Merge branch 'master' of factorcode.org:/git/factor
Eduardo Cavazos
commit
fdfd23b815
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <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
|
||||
|
|
@ -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" [ <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"
|
||||
{ ":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
|
||||
|
|
@ -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+
|
|||
<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 ;
|
||||
|
|
@ -63,19 +62,24 @@ SYMBOL: +mode+
|
|||
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
|
||||
! ======================================
|
||||
|
|
@ -85,7 +89,9 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
|||
: 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 -- )
|
||||
|
||||
|
|
@ -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 <participant-changed> ] 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
<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 )
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
'[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;
|
||||
|
||||
: update-participants ( tab -- )
|
||||
[ listmodel>> ] [ listener>> participants>> ] bi
|
||||
[ +operator+ filter-participants ]
|
||||
[ +voice+ filter-participants ]
|
||||
[ +normal+ filter-participants ] tri
|
||||
append append swap set-model ;
|
||||
[ userlist>> [ clear-gadget ] keep ]
|
||||
[ listener>> participants>> ] bi
|
||||
[ +operator+ green filter-participants ]
|
||||
[ +voice+ blue filter-participants ]
|
||||
[ +normal+ black filter-participants ] 2tri ;
|
||||
|
||||
M: participant-changed handle-inbox
|
||||
drop update-participants ;
|
||||
|
|
@ -147,11 +161,6 @@ irc-editor "general" f {
|
|||
{ T{ key-down f f "ENTER" } editor-send }
|
||||
} define-command-map
|
||||
|
||||
: <irc-list> ( -- gadget model )
|
||||
[ drop ]
|
||||
[ first2 [ <label> ] dip >>color ]
|
||||
{ } <model> [ <list> ] keep ;
|
||||
|
||||
: <irc-tab> ( listener client -- irc-tab )
|
||||
irc-tab new-frame
|
||||
swap client>> >>client swap >>listener
|
||||
|
|
@ -160,19 +169,19 @@ irc-editor "general" f {
|
|||
|
||||
: <irc-channel-tab> ( listener client -- irc-tab )
|
||||
<irc-tab>
|
||||
<irc-list> [ <scroller> @right grid-add ] dip >>listmodel
|
||||
[ update-participants ] keep ;
|
||||
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
|
||||
|
||||
: <irc-server-tab> ( listener client -- irc-tab )
|
||||
<irc-tab> ;
|
||||
|
||||
M: irc-tab graft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
add-listener ;
|
||||
[ listener>> ] [ client>> ] bi add-listener ;
|
||||
|
||||
M: irc-tab ungraft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
remove-listener ;
|
||||
[ listener>> ] [ client>> ] bi remove-listener ;
|
||||
|
||||
M: irc-tab pref-dim*
|
||||
drop { 480 480 } ;
|
||||
|
||||
: join-channel ( name ui-window -- )
|
||||
[ dup <irc-channel-listener> ] dip
|
||||
|
|
@ -187,8 +196,9 @@ M: irc-tab ungraft*
|
|||
: ui-connect ( profile -- ui-window )
|
||||
<irc-client> ui-window new over >>client swap
|
||||
[ connect-irc ]
|
||||
[ [ <irc-server-listener> ] dip add-listener ]
|
||||
[ listeners>> +server-listener+ swap at over <irc-tab>
|
||||
"Server" associate <tabbed> >>tabs ] bi ;
|
||||
"Server" associate <tabbed> >>tabs ] tri ;
|
||||
|
||||
: server-open ( server port nick password channels -- )
|
||||
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
|
||||
|
|
|
|||
|
|
@ -106,17 +106,12 @@ SYMBOL: enter-out
|
|||
'[ , prepend ] bi@
|
||||
<effect> ;
|
||||
|
||||
: insert-copy ( effect -- )
|
||||
in>> [ consume-d dup ] keep make-copies
|
||||
[ nip output-d ] [ #copy, ] 2bi ;
|
||||
|
||||
: call-recursive-inline-word ( word -- )
|
||||
dup "recursive" word-prop [
|
||||
[ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
|
||||
[ 2drop insert-copy ]
|
||||
[ add-call drop ]
|
||||
[ nip '[ , #call-recursive, ] consume/produce ]
|
||||
3tri
|
||||
3bi
|
||||
] [ undeclared-recursion-error inference-error ] if ;
|
||||
|
||||
: inline-word ( word -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue