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
"\n" join <string-reader> <string-writer> <duplex-stream> ;
: make-client ( lines -- irc-client )
- "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
- swap [ 2nip <test-stream> f ] curry >>connect ;
+ "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+ swap [ 2nip <test-stream> 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
{ "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" [ <irc-channel-listener> ] 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" [ <irc-channel-listener> ] 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" [ <irc-channel-listener> ] 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" [ <irc-nick-listener> ] 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" [ <irc-channel-listener> ] 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" [ <irc-channel-listener>
+ 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" [ <irc-channel-listener>
+ 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" [ <irc-channel-listener>
+ 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" [ <irc-channel-listener> ] 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
! Setup and running objects
! ======================================
-SYMBOL: current-irc-client
-
: irc-port 6667 ; ! Default irc port
TUPLE: irc-profile server port nickname password ;
<mailbox> <mailbox> irc-server-listener boa ;
: <irc-channel-listener> ( name -- irc-channel-listener )
- [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
+ [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
+ irc-channel-listener boa ;
: <irc-nick-listener> ( name -- irc-nick-listener )
[ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
TUPLE: participant-changed nick action ;
C: <participant-changed> 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* ;
<PRIVATE
+SYMBOL: current-irc-client
+
! ======================================
! Utils
! ======================================
: irc-write ( s -- ) irc-stream> 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 -- )
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 ;
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* ;
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 ;
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 ;
[ >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 <participant-changed> ] dip name>> to-listener ] bi
+ ] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ;
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
! ======================================
: (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 ;
] 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 ( -- )
! ======================================
: 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 -- )
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 ;
[ ":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
! 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
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 ;
irc-message new now >>timestamp
[ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
+<PRIVATE
+
+GENERIC: irc-command-string ( irc-message -- string )
+
+M: irc-message irc-command-string ( irc-message -- string ) command>> ;
+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 )
: 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 ;
sequences strings hashtables splitting fry assocs hashtables\r
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
- ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels\r
- io io.styles namespaces calendar calendar.format models\r
+ ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
+ io io.styles namespaces calendar calendar.format models continuations\r
irc.client irc.client.private irc.messages irc.messages.private\r
- irc.ui.commandparser irc.ui.load ;\r
+ irc.ui.commandparser irc.ui.load qualified ;\r
+\r
+RENAME: join sequences => sjoin\r
\r
IN: irc.ui\r
\r
\r
TUPLE: ui-window client tabs ;\r
\r
-TUPLE: irc-tab < frame listener client listmodel ;\r
+TUPLE: irc-tab < frame listener client userlist ;\r
\r
: write-color ( str color -- )\r
foreground associate format ;\r
" has left IRC" red write-color\r
trailing>> dot-or-parens red write-color ;\r
\r
+: full-mode ( message -- mode )\r
+ parameters>> rest " " sjoin ;\r
+\r
M: mode write-irc\r
"* " blue write-color\r
- [ name>> write ] keep\r
+ [ prefix>> parse-name write ] keep\r
" has applied mode " blue write-color\r
- [ mode>> write ] keep\r
+ [ full-mode write ] keep\r
" to " blue write-color\r
channel>> write ;\r
\r
+M: unhandled write-irc\r
+ "UNHANDLED: " write\r
+ line>> blue write-color ;\r
+\r
M: irc-end write-irc\r
drop "* You have left IRC" red write-color ;\r
\r
M: irc-connected write-irc\r
drop "* Connected" green write-color ;\r
\r
+M: irc-listener-end write-irc\r
+ drop ;\r
+\r
M: irc-message write-irc\r
drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
\r
+: time-happened ( irc-message -- timestamp )\r
+ [ timestamp>> ] [ 2drop now ] recover ;\r
+\r
: print-irc ( irc-message -- )\r
- [ timestamp>> timestamp>hms write " " write ]\r
+ [ time-happened timestamp>hms write " " write ]\r
[ write-irc nl ] bi ;\r
\r
: send-message ( message -- )\r
\r
GENERIC: handle-inbox ( tab message -- )\r
\r
-: filter-participants ( assoc val -- alist )\r
- [ >alist ] dip\r
- '[ second , = ] filter ;\r
+: filter-participants ( pack alist val color -- )\r
+ '[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;\r
\r
: update-participants ( tab -- )\r
- [ listmodel>> ] [ listener>> participants>> ] bi\r
- [ +operator+ filter-participants ]\r
- [ +voice+ filter-participants ]\r
- [ +normal+ filter-participants ] tri\r
- append append swap set-model ;\r
+ [ userlist>> [ clear-gadget ] keep ]\r
+ [ listener>> participants>> ] bi\r
+ [ +operator+ green filter-participants ]\r
+ [ +voice+ blue filter-participants ]\r
+ [ +normal+ black filter-participants ] 2tri ;\r
\r
M: participant-changed handle-inbox\r
drop update-participants ;\r
{ T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
-: <irc-list> ( -- gadget model )\r
- [ drop ]\r
- [ first2 [ <label> ] dip >>color ]\r
- { } <model> [ <list> ] keep ;\r
-\r
: <irc-tab> ( listener client -- irc-tab )\r
irc-tab new-frame\r
swap client>> >>client swap >>listener\r
\r
: <irc-channel-tab> ( listener client -- irc-tab )\r
<irc-tab>\r
- <irc-list> [ <scroller> @right grid-add ] dip >>listmodel\r
- [ update-participants ] keep ;\r
+ <pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
\r
: <irc-server-tab> ( listener client -- irc-tab )\r
<irc-tab> ;\r
\r
M: irc-tab graft*\r
- [ listener>> ] [ client>> ] bi\r
- add-listener ;\r
+ [ listener>> ] [ client>> ] bi add-listener ;\r
\r
M: irc-tab ungraft*\r
- [ listener>> ] [ client>> ] bi\r
- remove-listener ;\r
+ [ listener>> ] [ client>> ] bi remove-listener ;\r
+\r
+M: irc-tab pref-dim*\r
+ drop { 480 480 } ;\r
\r
: join-channel ( name ui-window -- )\r
[ dup <irc-channel-listener> ] dip\r
: ui-connect ( profile -- ui-window )\r
<irc-client> ui-window new over >>client swap\r
[ connect-irc ]\r
+ [ [ <irc-server-listener> ] dip add-listener ]\r
[ listeners>> +server-listener+ swap at over <irc-tab>\r
- "Server" associate <tabbed> >>tabs ] bi ;\r
+ "Server" associate <tabbed> >>tabs ] tri ;\r
\r
: server-open ( server port nick password channels -- )\r
[ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
projects / factor.git / commitdiff