irc.client: Fixes, refactoring

diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
index 932bdda472e0cb55a327ec6f49bdc0dd274509bb..c768c1a82ef47beb6c351757ba85260c7717fe31 100644 (file)
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@@ -20,7 +20,7 @@ M: mb-writer stream-nl ( mb-writer -- )
     [ [ last-line>> concat ] [ lines>> ] bi push ] keep
     V{ } clone >>last-line drop ;
 
-: spawn-client ( lines listeners -- irc-client )
+: spawn-client ( -- irc-client )
     "someserver" irc-port "factorbot" f <irc-profile>
     <irc-client>
         t >>is-running

diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index db4fdd2a584726b2dcd45cbd4ce6498513a32fca..569f6c4bf76b1832f588606d85fd5a20ca2adf3a 100755 (executable)
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -68,12 +68,17 @@ 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 [
-        [ [ irc-end ] dip in-messages>> mailbox-put ]
-        [ [ f ] dip (>>is-running) ]
-        [ stream>> dispose ]
-        tri
+        [ end-loops ] [ [ f ] dip (>>is-running) ] bi
     ] when* ;
 
 <PRIVATE
@@ -90,7 +95,8 @@ SYMBOL: current-irc-client
 : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
 : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
 : listener> ( name -- listener/f ) irc> listeners>> at ;
-
+: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
+: me? ( string -- ? ) irc> profile>> nickname>> = ;
 
 GENERIC: to-listener ( message obj -- )
 
@@ -137,10 +143,14 @@ M: irc-listener to-listener ( message irc-listener -- )
     swap dup listeners-with-participant [ rename-participant ] with with each ;
 
 : add-participant ( mode nick channel -- )
-    listener> [
-        [ participants>> set-at ]
-        [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
-    ] [ 2drop ] if* ;
+    listener>
+    [ participants>> set-at ]
+    [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ;
+
+: change-participant-mode ( channel mode nick -- )
+    rot listener>
+    [ participants>> set-at ]
+    [ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
 
 DEFER: me?
 
@@ -174,9 +184,6 @@ DEFER: me?
 ! Server message handling
 ! ======================================
 
-: me? ( string -- ? )
-    irc> profile>> nickname>> = ;
-
 GENERIC: forward-name ( irc-message -- name )
 M: join forward-name ( join -- name ) trailing>> ;
 M: part forward-name ( part -- name ) channel>> ;
@@ -220,7 +227,8 @@ M: nick-in-use process-message ( nick-in-use -- )
     name>> "_" append /NICK ;
 
 M: join process-message ( join -- )
-    [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
+    [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
+    dup listener> [ add-participant ] [ 3drop ] if ;
 
 M: part process-message ( part -- )
     [ irc-message-sender ] [ channel>> ] bi remove-participant ;
@@ -236,6 +244,12 @@ M: quit process-message ( quit -- )
 M: nick process-message ( nick -- )
     [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
 
+! M: mode process-message ( mode -- )
+!    [ channel-mode? ] keep and [
+!        [ name>> ] [ mode>> ] [ parameter>> ] tri
+!        [ change-participant-mode ] [ 2drop ] if*
+!    ] when* ;
+
 : >nick/mode ( string -- nick mode )
     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
 
@@ -249,15 +263,14 @@ M: names-reply process-message ( names-reply -- )
         [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
     ] [ drop ] if* ;
 
-: handle-incoming-irc ( irc-message -- )
-    [ forward-message ] [ process-message ] bi ;
-
 ! ======================================
 ! Client message handling
 ! ======================================
 
-: handle-outgoing-irc ( irc-message -- )
-    irc-message>client-line irc-print ;
+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 ;
 
 ! ======================================
 ! Reader/Writer
@@ -279,27 +292,28 @@ DEFER: (connect-irc)
 : handle-disconnect ( error -- )
     drop irc> is-running>> [ (handle-disconnect) ] when ;
 
-: (reader-loop) ( -- )
+: (reader-loop) ( -- ? )
     irc> stream>> [
         |dispose stream-readln [
-            parse-irc-line handle-reader-message
+            parse-irc-line handle-reader-message t
         ] [
-            irc> terminate-irc
+            irc> terminate-irc f
         ] if*
     ] with-destructors ;
 
 : reader-loop ( -- ? )
-    [ (reader-loop) ] [ handle-disconnect ] recover t ;
+    [ (reader-loop) ] [ handle-disconnect t ] recover ;
 
 : writer-loop ( -- ? )
-    irc> out-messages>> mailbox-get handle-outgoing-irc t ;
+    irc> out-messages>> mailbox-get handle-outgoing-irc ;
 
 ! ======================================
 ! Processing loops
 ! ======================================
 
 : in-multiplexer-loop ( -- ? )
-    irc> in-messages>> mailbox-get handle-incoming-irc t ;
+    irc> in-messages>> mailbox-get
+    [ forward-message ] [ process-message ] [ irc-end? not ] tri ;
 
 : strings>privmsg ( name string -- privmsg )
     privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
@@ -310,22 +324,22 @@ 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
-        irc> out-messages>> mailbox-put
-        t
+        maybe-annotate-with-name handle-listener-out
     ] [ drop f ] if* ;
 
-: spawn-irc-loop ( quot: ( -- ? ) name -- )
-    [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
-    spawn-server drop ;
-
 : spawn-irc ( -- )
-    [ reader-loop ] "irc-reader-loop" spawn-irc-loop
-    [ writer-loop ] "irc-writer-loop" spawn-irc-loop
-    [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
+    [ reader-loop ] "irc-reader-loop" spawn-server
+    [ writer-loop ] "irc-writer-loop" spawn-server
+    [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
+    3drop ;
 
 ! ======================================
 ! Listener join request handling
@@ -333,7 +347,7 @@ DEFER: (connect-irc)
 
 : set+run-listener ( name irc-listener -- )
     over irc> listeners>> set-at
-    '[ _ listener-loop ] "listener" spawn-irc-loop ;
+    '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
 
 GENERIC: (add-listener) ( irc-listener -- )