Merge branch 'master' of git://tiodante.com/git/factor
commit
fce7afcf9e
|
@ -1,7 +1,7 @@
|
||||||
USING: kernel tools.test accessors arrays sequences qualified
|
USING: kernel tools.test accessors arrays sequences qualified
|
||||||
io.streams.string io.streams.duplex namespaces threads
|
io.streams.string io.streams.duplex namespaces threads
|
||||||
calendar irc.client.private irc.client irc.messages.private
|
calendar irc.client.private irc.client irc.messages.private
|
||||||
concurrency.mailboxes classes ;
|
concurrency.mailboxes classes assocs ;
|
||||||
EXCLUDE: irc.messages => join ;
|
EXCLUDE: irc.messages => join ;
|
||||||
RENAME: join irc.messages => join_
|
RENAME: join irc.messages => join_
|
||||||
IN: irc.client.tests
|
IN: irc.client.tests
|
||||||
|
@ -20,28 +20,6 @@ IN: irc.client.tests
|
||||||
: with-dummy-client ( quot -- )
|
: with-dummy-client ( quot -- )
|
||||||
rot with-variable ; inline
|
rot with-variable ; inline
|
||||||
|
|
||||||
! Parsing tests
|
|
||||||
irc-message new
|
|
||||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
|
||||||
"someuser!n=user@some.where" >>prefix
|
|
||||||
"PRIVMSG" >>command
|
|
||||||
{ "#factortest" } >>parameters
|
|
||||||
"hi" >>trailing
|
|
||||||
1array
|
|
||||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
|
||||||
string>irc-message f >>timestamp ] unit-test
|
|
||||||
|
|
||||||
privmsg new
|
|
||||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
|
||||||
"someuser!n=user@some.where" >>prefix
|
|
||||||
"PRIVMSG" >>command
|
|
||||||
{ "#factortest" } >>parameters
|
|
||||||
"hi" >>trailing
|
|
||||||
"#factortest" >>name
|
|
||||||
1array
|
|
||||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
|
||||||
parse-irc-line f >>timestamp ] unit-test
|
|
||||||
|
|
||||||
{ "" } make-client dup "factorbot" set-nick current-irc-client [
|
{ "" } make-client dup "factorbot" set-nick current-irc-client [
|
||||||
{ t } [ irc> profile>> nickname>> me? ] unit-test
|
{ t } [ irc> profile>> nickname>> me? ] unit-test
|
||||||
|
|
||||||
|
@ -64,21 +42,29 @@ privmsg new
|
||||||
":some.where 001 factorbot :Welcome factorbot"
|
":some.where 001 factorbot :Welcome factorbot"
|
||||||
} make-client
|
} make-client
|
||||||
[ connect-irc ] keep 1 seconds sleep
|
[ connect-irc ] keep 1 seconds sleep
|
||||||
profile>> nickname>> ] unit-test
|
profile>> nickname>> ] unit-test
|
||||||
|
|
||||||
{ join_ "#factortest" } [
|
{ join_ "#factortest" } [
|
||||||
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
|
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
|
||||||
":ircserver.net MODE #factortest +ns"
|
":ircserver.net MODE #factortest +ns"
|
||||||
":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"
|
||||||
} make-client dup "factorbot" set-nick
|
} make-client dup "factorbot" set-nick
|
||||||
[ connect-irc ] keep 1 seconds sleep
|
[ connect-irc ] keep 1 seconds sleep
|
||||||
join-messages>> 5 seconds mailbox-get-timeout
|
join-messages>> 1 seconds mailbox-get-timeout
|
||||||
[ class ] [ trailing>> ] bi ] unit-test
|
[ class ] [ trailing>> ] bi ] unit-test
|
||||||
! TODO: user join
|
|
||||||
! ":somedude!n=user@isp.net JOIN :#factortest"
|
{ +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
|
! TODO: channel message
|
||||||
! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
|
! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello"
|
||||||
! TODO: direct private message
|
! TODO: direct private message
|
||||||
! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"
|
! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"
|
|
@ -31,6 +31,20 @@ TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
|
||||||
TUPLE: irc-nick-listener < irc-listener name ;
|
TUPLE: irc-nick-listener < irc-listener name ;
|
||||||
SYMBOL: +server-listener+
|
SYMBOL: +server-listener+
|
||||||
|
|
||||||
|
! participant modes
|
||||||
|
SYMBOL: +operator+
|
||||||
|
SYMBOL: +voice+
|
||||||
|
SYMBOL: +normal+
|
||||||
|
|
||||||
|
: participant-mode ( n -- mode )
|
||||||
|
H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
|
||||||
|
|
||||||
|
! participant changed actions
|
||||||
|
SYMBOL: +join+
|
||||||
|
SYMBOL: +part+
|
||||||
|
SYMBOL: +mode+
|
||||||
|
|
||||||
|
! listener objects
|
||||||
: <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 )
|
||||||
|
@ -46,6 +60,9 @@ SYMBOL: +server-listener+
|
||||||
! Message objects
|
! Message objects
|
||||||
! ======================================
|
! ======================================
|
||||||
|
|
||||||
|
TUPLE: participant-changed nick action ;
|
||||||
|
C: <participant-changed> participant-changed
|
||||||
|
|
||||||
SINGLETON: irc-end ! sent when the client isn't running anymore
|
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
|
||||||
|
@ -70,19 +87,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
||||||
: listener> ( name -- listener/f ) irc> listeners>> at ;
|
: listener> ( name -- listener/f ) irc> listeners>> at ;
|
||||||
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
|
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
|
||||||
|
|
||||||
: to-listener ( message name -- )
|
GENERIC: to-listener ( message obj -- )
|
||||||
|
|
||||||
|
M: string to-listener ( message string -- )
|
||||||
listener> [ +server-listener+ listener> ] unless*
|
listener> [ +server-listener+ listener> ] unless*
|
||||||
[ in-messages>> mailbox-put ] [ drop ] if* ;
|
[ to-listener ] [ drop ] if* ;
|
||||||
|
|
||||||
|
M: irc-listener to-listener ( message irc-listener -- )
|
||||||
|
in-messages>> mailbox-put ;
|
||||||
|
|
||||||
: remove-participant ( nick channel -- )
|
: remove-participant ( nick channel -- )
|
||||||
listener> [ participants>> delete-at ] [ drop ] if* ;
|
listener> [ participants>> delete-at ] [ drop ] if* ;
|
||||||
|
|
||||||
: remove-participant-from-all ( nick -- )
|
: listeners-with-participant ( nick -- seq )
|
||||||
irc> listeners>>
|
irc> listeners>> values
|
||||||
[ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
|
[ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
|
||||||
assoc-each ;
|
with filter ;
|
||||||
|
|
||||||
: add-participant ( nick mode channel -- )
|
: remove-participant-from-all ( nick -- )
|
||||||
|
dup listeners-with-participant [ delete-at ] with each ;
|
||||||
|
|
||||||
|
: add-participant ( mode nick channel -- )
|
||||||
listener> [ participants>> set-at ] [ 2drop ] if* ;
|
listener> [ participants>> set-at ] [ 2drop ] if* ;
|
||||||
|
|
||||||
DEFER: me?
|
DEFER: me?
|
||||||
|
@ -142,12 +167,31 @@ DEFER: me?
|
||||||
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
|
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
|
||||||
|
|
||||||
: broadcast-message-to-listeners ( message -- )
|
: broadcast-message-to-listeners ( message -- )
|
||||||
irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
|
irc> listeners>> values [ to-listener ] with each ;
|
||||||
|
|
||||||
|
GENERIC: handle-participant-change ( irc-message -- )
|
||||||
|
|
||||||
|
M: join handle-participant-change ( join -- )
|
||||||
|
[ prefix>> parse-name +join+ <participant-changed> ]
|
||||||
|
[ trailing>> ] bi to-listener ;
|
||||||
|
|
||||||
|
M: part handle-participant-change ( part -- )
|
||||||
|
[ prefix>> parse-name +part+ <participant-changed> ]
|
||||||
|
[ channel>> ] bi to-listener ;
|
||||||
|
|
||||||
|
M: kick handle-participant-change ( kick -- )
|
||||||
|
[ who>> +part+ <participant-changed> ]
|
||||||
|
[ channel>> ] bi to-listener ;
|
||||||
|
|
||||||
|
M: quit handle-participant-change ( quit -- )
|
||||||
|
prefix>> parse-name
|
||||||
|
[ +part+ <participant-changed> ] [ listeners-with-participant ] bi
|
||||||
|
[ to-listener ] with each ;
|
||||||
|
|
||||||
GENERIC: handle-incoming-irc ( irc-message -- )
|
GENERIC: handle-incoming-irc ( irc-message -- )
|
||||||
|
|
||||||
M: irc-message handle-incoming-irc ( irc-message -- )
|
M: irc-message handle-incoming-irc ( irc-message -- )
|
||||||
+server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
|
+server-listener+ listener> [ to-listener ] [ drop ] if* ;
|
||||||
|
|
||||||
M: logged-in handle-incoming-irc ( logged-in -- )
|
M: logged-in handle-incoming-irc ( logged-in -- )
|
||||||
name>> irc> profile>> (>>nickname) ;
|
name>> irc> profile>> (>>nickname) ;
|
||||||
|
@ -162,27 +206,35 @@ M: privmsg handle-incoming-irc ( privmsg -- )
|
||||||
dup irc-message-origin to-listener ;
|
dup irc-message-origin to-listener ;
|
||||||
|
|
||||||
M: join handle-incoming-irc ( join -- )
|
M: join handle-incoming-irc ( join -- )
|
||||||
[ maybe-forward-join ]
|
{ [ maybe-forward-join ] ! keep
|
||||||
[ dup trailing>> to-listener ]
|
[ dup trailing>> to-listener ]
|
||||||
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
|
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
|
||||||
tri ;
|
[ handle-participant-change ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
M: part handle-incoming-irc ( part -- )
|
M: part handle-incoming-irc ( part -- )
|
||||||
[ dup channel>> to-listener ] keep
|
[ dup channel>> to-listener ]
|
||||||
[ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
|
[ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
|
||||||
|
[ handle-participant-change ]
|
||||||
M: kick handle-incoming-irc ( kick -- )
|
|
||||||
[ dup channel>> to-listener ]
|
|
||||||
[ [ who>> ] [ channel>> ] bi remove-participant ]
|
|
||||||
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
|
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
|
M: kick handle-incoming-irc ( kick -- )
|
||||||
|
{ [ 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 -- )
|
M: quit handle-incoming-irc ( quit -- )
|
||||||
[ prefix>> parse-name remove-participant-from-all ] keep
|
{ [ dup prefix>> parse-name listeners-with-participant
|
||||||
call-next-method ;
|
[ to-listener ] with each ]
|
||||||
|
[ handle-participant-change ]
|
||||||
|
[ prefix>> parse-name remove-participant-from-all ]
|
||||||
|
[ ]
|
||||||
|
} cleave call-next-method ;
|
||||||
|
|
||||||
: >nick/mode ( string -- nick mode )
|
: >nick/mode ( string -- nick mode )
|
||||||
dup first "+@" member? [ unclip ] [ f ] if ;
|
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
|
||||||
|
|
||||||
: names-reply>participants ( names-reply -- participants )
|
: names-reply>participants ( names-reply -- participants )
|
||||||
trailing>> [ blank? ] trim " " split
|
trailing>> [ blank? ] trim " " split
|
||||||
|
@ -200,8 +252,8 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
|
||||||
|
|
||||||
GENERIC: handle-outgoing-irc ( obj -- )
|
GENERIC: handle-outgoing-irc ( obj -- )
|
||||||
|
|
||||||
! M: irc-message handle-outgoing-irc ( irc-message -- )
|
M: irc-message handle-outgoing-irc ( irc-message -- )
|
||||||
! irc-message>string irc-print ;
|
irc-message>client-line irc-print ;
|
||||||
|
|
||||||
M: privmsg handle-outgoing-irc ( privmsg -- )
|
M: privmsg handle-outgoing-irc ( privmsg -- )
|
||||||
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
|
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
|
||||||
|
@ -225,7 +277,7 @@ DEFER: (connect-irc)
|
||||||
|
|
||||||
: (handle-disconnect) ( -- )
|
: (handle-disconnect) ( -- )
|
||||||
irc>
|
irc>
|
||||||
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
|
[ [ irc-disconnected ] dip to-listener ]
|
||||||
[ dup reconnect-time>> sleep (connect-irc) ]
|
[ dup reconnect-time>> sleep (connect-irc) ]
|
||||||
[ profile>> nickname>> /LOGIN ]
|
[ profile>> nickname>> /LOGIN ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
|
@ -0,0 +1,37 @@
|
||||||
|
USING: kernel tools.test accessors arrays qualified
|
||||||
|
irc.messages irc.messages.private ;
|
||||||
|
EXCLUDE: sequences => join ;
|
||||||
|
IN: irc.messages.tests
|
||||||
|
|
||||||
|
! Parsing tests
|
||||||
|
irc-message new
|
||||||
|
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||||
|
"someuser!n=user@some.where" >>prefix
|
||||||
|
"PRIVMSG" >>command
|
||||||
|
{ "#factortest" } >>parameters
|
||||||
|
"hi" >>trailing
|
||||||
|
1array
|
||||||
|
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||||
|
string>irc-message f >>timestamp ] unit-test
|
||||||
|
|
||||||
|
privmsg new
|
||||||
|
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||||
|
"someuser!n=user@some.where" >>prefix
|
||||||
|
"PRIVMSG" >>command
|
||||||
|
{ "#factortest" } >>parameters
|
||||||
|
"hi" >>trailing
|
||||||
|
"#factortest" >>name
|
||||||
|
1array
|
||||||
|
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||||
|
parse-irc-line f >>timestamp ] unit-test
|
||||||
|
|
||||||
|
join new
|
||||||
|
":someuser!n=user@some.where JOIN :#factortest" >>line
|
||||||
|
"someuser!n=user@some.where" >>prefix
|
||||||
|
"JOIN" >>command
|
||||||
|
{ } >>parameters
|
||||||
|
"#factortest" >>trailing
|
||||||
|
1array
|
||||||
|
[ ":someuser!n=user@some.where JOIN :#factortest"
|
||||||
|
parse-irc-line f >>timestamp ] unit-test
|
||||||
|
|
|
@ -21,6 +21,10 @@ TUPLE: mode < irc-message name channel mode ;
|
||||||
TUPLE: names-reply < irc-message who = channel ;
|
TUPLE: names-reply < irc-message who = channel ;
|
||||||
TUPLE: unhandled < irc-message ;
|
TUPLE: unhandled < irc-message ;
|
||||||
|
|
||||||
|
: <irc-client-message> ( command parameters trailing -- irc-message )
|
||||||
|
irc-message new now >>timestamp
|
||||||
|
[ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
|
||||||
|
|
||||||
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 ( irc-message -- string )
|
||||||
|
@ -30,6 +34,7 @@ M: irc-message irc-message>client-line ( irc-message -- string )
|
||||||
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 ( irc-message -- string )
|
M: irc-message irc-message>server-line ( irc-message -- string )
|
||||||
drop "not implemented yet" ;
|
drop "not implemented yet" ;
|
||||||
|
|
||||||
|
@ -58,6 +63,8 @@ M: irc-message irc-message>server-line ( irc-message -- string )
|
||||||
: split-trailing ( string -- string string/f )
|
: split-trailing ( string -- string string/f )
|
||||||
":" split1 ;
|
":" split1 ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: string>irc-message ( string -- object )
|
: string>irc-message ( string -- object )
|
||||||
dup split-prefix split-trailing
|
dup split-prefix split-trailing
|
||||||
[ [ blank? ] trim " " split unclip swap ] dip
|
[ [ blank? ] trim " " split unclip swap ] dip
|
||||||
|
@ -82,4 +89,3 @@ M: irc-message irc-message>server-line ( irc-message -- string )
|
||||||
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
|
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
|
||||||
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
|
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
Loading…
Reference in New Issue