diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 932bdda472..c768c1a82e 100644 --- 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 t >>is-running diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index db4fdd2a58..569f6c4bf7 100755 --- 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 +> 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* ; [ 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 ] dip to-listener ] 2bi - ] [ 2drop ] if* ; + listener> + [ participants>> set-at ] + [ [ +join+ f ] dip to-listener ] 2bi ; + +: change-participant-mode ( channel mode nick -- ) + rot listener> + [ participants>> set-at ] + [ [ [ +mode+ ] dip ] 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 ] 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 -- )