diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 3d210e0000..0a1a3cb7f2 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -437,7 +437,7 @@ HELP: or HELP: xor { $values { "obj1" "a generalized boolean" } { "obj2" "a generalized boolean" } { "?" "a generalized boolean" } } -{ $description "Tests if at exactly one object is not " { $link f } "." } +{ $description "If exactly one input is false, outputs the other input. Otherwise outputs " { $link f } "." } { $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ; HELP: both? diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 195e9becae..5cb4abc2e9 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -50,6 +50,10 @@ IN: kernel.tests [ f ] [ 3 f and ] unit-test [ 4 ] [ 4 6 or ] unit-test [ 6 ] [ f 6 or ] unit-test +[ f ] [ 1 2 xor ] unit-test +[ 1 ] [ 1 f xor ] unit-test +[ 2 ] [ f 2 xor ] unit-test +[ f ] [ f f xor ] unit-test [ slip ] must-fail [ ] [ :c ] unit-test diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 47e0d76bf7..337fe6c8b0 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -173,7 +173,7 @@ GENERIC: boa ( ... class -- tuple ) : or ( obj1 obj2 -- ? ) dupd ? ; inline -: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline +: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline : both? ( x y quot -- ? ) bi@ and ; inline diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 100724ea58..e021ff4ff4 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,7 +1,7 @@ USING: kernel tools.test accessors arrays sequences qualified io.streams.string io.streams.duplex namespaces threads calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes assocs ; + concurrency.mailboxes classes assocs combinators ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -11,16 +11,16 @@ IN: irc.client.tests "\n" join ; : make-client ( lines -- irc-client ) - "someserver" irc-port "factorbot" f - swap [ 2nip f ] curry >>connect ; + "someserver" irc-port "factorbot" f + swap [ 2nip f ] curry >>connect ; : set-nick ( irc-client nickname -- ) - swap profile>> (>>nickname) ; + swap profile>> (>>nickname) ; -: with-dummy-client ( quot -- ) - rot with-variable ; inline +: with-dummy-client ( irc-client quot -- ) + [ current-irc-client ] dip with-variable ; inline -{ "" } make-client dup "factorbot" set-nick current-irc-client [ +{ "" } make-client dup "factorbot" set-nick [ { t } [ irc> profile>> nickname>> me? ] unit-test { "factorbot" } [ irc> profile>> nickname>> ] unit-test @@ -32,39 +32,144 @@ IN: irc.client.tests { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" parse-irc-line irc-message-origin ] unit-test -] with-variable +] with-dummy-client ! Test login and nickname set -{ "factorbot" } [ { "NOTICE AUTH :*** Looking up your hostname..." - "NOTICE AUTH :*** Checking ident" - "NOTICE AUTH :*** Found your hostname" - "NOTICE AUTH :*** No identd (auth) response" - ":some.where 001 factorbot :Welcome factorbot" - } make-client - [ connect-irc ] keep 1 seconds sleep - profile>> nickname>> ] unit-test +{ "factorbot" } [ + { "NOTICE AUTH :*** Looking up your hostname..." + "NOTICE AUTH :*** Checking ident" + "NOTICE AUTH :*** Found your hostname" + "NOTICE AUTH :*** No identd (auth) response" + ":some.where 001 factorbot :Welcome factorbot" + } make-client + { [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ profile>> nickname>> ] + [ terminate-irc ] + } cleave ] unit-test { join_ "#factortest" } [ - { ":factorbot!n=factorbo@some.where JOIN :#factortest" - ":ircserver.net MODE #factortest +ns" - ":ircserver.net 353 factorbot @ #factortest :@factorbot " - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." - ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" - } make-client dup "factorbot" set-nick - [ connect-irc ] keep 1 seconds sleep - join-messages>> 1 seconds mailbox-get-timeout - [ class ] [ trailing>> ] bi ] unit-test + { ":factorbot!n=factorbo@some.where JOIN :#factortest" + ":ircserver.net MODE #factortest +ns" + ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" + } make-client + { [ "factorbot" set-nick ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ join-messages>> 0.1 seconds mailbox-get-timeout ] + [ terminate-irc ] + } cleave + [ class ] [ trailing>> ] bi ] unit-test { +join+ "somebody" } [ - { ":somebody!n=somebody@some.where JOIN :#factortest" - } make-client dup "factorbot" set-nick - [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] - [ connect-irc ] - [ listeners>> [ "#factortest" ] dip at - [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri - [ action>> ] [ nick>> ] bi - ] unit-test -! TODO: channel message -! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" -! TODO: direct private message -! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file + { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] + [ terminate-irc ] + } cleave + [ action>> ] [ nick>> ] bi + ] unit-test + +{ privmsg "#factortest" "hello" } [ + { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test + +{ privmsg "factorbot" "hello" } [ + { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "somedude" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "somedude" ] dip at + [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + [ class ] [ name>> ] [ trailing>> ] tri + ] unit-test + +! Participants lists tests +{ H{ { "somedude" +normal+ } } } [ + { ":somedude!n=user@isp.net JOIN :#factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" +normal+ } } } [ + { ":somedude!n=user@isp.net PART #factortest" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" +normal+ } } } [ + { ":somedude!n=user@isp.net QUIT" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +{ H{ { "somedude2" +normal+ } } } [ + { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude2" +normal+ } + { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at participants>> ] + [ terminate-irc ] + } cleave + ] unit-test + +! Namelist notification +{ T{ participant-changed f f f } } [ + { ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] + [ terminate-irc ] + } cleave + ] unit-test \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 405d8ed9ed..813de0f57c 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -12,8 +12,6 @@ IN: irc.client ! Setup and running objects ! ====================================== -SYMBOL: current-irc-client - : irc-port 6667 ; ! Default irc port TUPLE: irc-profile server port nickname password ; @@ -51,7 +49,8 @@ SYMBOL: +mode+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - [ ] dip f 60 seconds H{ } clone irc-channel-listener boa ; + [ ] dip f 60 seconds H{ } clone + irc-channel-listener boa ; : ( name -- irc-nick-listener ) [ ] dip irc-nick-listener boa ; @@ -63,19 +62,24 @@ SYMBOL: +mode+ TUPLE: participant-changed nick action ; C: participant-changed +SINGLETON: irc-listener-end ! send to a listener to stop its execution 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 UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) - [ [ irc-end ] dip in-messages>> mailbox-put ] - [ [ f ] dip (>>is-running) ] - [ stream>> dispose ] - tri ; + [ is-running>> ] keep and [ + [ [ irc-end ] dip in-messages>> mailbox-put ] + [ [ f ] dip (>>is-running) ] + [ stream>> dispose ] + tri + ] when* ; stream-write ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; : listener> ( name -- listener/f ) irc> listeners>> at ; -: unregister-listener ( name -- ) irc> listeners>> delete-at ; + +: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- ) + [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -93,6 +99,12 @@ M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* [ to-listener ] [ drop ] if* ; +: unregister-listener ( name -- ) + irc> listeners>> + [ at [ irc-listener-end ] dip to-listener ] + [ delete-at ] + 2bi ; + M: irc-listener to-listener ( message irc-listener -- ) in-messages>> mailbox-put ; @@ -105,7 +117,7 @@ M: irc-listener to-listener ( message irc-listener -- ) with filter ; : remove-participant-from-all ( nick -- ) - dup listeners-with-participant [ delete-at ] with each ; + dup listeners-with-participant [ participants>> delete-at ] with each ; : add-participant ( mode nick channel -- ) listener> [ participants>> set-at ] [ 2drop ] if* ; @@ -206,9 +218,9 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - { [ maybe-forward-join ] ! keep + { [ maybe-forward-join ] [ dup trailing>> to-listener ] - [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ handle-participant-change ] } cleave ; @@ -219,19 +231,18 @@ M: part handle-incoming-irc ( part -- ) tri ; M: kick handle-incoming-irc ( kick -- ) - { [ dup channel>> to-listener ] + { [ dup channel>> to-listener ] [ [ who>> ] [ channel>> ] bi remove-participant ] [ handle-participant-change ] [ dup who>> me? [ unregister-listener ] [ drop ] if ] } cleave ; M: quit handle-incoming-irc ( quit -- ) - { [ dup prefix>> parse-name listeners-with-participant - [ to-listener ] with each ] - [ handle-participant-change ] - [ prefix>> parse-name remove-participant-from-all ] - [ ] - } cleave call-next-method ; + [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ prefix>> parse-name remove-participant-from-all ] + [ handle-participant-change ] + tri ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -241,8 +252,10 @@ M: quit handle-incoming-irc ( quit -- ) [ >nick/mode 2array ] map >hashtable ; M: names-reply handle-incoming-irc ( names-reply -- ) - [ names-reply>participants ] [ channel>> listener> ] bi - [ (>>participants) ] [ drop ] if* ; + [ names-reply>participants ] [ channel>> listener> ] bi [ + [ (>>participants) ] + [ [ f f ] dip name>> to-listener ] bi + ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; @@ -256,12 +269,6 @@ GENERIC: handle-outgoing-irc ( obj -- ) M: irc-message handle-outgoing-irc ( irc-message -- ) irc-message>client-line irc-print ; -M: privmsg handle-outgoing-irc ( privmsg -- ) - [ name>> ] [ trailing>> ] bi /PRIVMSG ; - -M: part handle-outgoing-irc ( part -- ) - [ channel>> ] [ trailing>> "" or ] bi /PART ; - ! ====================================== ! Reader/Writer ! ====================================== @@ -273,7 +280,7 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ [ irc-disconnected ] dip to-listener ] + [ [ irc-disconnected ] dip in-messages>> mailbox-put ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; @@ -291,35 +298,37 @@ DEFER: (connect-irc) ] if* ] with-destructors ; -: reader-loop ( -- ) - [ (reader-loop) ] [ handle-disconnect ] recover ; +: reader-loop ( -- ? ) + [ (reader-loop) ] [ handle-disconnect ] recover t ; -: writer-loop ( -- ) - irc> out-messages>> mailbox-get handle-outgoing-irc ; +: writer-loop ( -- ? ) + irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ; ! ====================================== ! Processing loops ! ====================================== -: in-multiplexer-loop ( -- ) - irc> in-messages>> mailbox-get handle-incoming-irc ; +: in-multiplexer-loop ( -- ? ) + irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; : maybe-annotate-with-name ( name obj -- obj ) - { - { [ dup string? ] [ strings>privmsg ] } - { [ dup privmsg instance? ] [ swap >>name ] } - [ nip ] + { { [ dup string? ] [ strings>privmsg ] } + { [ dup privmsg instance? ] [ swap >>name ] } + [ nip ] } cond ; -: listener-loop ( name listener -- ) - out-messages>> mailbox-get maybe-annotate-with-name - irc> out-messages>> mailbox-put ; +: listener-loop ( name -- ? ) + dup listener> [ + out-messages>> [ maybe-annotate-with-name + irc> out-messages>> mailbox-put ] with + maybe-mailbox-get t + ] [ drop f ] if* ; -: spawn-irc-loop ( quot name -- ) - [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip +: spawn-irc-loop ( quot: ( -- ? ) name -- ) + [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip spawn-server drop ; : spawn-irc ( -- ) @@ -332,9 +341,8 @@ DEFER: (connect-irc) ! ====================================== : set+run-listener ( name irc-listener -- ) - [ '[ , , listener-loop ] "listener" spawn-irc-loop ] - [ swap irc> listeners>> set-at ] - 2bi ; + over irc> listeners>> set-at + '[ , listener-loop ] "listener" spawn-irc-loop ; GENERIC: (add-listener) ( irc-listener -- ) @@ -371,16 +379,15 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) t >>is-running in-messages>> [ irc-connected ] dip mailbox-put ; -: with-irc-client ( irc-client quot -- ) +: with-irc-client ( irc-client quot: ( -- ) -- ) [ current-irc-client ] dip with-variable ; inline PRIVATE> : connect-irc ( irc-client -- ) - dup [ - [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi - spawn-irc - ] with-irc-client ; + [ irc> + [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi + spawn-irc ] with-irc-client ; : add-listener ( irc-listener irc-client -- ) swap '[ , (add-listener) ] with-irc-client ; diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 1bd6088f82..7ee0f41ab0 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -35,3 +35,23 @@ join new [ ":someuser!n=user@some.where JOIN :#factortest" parse-irc-line f >>timestamp ] unit-test +mode new + ":ircserver.net MODE #factortest +ns" >>line + "ircserver.net" >>prefix + "MODE" >>command + { "#factortest" "+ns" } >>parameters + "#factortest" >>channel + "+ns" >>mode +1array +[ ":ircserver.net MODE #factortest +ns" + parse-irc-line f >>timestamp ] unit-test + +nick new + ":someuser!n=user@some.where NICK :someuser2" >>line + "someuser!n=user@some.where" >>prefix + "NICK" >>command + { } >>parameters + "someuser2" >>trailing +1array +[ ":someuser!n=user@some.where NICK :someuser2" + parse-irc-line f >>timestamp ] unit-test \ No newline at end of file diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 5813c72723..3b9cf0af2c 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators qualified - arrays classes.tuple math.order ; + arrays classes.tuple math.order quotations ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.messages @@ -12,12 +12,13 @@ TUPLE: ping < irc-message ; TUPLE: join < irc-message ; TUPLE: part < irc-message channel ; TUPLE: quit < irc-message ; +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: notice < irc-message type ; -TUPLE: mode < irc-message name channel mode ; +TUPLE: mode < irc-message channel mode ; TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; @@ -25,12 +26,44 @@ TUPLE: unhandled < irc-message ; irc-message new now >>timestamp [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; +> ; +M: ping irc-command-string ( ping -- string ) drop "PING" ; +M: join irc-command-string ( join -- string ) drop "JOIN" ; +M: part irc-command-string ( part -- string ) drop "PART" ; +M: quit irc-command-string ( quit -- string ) drop "QUIT" ; +M: nick irc-command-string ( nick -- string ) drop "NICK" ; +M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; +M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; +M: mode irc-command-string ( mode -- string ) drop "MODE" ; +M: kick irc-command-string ( kick -- string ) drop "KICK" ; + +GENERIC: irc-command-parameters ( irc-message -- seq ) + +M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ; +M: ping irc-command-parameters ( ping -- seq ) drop { } ; +M: join irc-command-parameters ( join -- seq ) drop { } ; +M: part irc-command-parameters ( part -- seq ) name>> 1array ; +M: quit irc-command-parameters ( quit -- seq ) drop { } ; +M: nick irc-command-parameters ( nick -- seq ) drop { } ; +M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; +M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; +M: kick irc-command-parameters ( kick -- seq ) + [ channel>> ] [ who>> ] bi 2array ; +M: mode irc-command-parameters ( mode -- seq ) + [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; + +PRIVATE> + GENERIC: irc-message>client-line ( irc-message -- string ) M: irc-message irc-message>client-line ( irc-message -- string ) - [ command>> ] - [ parameters>> " " sjoin ] - [ trailing>> dup [ CHAR: : prefix ] when ] + [ irc-command-string ] + [ irc-command-parameters " " sjoin ] + [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] tri 3array " " sjoin ; GENERIC: irc-message>server-line ( irc-message -- string ) @@ -73,19 +106,20 @@ PRIVATE> : parse-irc-line ( string -- message ) string>irc-message dup command>> { - { "PING" [ \ ping ] } - { "NOTICE" [ \ notice ] } - { "001" [ \ logged-in ] } - { "433" [ \ nick-in-use ] } - { "353" [ \ names-reply ] } - { "JOIN" [ \ join ] } - { "PART" [ \ part ] } - { "PRIVMSG" [ \ privmsg ] } - { "QUIT" [ \ quit ] } - { "MODE" [ \ mode ] } - { "KICK" [ \ kick ] } - [ drop \ unhandled ] + { "PING" [ ping ] } + { "NOTICE" [ notice ] } + { "001" [ logged-in ] } + { "433" [ nick-in-use ] } + { "353" [ names-reply ] } + { "JOIN" [ join ] } + { "PART" [ part ] } + { "NICK" [ nick ] } + { "PRIVMSG" [ privmsg ] } + { "QUIT" [ quit ] } + { "MODE" [ mode ] } + { "KICK" [ kick ] } + [ drop unhandled ] } case [ [ tuple-slots ] [ parameters>> ] bi append ] dip - [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; - + [ all-slots over [ length ] bi@ min head >quotation ] keep + '[ @ , boa nip ] call ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 9b8d1a4d11..0ceeed1d35 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -5,10 +5,12 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures - ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels - io io.styles namespaces calendar calendar.format models + ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels + io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private - irc.ui.commandparser irc.ui.load ; + irc.ui.commandparser irc.ui.load qualified ; + +RENAME: join sequences => sjoin IN: irc.ui @@ -18,7 +20,7 @@ SYMBOL: client TUPLE: ui-window client tabs ; -TUPLE: irc-tab < frame listener client listmodel ; +TUPLE: irc-tab < frame listener client userlist ; : write-color ( str color -- ) foreground associate format ; @@ -71,14 +73,21 @@ M: quit write-irc " has left IRC" red write-color trailing>> dot-or-parens red write-color ; +: full-mode ( message -- mode ) + parameters>> rest " " sjoin ; + M: mode write-irc "* " blue write-color - [ name>> write ] keep + [ prefix>> parse-name write ] keep " has applied mode " blue write-color - [ mode>> write ] keep + [ full-mode write ] keep " to " blue write-color channel>> write ; +M: unhandled write-irc + "UNHANDLED: " write + line>> blue write-color ; + M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -88,11 +97,17 @@ M: irc-disconnected write-irc M: irc-connected write-irc drop "* Connected" green write-color ; +M: irc-listener-end write-irc + drop ; + M: irc-message write-irc drop ; ! catch all unimplemented writes, THIS WILL CHANGE +: time-happened ( irc-message -- timestamp ) + [ timestamp>> ] [ 2drop now ] recover ; + : print-irc ( irc-message -- ) - [ timestamp>> timestamp>hms write " " write ] + [ time-happened timestamp>hms write " " write ] [ write-irc nl ] bi ; : send-message ( message -- ) @@ -101,16 +116,15 @@ M: irc-message write-irc GENERIC: handle-inbox ( tab message -- ) -: filter-participants ( assoc val -- alist ) - [ >alist ] dip - '[ second , = ] filter ; +: filter-participants ( pack alist val color -- ) + '[ , = [