]> gitweb.factorcode.org Git - factor.git/commitdiff
irc.client: Refactor, clean, etc. Stop using a thread for each listener for output...
authorBruno Deferrari <utizoc@gmail.com>
Thu, 25 Sep 2008 04:05:44 +0000 (01:05 -0300)
committerBruno Deferrari <utizoc@gmail.com>
Mon, 29 Sep 2008 01:11:58 +0000 (22:11 -0300)
extra/irc/client/client-tests.factor
extra/irc/client/client.factor
extra/irc/messages/messages-tests.factor
extra/irc/messages/messages.factor
extra/irc/ui/ui.factor

index 3554f6c120e9cea11356781f6fb2091cb27dba2a..acd5a783dbdd18440302bc1ca2477f0e4dee76c0 100644 (file)
@@ -28,9 +28,11 @@ M: mb-writer stream-nl ( mb-writer -- )
     dup [ spawn-irc yield ] with-irc-client ;
 
 ! to be used inside with-irc-client quotations
-: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
-: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
+: %add-named-listener ( listener -- ) irc> add-listener ;
 : %push-line ( line -- ) irc> stream>> in>> push-line yield ;
+: %join ( channel -- )
+    <irc-channel-listener>
+    [ irc> add-listener ] [ join-irc-channel ] bi ;
 
 : read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
     [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
@@ -62,13 +64,28 @@ M: mb-writer stream-nl ( mb-writer -- )
   ] unit-test
 ] with-irc
 
+! Test connect
+{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
+   "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+    [ 2drop <test-stream> t ] >>connect
+    [ connect-irc ] keep stream>> out>> lines>>
+] unit-test
+
+! Test join
+[ { "JOIN #factortest" } [
+      "#factortest" %join
+      irc> stream>> out>> lines>> pop
+  ] unit-test
+] with-irc
+
 [ { join_ "#factortest" } [
+      "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
       { ":factorbot!n=factorbo@some.where JOIN :#factortest"
         ":ircserver.net 353 factorbot @ #factortest :@factorbot "
         ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
         ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
       } [ %push-line ] each
-      irc> join-messages>> 0.1 seconds mailbox-get-timeout
+      in-messages>> 0.1 seconds mailbox-get-timeout
       [ class ] [ trailing>> ] bi
   ] unit-test
 ] with-irc
@@ -89,8 +106,8 @@ M: mb-writer stream-nl ( mb-writer -- )
 ] with-irc
 
 [ { privmsg "factorbot" "hello" } [
-      "somedude" <irc-nick-listener>  [ %add-named-listener ] keep
-      ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
+      "ircuser" <irc-nick-listener>  [ %add-named-listener ] keep
+      ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
       [ privmsg? ] read-matching-message
       [ class ] [ name>> ] [ trailing>> ] tri
   ] unit-test
@@ -104,48 +121,48 @@ M: mb-writer stream-nl ( mb-writer -- )
 ] with-irc
 
 ! Participant lists tests
