steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

irc.client: Refactor, clean, etc. Stop using a thread for each listener for output messages

db4
Bruno Deferrari 2008-09-25 01:05:44 -03:00
parent aab5126d94
commit 6e09d7cb63
5 changed files with 159 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
extra/irc/client/client-tests.factor
View File

@ -28,9 +28,11 @@ M: mb-writer stream-nl ( mb-writer -- )
dup [ spawn-irc yield ] with-irc-client ; dup [ spawn-irc yield ] with-irc-client ;
! to be used inside with-irc-client quotations ! to be used inside with-irc-client quotations
: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ; : %add-named-listener ( listener -- ) irc> add-listener ;
: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ; : %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 ) : read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
[ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
@ -62,13 +64,28 @@ M: mb-writer stream-nl ( mb-writer -- )
] unit-test ] unit-test
] with-irc ] 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" } [ [ { join_ "#factortest" } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep
{ ":factorbot!n=factorbo@some.where JOIN :#factortest" { ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} [ %push-line ] each } [ %push-line ] each
irc> join-messages>> 0.1 seconds mailbox-get-timeout in-messages>> 0.1 seconds mailbox-get-timeout
[ class ] [ trailing>> ] bi [ class ] [ trailing>> ] bi
] unit-test ] unit-test
] with-irc ] with-irc
@ -89,8 +106,8 @@ M: mb-writer stream-nl ( mb-writer -- )
] with-irc ] with-irc
[ { privmsg "factorbot" "hello" } [ [ { privmsg "factorbot" "hello" } [
"somedude" <irc-nick-listener> [ %add-named-listener ] keep "ircuser" <irc-nick-listener> [ %add-named-listener ] keep
":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ privmsg? ] read-matching-message [ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri [ class ] [ name>> ] [ trailing>> ] tri
] unit-test ] unit-test
@ -104,48 +121,48 @@ M: mb-writer stream-nl ( mb-writer -- )
] with-irc ] with-irc
! Participant lists tests ! Participant lists tests
[ { H{ { "somedude" +normal+ } } } [ [ { H{ { "ircuser" +normal+ } } } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep "#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>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
[ { H{ { "somedude2" +normal+ } } } [ [ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-listener>
H{ { "somedude2" +normal+ } H{ { "ircuser2" +normal+ }
{ "somedude" +normal+ } } clone >>participants { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-listener ] keep
":somedude!n=user@isp.net PART #factortest" %push-line ":ircuser!n=user@isp.net PART #factortest" %push-line
participants>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
[ { H{ { "somedude2" +normal+ } } } [ [ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-listener>
H{ { "somedude2" +normal+ } H{ { "ircuser2" +normal+ }
{ "somedude" +normal+ } } clone >>participants { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-listener ] keep
":somedude!n=user@isp.net QUIT" %push-line ":ircuser!n=user@isp.net QUIT" %push-line
participants>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
[ { H{ { "somedude2" +normal+ } } } [ [ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-listener>
H{ { "somedude2" +normal+ } H{ { "ircuser2" +normal+ }
{ "somedude" +normal+ } } clone >>participants { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %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>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
[ { H{ { "somedude2" +normal+ } } } [ [ { H{ { "ircuser2" +normal+ } } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-listener>
H{ { "somedude" +normal+ } } clone >>participants H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %add-named-listener ] keep
":somedude!n=user2@isp.net NICK :somedude2" %push-line ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
participants>> participants>>
] unit-test ] unit-test
] with-irc ] with-irc
@ -159,20 +176,20 @@ M: mb-writer stream-nl ( mb-writer -- )
] unit-test ] unit-test
] with-irc ] with-irc
[ { T{ participant-changed f "somedude" +part+ f } } [ [ { T{ participant-changed f "ircuser" +part+ f } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-listener>
H{ { "somedude" +normal+ } } clone >>participants H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %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 [ participant-changed? ] read-matching-message
] unit-test ] unit-test
] with-irc ] with-irc
[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [ [ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
"#factortest" <irc-channel-listener> "#factortest" <irc-channel-listener>
H{ { "somedude" +normal+ } } clone >>participants H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-listener ] keep [ %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 [ participant-changed? ] read-matching-message
] unit-test ] unit-test
] with-irc ] with-irc

166
extra/irc/client/client.factor
View File

@ -17,13 +17,13 @@ IN: irc.client
TUPLE: irc-profile server port nickname password ; TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile 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 ; listeners is-running nick connect reconnect-time ;
: <irc-client> ( profile -- irc-client ) : <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 ; [ <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-server-listener < irc-listener ;
TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
TUPLE: irc-nick-listener < irc-listener name ; TUPLE: irc-nick-listener < irc-listener name ;
@ -47,14 +47,14 @@ SYMBOL: +nick+
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ; : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
: <irc-server-listener> ( -- irc-server-listener ) : <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 ) : <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-channel-listener boa ;
: <irc-nick-listener> ( name -- irc-nick-listener ) : <irc-nick-listener> ( name -- irc-nick-listener )
[ <mailbox> <mailbox> ] dip irc-nick-listener boa ; [ <mailbox> f ] dip irc-nick-listener boa ;
! ====================================== ! ======================================
! Message objects ! 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-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established 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 -- ) : terminate-irc ( irc-client -- )
[ is-running>> ] keep and [ [ is-running>> ] keep and [
[ end-loops ] f >>is-running
[ [ f ] dip (>>is-running) ] [ in-messages>> ] [ out-messages>> ] bi 2array
bi [ irc-end swap mailbox-put ] each
] when* ; ] when* ;
<PRIVATE <PRIVATE
@ -102,12 +94,11 @@ SYMBOL: current-irc-client
GENERIC: to-listener ( message obj -- ) GENERIC: to-listener ( message obj -- )
M: string to-listener ( message string -- ) M: string to-listener
listener> [ +server-listener+ listener> ] unless* listener> [ +server-listener+ listener> ] unless*
[ to-listener ] [ drop ] if* ; [ to-listener ] [ drop ] if* ;
M: irc-listener to-listener ( message irc-listener -- ) M: irc-listener to-listener in-messages>> mailbox-put ;
in-messages>> mailbox-put ;
: unregister-listener ( name -- ) : unregister-listener ( name -- )
irc> listeners>> irc> listeners>>
@ -156,10 +147,6 @@ M: irc-listener to-listener ( message irc-listener -- )
DEFER: me? DEFER: me?
: maybe-forward-join ( join -- )
[ irc-message-sender me? ] keep and
[ irc> join-messages>> mailbox-put ] when* ;
! ====================================== ! ======================================
! IRC client messages ! IRC client messages
! ====================================== ! ======================================
@ -187,63 +174,50 @@ DEFER: me?
! ====================================== ! ======================================
GENERIC: forward-name ( irc-message -- name ) GENERIC: forward-name ( irc-message -- name )
M: join forward-name ( join -- name ) trailing>> ; M: join forward-name trailing>> ;
M: part forward-name ( part -- name ) channel>> ; M: part forward-name channel>> ;
M: kick forward-name ( kick -- name ) channel>> ; M: kick forward-name channel>> ;
M: mode forward-name ( mode -- name ) name>> ; M: mode forward-name name>> ;
M: privmsg forward-name ( privmsg -- name ) M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
dup name>> me? [ irc-message-sender ] [ name>> ] if ;
UNION: single-forward join part kick mode privmsg ; UNION: single-forward join part kick mode privmsg ;
UNION: multiple-forward nick quit ; UNION: multiple-forward nick quit ;
UNION: broadcast-forward irc-end irc-disconnected irc-connected ; UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
GENERIC: forward-message ( irc-message -- ) GENERIC: forward-message ( irc-message -- )
M: irc-message forward-message ( irc-message -- ) M: irc-message forward-message
+server-listener+ listener> [ to-listener ] [ drop ] if* ; +server-listener+ listener> [ to-listener ] [ drop ] if* ;
M: single-forward forward-message ( forward-single -- ) M: single-forward forward-message dup forward-name to-listener ;
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 ; dup irc-message-sender to-listeners-with-participant ;
M: join forward-message ( join -- ) M: broadcast-forward forward-message
[ maybe-forward-join ] [ call-next-method ] bi ;
M: broadcast-forward forward-message ( irc-broadcasted-message -- )
irc> listeners>> values [ to-listener ] with each ; irc> listeners>> values [ to-listener ] with each ;
GENERIC: process-message ( irc-message -- ) 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 -- ) M: join process-message
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 -- )
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
dup listener> [ add-participant ] [ 3drop ] if ; dup listener> [ add-participant ] [ 3drop ] if ;
M: part process-message ( part -- ) M: part process-message
[ irc-message-sender ] [ channel>> ] bi remove-participant ; [ irc-message-sender ] [ channel>> ] bi remove-participant ;
M: kick process-message ( kick -- ) M: kick process-message
[ [ who>> ] [ channel>> ] bi remove-participant ] [ [ who>> ] [ channel>> ] bi remove-participant ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ] [ dup who>> me? [ unregister-listener ] [ drop ] if ]
bi ; bi ;
M: quit process-message ( quit -- ) M: quit process-message
irc-message-sender remove-participant-from-all ; 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 ; [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
! M: mode process-message ( mode -- ) ! M: mode process-message ( mode -- )
@ -259,7 +233,7 @@ M: nick process-message ( nick -- )
trailing>> [ blank? ] trim " " split trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ; [ >nick/mode 2array ] map >hashtable ;
M: names-reply process-message ( names-reply -- ) M: names-reply process-message
[ names-reply>participants ] [ channel>> listener> ] bi [ [ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ] [ (>>participants) ]
[ [ f f f <participant-changed> ] dip name>> to-listener ] bi [ [ 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 -- ? ) GENERIC: handle-outgoing-irc ( irc-message -- ? )
M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ; M: irc-end handle-outgoing-irc drop f ;
M: irc-message handle-outgoing-irc ( irc-message -- ? ) M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
irc-message>client-line irc-print t ;
! ====================================== ! ======================================
! Reader/Writer ! Reader/Writer
@ -326,16 +299,11 @@ DEFER: (connect-irc)
[ nip ] [ nip ]
} cond ; } cond ;
GENERIC: handle-listener-out ( irc-message -- ? ) GENERIC: annotate-message ( listener object -- object )
M: irc-end handle-listener-out ( irc-end -- ? ) drop f ; M: object annotate-message nip ;
M: irc-message handle-listener-out ( irc-message -- ? ) M: part annotate-message swap name>> >>channel ;
irc> out-messages>> mailbox-put t ; M: privmsg annotate-message swap name>> >>name ;
M: string annotate-message [ name>> ] dip strings>privmsg ;
: listener-loop ( name -- ? )
dup listener> [
out-messages>> mailbox-get
maybe-annotate-with-name handle-listener-out
] [ drop f ] if* ;
: spawn-irc ( -- ) : spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server [ 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 [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ; 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 -- ) GENERIC: (add-listener) ( irc-listener -- )
M: irc-channel-listener (add-listener) ( irc-channel-listener -- ) M: irc-listener (add-listener)
[ [ name>> ] [ password>> ] bi /JOIN ] [ irc> >>client ] [ name>> ] bi irc> listeners>> set-at ;
[ [ [ drop irc> join-messages>> ]
[ timeout>> ]
[ name>> '[ trailing>> _ = ] ]
tri mailbox-get-timeout? trailing>> ] keep set+run-listener
] bi ;
M: irc-nick-listener (add-listener) ( irc-nick-listener -- ) M: irc-server-listener (add-listener)
[ name>> ] keep set+run-listener ; irc> >>client +server-listener+ irc> listeners>> set-at ;
M: irc-server-listener (add-listener) ( irc-server-listener -- )
[ +server-listener+ ] dip set+run-listener ;
GENERIC: (remove-listener) ( irc-listener -- ) GENERIC: (remove-listener) ( irc-listener -- )
M: irc-nick-listener (remove-listener) ( irc-nick-listener -- ) M: irc-nick-listener (remove-listener)
name>> unregister-listener ; name>> unregister-listener ;
M: irc-channel-listener (remove-listener) ( irc-channel-listener -- ) M: irc-channel-listener (remove-listener)
[ [ name>> ] [ out-messages>> ] bi [ part new annotate-message irc> out-messages>> mailbox-put ] keep
[ [ part new ] dip >>channel ] dip mailbox-put ] keep
name>> unregister-listener ; name>> unregister-listener ;
M: irc-server-listener (remove-listener) ( irc-server-listener -- ) M: irc-server-listener (remove-listener)
drop +server-listener+ unregister-listener ; drop +server-listener+ unregister-listener ;
: (connect-irc) ( irc-client -- ) : (connect-irc) ( irc-client -- )
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep {
swap >>stream [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
t >>is-running [ (>>stream) ]
in-messages>> [ irc-connected ] dip mailbox-put ; [ t swap (>>is-running) ]
[ in-messages>> [ irc-connected ] dip mailbox-put ]
} cleave ;
: with-irc-client ( irc-client quot: ( -- ) -- ) : with-irc-client ( irc-client quot: ( -- ) -- )
[ \ current-irc-client ] dip with-variable ; inline [ \ current-irc-client ] dip with-variable ; inline
@ -392,15 +345,18 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
PRIVATE> PRIVATE>
: connect-irc ( irc-client -- ) : connect-irc ( irc-client -- )
[ irc> dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
[ (connect-irc) ] [ nick>> /LOGIN ] bi
spawn-irc ] with-irc-client ;
: add-listener ( irc-listener irc-client -- ) : add-listener ( irc-listener irc-client -- )
swap '[ _ (add-listener) ] with-irc-client ; swap '[ _ (add-listener) ] with-irc-client ;
: remove-listener ( irc-listener irc-client -- ) : remove-listener ( irc-listener -- )
swap '[ _ (remove-listener) ] with-irc-client ; [ 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 ; : read-message ( irc-listener -- message ) in-messages>> mailbox-get ;

10
extra/irc/messages/messages-tests.factor
View File

@ -62,4 +62,14 @@ IN: irc.messages.tests
{ parameters { } } { parameters { } }
{ trailing "someuser2" } } } { trailing "someuser2" } } }
[ ":someuser!n=user@some.where NICK :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 parse-irc-line f >>timestamp ] unit-test

71
extra/irc/messages/messages.factor
View File

@ -17,7 +17,7 @@ TUPLE: nick < irc-message ;
TUPLE: privmsg < irc-message name ; TUPLE: privmsg < irc-message name ;
TUPLE: kick < irc-message channel who ; TUPLE: kick < irc-message channel who ;
TUPLE: roomlist < irc-message channel names ; 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: notice < irc-message type ;
TUPLE: mode < irc-message name mode parameter ; TUPLE: mode < irc-message name mode parameter ;
TUPLE: names-reply < irc-message who channel ; TUPLE: names-reply < irc-message who channel ;
@ -31,45 +31,43 @@ TUPLE: unhandled < irc-message ;
GENERIC: command-string>> ( irc-message -- string ) GENERIC: command-string>> ( irc-message -- string )
M: irc-message command-string>> ( irc-message -- string ) command>> ; M: irc-message command-string>> command>> ;
M: ping command-string>> ( ping -- string ) drop "PING" ; M: ping command-string>> drop "PING" ;
M: join command-string>> ( join -- string ) drop "JOIN" ; M: join command-string>> drop "JOIN" ;
M: part command-string>> ( part -- string ) drop "PART" ; M: part command-string>> drop "PART" ;
M: quit command-string>> ( quit -- string ) drop "QUIT" ; M: quit command-string>> drop "QUIT" ;
M: nick command-string>> ( nick -- string ) drop "NICK" ; M: nick command-string>> drop "NICK" ;
M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ; M: privmsg command-string>> drop "PRIVMSG" ;
M: notice command-string>> ( notice -- string ) drop "NOTICE" ; M: notice command-string>> drop "NOTICE" ;
M: mode command-string>> ( mode -- string ) drop "MODE" ; M: mode command-string>> drop "MODE" ;
M: kick command-string>> ( kick -- string ) drop "KICK" ; M: kick command-string>> drop "KICK" ;
GENERIC: command-parameters>> ( irc-message -- seq ) GENERIC: command-parameters>> ( irc-message -- seq )
M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ; M: irc-message command-parameters>> parameters>> ;
M: ping command-parameters>> ( ping -- seq ) drop { } ; M: ping command-parameters>> drop { } ;
M: join command-parameters>> ( join -- seq ) drop { } ; M: join command-parameters>> drop { } ;
M: part command-parameters>> ( part -- seq ) channel>> 1array ; M: part command-parameters>> channel>> 1array ;
M: quit command-parameters>> ( quit -- seq ) drop { } ; M: quit command-parameters>> drop { } ;
M: nick command-parameters>> ( nick -- seq ) drop { } ; M: nick command-parameters>> drop { } ;
M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ; M: privmsg command-parameters>> name>> 1array ;
M: notice command-parameters>> ( norice -- seq ) type>> 1array ; M: notice command-parameters>> type>> 1array ;
M: kick command-parameters>> ( kick -- seq ) M: kick command-parameters>> [ channel>> ] [ who>> ] bi 2array ;
[ channel>> ] [ who>> ] bi 2array ; M: mode command-parameters>> [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
M: mode command-parameters>> ( mode -- seq )
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
GENERIC: (>>command-parameters) ( params irc-message -- ) GENERIC: (>>command-parameters) ( params irc-message -- )
M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ; M: irc-message (>>command-parameters) 2drop ;
M: logged-in (>>command-parameters) ( params part -- ) [ first ] dip (>>name) ; M: logged-in (>>command-parameters) [ first ] dip (>>name) ;
M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ; M: privmsg (>>command-parameters) [ first ] dip (>>name) ;
M: notice (>>command-parameters) ( params notice -- ) [ first ] dip (>>type) ; M: notice (>>command-parameters) [ first ] dip (>>type) ;
M: part (>>command-parameters) ( params part -- ) M: part (>>command-parameters) [ first ] dip (>>channel) ;
[ first ] dip (>>channel) ; M: nick-in-use (>>command-parameters) [ second ] dip (>>name) ;
M: kick (>>command-parameters) ( params kick -- ) M: kick (>>command-parameters)
[ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ; [ 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 ; [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
M: mode (>>command-parameters) ( params mode -- ) M: mode (>>command-parameters)
{ { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] } { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
{ [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] } { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
} switch ; } switch ;
@ -78,16 +76,14 @@ PRIVATE>
GENERIC: irc-message>client-line ( irc-message -- string ) 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-string>> ]
[ command-parameters>> " " sjoin ] [ command-parameters>> " " sjoin ]
[ trailing>> [ CHAR: : prefix ] [ "" ] if* ] [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
tri 3array " " sjoin ; tri 3array " " sjoin ;
GENERIC: irc-message>server-line ( irc-message -- string ) GENERIC: irc-message>server-line ( irc-message -- string )
M: irc-message irc-message>server-line drop "not implemented yet" ;
M: irc-message irc-message>server-line ( irc-message -- string )
drop "not implemented yet" ;
<PRIVATE <PRIVATE
! ====================================== ! ======================================
@ -124,8 +120,7 @@ PRIVATE>
UNION: sender-in-prefix privmsg join part quit kick mode nick ; UNION: sender-in-prefix privmsg join part quit kick mode nick ;
GENERIC: irc-message-sender ( irc-message -- sender ) GENERIC: irc-message-sender ( irc-message -- sender )
M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) M: sender-in-prefix irc-message-sender prefix>> parse-name ;
prefix>> parse-name ;
: string>irc-message ( string -- object ) : string>irc-message ( string -- object )
dup split-prefix split-trailing dup split-prefix split-trailing

14
extra/irc/ui/ui.factor
View File

@ -182,11 +182,16 @@ irc-editor "general" f {
<irc-pane> [ <scroller> @center grid-add ] keep <irc-pane> [ <scroller> @center grid-add ] keep
<irc-editor> <scroller> @bottom grid-add ; <irc-editor> <scroller> @bottom grid-add ;
GENERIC: init-listener ( listener -- )
M: object init-listener drop ;
M: irc-channel-listener init-listener join-irc-channel ;
M: irc-tab graft* M: irc-tab graft*
[ listener>> ] [ window>> client>> ] bi add-listener ; [ listener>> dup ] [ window>> client>> ] bi add-listener
init-listener ;
M: irc-tab ungraft* M: irc-tab ungraft*
[ listener>> ] [ window>> client>> ] bi remove-listener ; listener>> remove-listener ;
TUPLE: irc-channel-tab < irc-tab userlist ; TUPLE: irc-channel-tab < irc-tab userlist ;
@ -239,8 +244,9 @@ M: irc-tab pref-dim*
[ connect-irc ] } cleave ; [ connect-irc ] } cleave ;
: server-open ( server port nick password channels -- ) : server-open ( server port nick password channels -- )
[ <irc-profile> ui-connect [ irc-window ] keep ] dip [ <irc-profile> ui-connect [ irc-window ] keep ] dip 2drop ;
[ over join-channel ] each drop ; ! FIXME: should join channels only after we have been logged in
! [ over join-channel ] each drop ;
: main-run ( -- ) run-ircui ; : main-run ( -- ) run-ircui ;