-[ { H{ { "somedude" +normal+ } } } [
+[ { H{ { "ircuser" +normal+ } } } [
       "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
-      ":somedude!n=user@isp.net JOIN :#factortest" %push-line
+      ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
       participants>>
   ] unit-test
 ] with-irc
 
-[ { H{ { "somedude2" +normal+ } } } [
+[ { H{ { "ircuser2" +normal+ } } } [
       "#factortest" <irc-channel-listener>
-          H{ { "somedude2" +normal+ }
-             { "somedude" +normal+ } } clone >>participants
+          H{ { "ircuser2" +normal+ }
+             { "ircuser" +normal+ } } clone >>participants
       [ %add-named-listener ] keep
-      ":somedude!n=user@isp.net PART #factortest" %push-line
+      ":ircuser!n=user@isp.net PART #factortest" %push-line
       participants>>
   ] unit-test
 ] with-irc
 
-[ { H{ { "somedude2" +normal+ } } } [
+[ { H{ { "ircuser2" +normal+ } } } [
       "#factortest" <irc-channel-listener>
-          H{ { "somedude2" +normal+ }
-             { "somedude" +normal+ } } clone >>participants
+          H{ { "ircuser2" +normal+ }
+             { "ircuser" +normal+ } } clone >>participants
       [ %add-named-listener ] keep
-      ":somedude!n=user@isp.net QUIT" %push-line
+      ":ircuser!n=user@isp.net QUIT" %push-line
       participants>>
   ] unit-test
 ] with-irc
 
-[ { H{ { "somedude2" +normal+ } } } [
+[ { H{ { "ircuser2" +normal+ } } } [
       "#factortest" <irc-channel-listener>
-          H{ { "somedude2" +normal+ }
-             { "somedude" +normal+ } } clone >>participants
+          H{ { "ircuser2" +normal+ }
+             { "ircuser" +normal+ } } clone >>participants
       [ %add-named-listener ] keep
-      ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line
+      ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
       participants>>
   ] unit-test
 ] with-irc
 
-[ { H{ { "somedude2" +normal+ } } } [
+[ { H{ { "ircuser2" +normal+ } } } [
       "#factortest" <irc-channel-listener>
-          H{ { "somedude" +normal+ } } clone >>participants
+          H{ { "ircuser" +normal+ } } clone >>participants
       [ %add-named-listener ] keep
-      ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+      ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
       participants>>
   ] unit-test
 ] with-irc
@@ -159,20 +176,20 @@ M: mb-writer stream-nl ( mb-writer -- )
   ] unit-test
 ] with-irc
 
-[ { T{ participant-changed f "somedude" +part+ f } } [
+[ { T{ participant-changed f "ircuser" +part+ f } } [
       "#factortest" <irc-channel-listener>
-          H{ { "somedude" +normal+ } } clone >>participants
+          H{ { "ircuser" +normal+ } } clone >>participants
       [ %add-named-listener ] keep
-      ":somedude!n=user@isp.net QUIT" %push-line
+      ":ircuser!n=user@isp.net QUIT" %push-line
       [ participant-changed? ] read-matching-message
   ] unit-test
 ] with-irc
 
-[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [
+[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
       "#factortest" <irc-channel-listener>
-          H{ { "somedude" +normal+ } } clone >>participants
+          H{ { "ircuser" +normal+ } } clone >>participants
       [ %add-named-listener ] keep
-      ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+      ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
       [ participant-changed? ] read-matching-message
   ] unit-test
 ] with-irc
index b6eeec9468b80ee8cd704b796815f046f431deba..ca16ff3b887eb2f3c47d97f192de29d130571352 100755 (executable)
@@ -17,13 +17,13 @@ IN: irc.client
 TUPLE: irc-profile server port nickname password ;
 C: <irc-profile> irc-profile
 
-TUPLE: irc-client profile stream in-messages out-messages join-messages
+TUPLE: irc-client profile stream in-messages out-messages
        listeners is-running nick connect reconnect-time ;
 : <irc-client> ( profile -- irc-client )
-    [ f <mailbox> <mailbox> <mailbox> H{ } clone f ] keep nickname>>
+    [ f <mailbox> <mailbox> H{ } clone f ] keep nickname>>
     [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
 
-TUPLE: irc-listener in-messages out-messages ;
+TUPLE: irc-listener in-messages client ;
 TUPLE: irc-server-listener < irc-listener ;
 TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
 TUPLE: irc-nick-listener < irc-listener name ;
@@ -47,14 +47,14 @@ SYMBOL: +nick+
 : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
 
 : <irc-server-listener> ( -- irc-server-listener )
-     <mailbox> <mailbox> irc-server-listener boa ;
+     <mailbox> f irc-server-listener boa ;
 
 : <irc-channel-listener> ( name -- irc-channel-listener )
-     [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
+     [ <mailbox> f ] dip f 60 seconds H{ } clone
      irc-channel-listener boa ;
 
 : <irc-nick-listener> ( name -- irc-nick-listener )
-     [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
+     [ <mailbox> f ] dip irc-nick-listener boa ;
 
 ! ======================================
 ! Message objects
@@ -68,19 +68,11 @@ SINGLETON: irc-end          ! sent when the client isn't running anymore
 SINGLETON: irc-disconnected ! sent when connection is lost
 SINGLETON: irc-connected    ! sent when connection is established
 
-<PRIVATE
-: end-loops ( irc-client -- )
-     [ listeners>> values [ out-messages>> ] map ]
-     [ in-messages>> ]
-     [ out-messages>> ] tri 2array prepend
-     [ irc-end swap mailbox-put ] each ;
-PRIVATE>
-
 : terminate-irc ( irc-client -- )
     [ is-running>> ] keep and [
-        [ end-loops ]
-        [ [ f ] dip (>>is-running) ]
-        bi
+        f >>is-running
+        [ in-messages>> ] [ out-messages>> ] bi 2array
+        [ irc-end swap mailbox-put ] each
     ] when* ;
 
 <PRIVATE
@@ -102,12 +94,11 @@ SYMBOL: current-irc-client
 
 GENERIC: to-listener ( message obj -- )
 
-M: string to-listener ( message string -- )
+M: string to-listener
     listener> [ +server-listener+ listener> ] unless*
     [ to-listener ] [ drop ] if* ;
 
-M: irc-listener to-listener ( message irc-listener -- )
-    in-messages>> mailbox-put ;
+M: irc-listener to-listener in-messages>> mailbox-put ;
 
 : unregister-listener ( name -- )
     irc> listeners>>
@@ -156,10 +147,6 @@ M: irc-listener to-listener ( message irc-listener -- )
 
 DEFER: me?
 
-: maybe-forward-join ( join -- )
-    [ irc-message-sender me? ] keep and
-    [ irc> join-messages>> mailbox-put ] when* ;
-
 ! ======================================
 ! IRC client messages
 ! ======================================
@@ -187,63 +174,50 @@ DEFER: me?
 ! ======================================
 
 GENERIC: forward-name ( irc-message -- name )
-M: join forward-name ( join -- name ) trailing>> ;
-M: part forward-name ( part -- name ) channel>> ;
-M: kick forward-name ( kick -- name ) channel>> ;
-M: mode forward-name ( mode -- name ) name>> ;
-M: privmsg forward-name ( privmsg -- name )
-    dup name>> me? [ irc-message-sender ] [ name>> ] if ;
+M: join forward-name trailing>> ;
+M: part forward-name channel>> ;
+M: kick forward-name channel>> ;
+M: mode forward-name name>> ;
+M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
 
 UNION: single-forward join part kick mode privmsg ;
 UNION: multiple-forward nick quit ;
 UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
 GENERIC: forward-message ( irc-message -- )
 
-M: irc-message forward-message ( irc-message -- )
+M: irc-message forward-message
     +server-listener+ listener> [ to-listener ] [ drop ] if* ;
 
-M: single-forward forward-message ( forward-single -- )
-    dup forward-name to-listener ;
+M: single-forward forward-message dup forward-name to-listener ;
 
-M: multiple-forward forward-message ( multiple-forward -- )
+M: multiple-forward forward-message
     dup irc-message-sender to-listeners-with-participant ;
-
-M: join forward-message ( join -- )
-    [ maybe-forward-join ] [ call-next-method ] bi ;
-    
-M: broadcast-forward forward-message ( irc-broadcasted-message -- )
+  
+M: broadcast-forward forward-message
     irc> listeners>> values [ to-listener ] with each ;
 
 GENERIC: process-message ( irc-message -- )
+M: object      process-message drop ; 
+M: logged-in   process-message name>> irc> (>>nick) ;
+M: ping        process-message trailing>> /PONG ;
+M: nick-in-use process-message name>> "_" append /NICK ;
 
-M: object process-message ( object -- )
-    drop ;
-    
-M: logged-in process-message ( logged-in -- )
-    name>> irc> (>>nick) ;
-
-M: ping process-message ( ping -- )
-    trailing>> /PONG ;
-
-M: nick-in-use process-message ( nick-in-use -- )
-    name>> "_" append /NICK ;
-
-M: join process-message ( join -- )
+M: join process-message
     [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
     dup listener> [ add-participant ] [ 3drop ] if ;
 
-M: part process-message ( part -- )
+M: part process-message
     [ irc-message-sender ] [ channel>> ] bi remove-participant ;
 
-M: kick process-message ( kick -- )
+M: kick process-message
     [ [ who>> ] [ channel>> ] bi remove-participant ]
     [ dup who>> me? [ unregister-listener ] [ drop ] if ]
     bi ;
 
-M: quit process-message ( quit -- )
+M: quit process-message
     irc-message-sender remove-participant-from-all ;
 
-M: nick process-message ( nick -- )
+M: nick process-message
     [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
 
 ! M: mode process-message ( mode -- )
@@ -259,7 +233,7 @@ M: nick process-message ( nick -- )
     trailing>> [ blank? ] trim " " split
     [ >nick/mode 2array ] map >hashtable ;
 
-M: names-reply process-message ( names-reply -- )
+M: names-reply process-message
     [ names-reply>participants ] [ channel>> listener> ] bi [
         [ (>>participants) ]
         [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
@@ -270,9 +244,8 @@ M: names-reply process-message ( names-reply -- )
 ! ======================================
 
 GENERIC: handle-outgoing-irc ( irc-message -- ? )
-M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ;
-M: irc-message handle-outgoing-irc ( irc-message -- ? )
-    irc-message>client-line irc-print t ;
+M: irc-end     handle-outgoing-irc drop f ;
+M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
 
 ! ======================================
 ! Reader/Writer
@@ -326,16 +299,11 @@ DEFER: (connect-irc)
       [ nip ]
     } cond ;
 
-GENERIC: handle-listener-out ( irc-message -- ? )
-M: irc-end handle-listener-out ( irc-end -- ? ) drop f ;
-M: irc-message handle-listener-out ( irc-message -- ? )
-     irc> out-messages>> mailbox-put t ;
-    
-: listener-loop ( name -- ? )
-    dup listener> [
-        out-messages>> mailbox-get
-        maybe-annotate-with-name handle-listener-out
-    ] [ drop f ] if* ;
+GENERIC: annotate-message ( listener object -- object )
+M: object  annotate-message nip ;
+M: part    annotate-message swap name>> >>channel ;
+M: privmsg annotate-message swap name>> >>name ;
+M: string  annotate-message [ name>> ] dip strings>privmsg ;
 
 : spawn-irc ( -- )
     [ reader-loop ] "irc-reader-loop" spawn-server
@@ -343,48 +311,33 @@ M: irc-message handle-listener-out ( irc-message -- ? )
     [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
     3drop ;
 
-! ======================================
-! Listener join request handling
-! ======================================
-
-: set+run-listener ( name irc-listener -- )
-    over irc> listeners>> set-at
-    '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
-
 GENERIC: (add-listener) ( irc-listener -- )
 
-M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
-    [ [ name>> ] [ password>> ] bi /JOIN ]
-    [ [ [ drop irc> join-messages>> ]
-        [ timeout>> ]
-        [ name>> '[ trailing>> _ = ] ]
-        tri mailbox-get-timeout? trailing>> ] keep set+run-listener
-    ] bi ;
+M: irc-listener (add-listener)
+    [ irc> >>client ] [ name>> ] bi irc> listeners>> set-at ;
 
-M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
-    [ name>> ] keep set+run-listener ;
-
-M: irc-server-listener (add-listener) ( irc-server-listener -- )
-    [ +server-listener+ ] dip set+run-listener ;
+M: irc-server-listener (add-listener)
+    irc> >>client +server-listener+ irc> listeners>> set-at ;
 
 GENERIC: (remove-listener) ( irc-listener -- )
 
-M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
+M: irc-nick-listener (remove-listener)
     name>> unregister-listener ;
 
-M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
-    [ [ name>> ] [ out-messages>> ] bi
-      [ [ part new ] dip >>channel ] dip mailbox-put ] keep
+M: irc-channel-listener (remove-listener)
+    [ part new annotate-message irc> out-messages>> mailbox-put  ] keep
     name>> unregister-listener ;
 
-M: irc-server-listener (remove-listener) ( irc-server-listener -- )
+M: irc-server-listener (remove-listener)
    drop +server-listener+ unregister-listener ;
 
 : (connect-irc) ( irc-client -- )
-    [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
-        swap >>stream
-        t >>is-running
-    in-messages>> [ irc-connected ] dip mailbox-put ;
+    {
+        [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
+        [ (>>stream) ]
+        [ t swap (>>is-running) ]
+        [ in-messages>> [ irc-connected ] dip mailbox-put ]
+    } cleave ;
 
 : with-irc-client ( irc-client quot: ( -- ) -- )
     [ \ current-irc-client ] dip with-variable ; inline
@@ -392,15 +345,18 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
 PRIVATE>
 
 : connect-irc ( irc-client -- )
-    [ irc>
-      [ (connect-irc) ] [ nick>> /LOGIN ] bi
-      spawn-irc ] with-irc-client ;
+    dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
 
 : add-listener ( irc-listener irc-client -- )
     swap '[ _ (add-listener) ] with-irc-client ;
 
-: remove-listener ( irc-listener irc-client -- )
-    swap '[ _ (remove-listener) ] with-irc-client ;
+: remove-listener ( irc-listener -- )
+    [ client>> ] keep '[ _ (remove-listener) ] with-irc-client ;
+
+: join-irc-channel ( irc-channel-listener -- )
+    dup client>> [ [ name>> ] [ password>> ] bi /JOIN ] with-irc-client ;
+
+: write-message ( message irc-listener -- )
+    [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
 
-: write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
 : read-message ( irc-listener -- message ) in-messages>> mailbox-get ;
index b61dd1644848eaf573dc8a6e57767a8fc786934a..41272a43f20109e9dbe9822c7d5bcf02b996bd50 100644 (file)
@@ -62,4 +62,14 @@ IN: irc.messages.tests
      { parameters  { } }
      { trailing "someuser2" } } }
 [ ":someuser!n=user@some.where NICK :someuser2"
+  parse-irc-line f >>timestamp ] unit-test
+
+{ T{ nick-in-use
+     { line ":ircserver.net 433 * nickname :Nickname is already in use" }
+     { prefix "ircserver.net" }
+     { command "433" }
+     { parameters { "*" "nickname" } }
+     { name "nickname" }
+     { trailing "Nickname is already in use" } } }
+[ ":ircserver.net 433 * nickname :Nickname is already in use"
   parse-irc-line f >>timestamp ] unit-test
\ No newline at end of file
index 9201f822dab80be6ca6d3e6138dbacb82a9e7d52..882cec5c8d88705dc385518d060cbfa31b6d8c87 100755 (executable)
@@ -17,7 +17,7 @@ TUPLE: nick < irc-message ;
 TUPLE: privmsg < irc-message name ;
 TUPLE: kick < irc-message channel who ;
 TUPLE: roomlist < irc-message channel names ;
-TUPLE: nick-in-use < irc-message asterisk name ;
+TUPLE: nick-in-use < irc-message name ;
 TUPLE: notice < irc-message type ;
 TUPLE: mode < irc-message name mode parameter ;
 TUPLE: names-reply < irc-message who channel ;
@@ -31,45 +31,43 @@ TUPLE: unhandled < irc-message ;
 
 GENERIC: command-string>> ( irc-message -- string )
 
-M: irc-message command-string>> ( irc-message -- string ) command>> ;
-M: ping        command-string>> ( ping -- string )    drop "PING" ;
-M: join        command-string>> ( join -- string )    drop "JOIN" ;
-M: part        command-string>> ( part -- string )    drop "PART" ;
-M: quit        command-string>> ( quit -- string )    drop "QUIT" ;
-M: nick        command-string>> ( nick -- string )    drop "NICK" ;
-M: privmsg     command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
-M: notice      command-string>> ( notice -- string )  drop "NOTICE" ;
-M: mode        command-string>> ( mode -- string )    drop "MODE" ;
-M: kick        command-string>> ( kick -- string )    drop "KICK" ;
+M: irc-message command-string>> command>> ;
+M: ping        command-string>> drop "PING" ;
+M: join        command-string>> drop "JOIN" ;
+M: part        command-string>> drop "PART" ;
+M: quit        command-string>> drop "QUIT" ;
+M: nick        command-string>> drop "NICK" ;
+M: privmsg     command-string>> drop "PRIVMSG" ;
+M: notice      command-string>> drop "NOTICE" ;
+M: mode        command-string>> drop "MODE" ;
+M: kick        command-string>> drop "KICK" ;
 
 GENERIC: command-parameters>> ( irc-message -- seq )
 
-M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
-M: ping        command-parameters>> ( ping -- seq )    drop { } ;
-M: join        command-parameters>> ( join -- seq )    drop { } ;
-M: part        command-parameters>> ( part -- seq )    channel>> 1array ;
-M: quit        command-parameters>> ( quit -- seq )    drop { } ;
-M: nick        command-parameters>> ( nick -- seq )    drop { } ;
-M: privmsg     command-parameters>> ( privmsg -- seq ) name>> 1array ;
-M: notice      command-parameters>> ( norice -- seq )  type>> 1array ;
-M: kick command-parameters>> ( kick -- seq )
-    [ channel>> ] [ who>> ] bi 2array ;
-M: mode command-parameters>> ( mode -- seq )
-    [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
+M: irc-message command-parameters>> parameters>> ;
+M: ping        command-parameters>> drop { } ;
+M: join        command-parameters>> drop { } ;
+M: part        command-parameters>> channel>> 1array ;
+M: quit        command-parameters>> drop { } ;
+M: nick        command-parameters>> drop { } ;
+M: privmsg     command-parameters>> name>> 1array ;
+M: notice      command-parameters>> type>> 1array ;
+M: kick command-parameters>> [ channel>> ] [ who>> ] bi 2array ;
+M: mode command-parameters>> [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
 
 GENERIC: (>>command-parameters) ( params irc-message -- )
 
-M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ;
-M: logged-in (>>command-parameters) ( params part -- )  [ first ] dip (>>name) ;
-M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ;
-M: notice  (>>command-parameters) ( params notice -- )  [ first ] dip (>>type) ;
-M: part    (>>command-parameters) ( params part -- )
-    [ first ] dip (>>channel) ;
-M: kick    (>>command-parameters) ( params kick -- )
+M: irc-message (>>command-parameters) 2drop ;
+M: logged-in (>>command-parameters) [ first ] dip (>>name) ;
+M: privmsg (>>command-parameters) [ first ] dip (>>name) ;
+M: notice  (>>command-parameters) [ first ] dip (>>type) ;
+M: part    (>>command-parameters) [ first ] dip (>>channel) ;
+M: nick-in-use (>>command-parameters) [ second ] dip (>>name) ;
+M: kick    (>>command-parameters)
     [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
-M: names-reply (>>command-parameters) ( params names-reply -- )
+M: names-reply (>>command-parameters)
     [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
-M: mode    (>>command-parameters) ( params mode -- )
+M: mode    (>>command-parameters)
     { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
       { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
     } switch ;
@@ -78,16 +76,14 @@ PRIVATE>
 
 GENERIC: irc-message>client-line ( irc-message -- string )
 
-M: irc-message irc-message>client-line ( irc-message -- string )
+M: irc-message irc-message>client-line
     [ command-string>> ]
     [ command-parameters>> " " sjoin ]
     [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
     tri 3array " " sjoin ;
 
 GENERIC: irc-message>server-line ( irc-message -- string )
-
-M: irc-message irc-message>server-line ( irc-message -- string )
-   drop "not implemented yet" ;
+M: irc-message irc-message>server-line drop "not implemented yet" ;
 
 <PRIVATE
 ! ======================================
@@ -124,8 +120,7 @@ PRIVATE>
 
 UNION: sender-in-prefix privmsg join part quit kick mode nick ;
 GENERIC: irc-message-sender ( irc-message -- sender )
-M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
-    prefix>> parse-name ;
+M: sender-in-prefix irc-message-sender prefix>> parse-name ;
 
 : string>irc-message ( string -- object )
     dup split-prefix split-trailing
index 1e4bcf35f81911e238b5689518b7dd5ad964f09a..c171fef0b639bb6ea0e69ef07a25860dcb217206 100755 (executable)
@@ -182,11 +182,16 @@ irc-editor "general" f {
     <irc-pane> [ <scroller> @center grid-add ] keep\r
     <irc-editor> <scroller> @bottom grid-add ;\r
 \r
+GENERIC: init-listener ( listener -- )\r
+M: object init-listener drop ;\r
+M: irc-channel-listener init-listener join-irc-channel ;\r
+\r
 M: irc-tab graft*\r
-    [ listener>> ] [ window>> client>> ] bi add-listener ;\r
+    [ listener>> dup ] [ window>> client>> ] bi add-listener\r
+    init-listener ;\r
 \r
 M: irc-tab ungraft*\r
-    [ listener>> ] [ window>> client>> ] bi remove-listener ;\r
+    listener>> remove-listener ;\r
 \r
 TUPLE: irc-channel-tab < irc-tab userlist ;\r
 \r
@@ -239,8 +244,9 @@ M: irc-tab pref-dim*
       [ connect-irc ] } cleave ;\r
 \r
 : server-open ( server port nick password channels -- )\r
-    [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
-    [ over join-channel ] each drop ;\r
+    [ <irc-profile> ui-connect [ irc-window ] keep ] dip 2drop ;\r
+! FIXME: should join channels only after we have been logged in\r
+!    [ over join-channel ] each drop ;\r
 \r
 : main-run ( -- ) run-ircui ;\r
 \r