irc.client: Big refactor
Bruno Deferrari
parent
4d722001e9
commit
85d595d8b6
|
|
@ -0,0 +1,37 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs concurrency.mailboxes io kernel namespaces
|
||||
strings words.symbol irc.client.chats irc.messages ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.client.base
|
||||
|
||||
SYMBOL: current-irc-client
|
||||
|
||||
: irc> ( -- irc-client ) current-irc-client get ;
|
||||
: stream> ( -- stream ) irc> stream>> ;
|
||||
: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ;
|
||||
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
|
||||
: chats> ( -- seq ) irc> chats>> values ;
|
||||
: me? ( string -- ? ) irc> nick>> = ;
|
||||
|
||||
: with-irc ( irc-client quot: ( -- ) -- )
|
||||
\ current-irc-client swap with-variable ; inline
|
||||
|
||||
UNION: to-target privmsg notice ;
|
||||
UNION: to-channel join part topic kick rpl-channel-modes
|
||||
rpl-notopic rpl-topic rpl-names rpl-names-end ;
|
||||
UNION: to-one-chat to-target to-channel mode ;
|
||||
UNION: to-many-chats nick quit ;
|
||||
UNION: to-all-chats irc-end irc-disconnected irc-connected ;
|
||||
PREDICATE: to-me < to-target target>> me? ;
|
||||
|
||||
GENERIC: chat-name ( irc-message -- name )
|
||||
M: mode chat-name name>> ;
|
||||
M: to-target chat-name target>> ;
|
||||
M: to-me chat-name sender>> ;
|
||||
M: to-channel chat-name channel>> ;
|
||||
|
||||
GENERIC: chat> ( obj -- chat/f )
|
||||
M: string chat> irc> chats>> at ;
|
||||
M: symbol chat> irc> chats>> at ;
|
||||
M: to-one-chat chat> chat-name +server-chat+ or chat> ;
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
USING: help.markup help.syntax quotations kernel ;
|
||||
IN: irc.client.chats
|
||||
|
||||
HELP: irc-client "IRC Client object" ;
|
||||
|
||||
HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
|
||||
|
||||
HELP: irc-channel-chat "Chat for irc channels" ;
|
||||
|
||||
HELP: irc-nick-chat "Chat for irc users" ;
|
||||
|
||||
HELP: irc-profile "IRC Client profile object" ;
|
||||
|
||||
HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ;
|
||||
|
||||
HELP: irc-end "Message sent when the client isn't running anymore, a chat should stop after it receives this message." ;
|
||||
|
||||
HELP: irc-disconnected "Message sent to notify chats that connection was lost." ;
|
||||
|
||||
HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ;
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit
|
||||
destructors arrays sequences ;
|
||||
IN: irc.client.chats
|
||||
|
||||
CONSTANT: irc-port 6667 ! Default irc port
|
||||
|
||||
TUPLE: irc-chat in-messages client ;
|
||||
TUPLE: irc-server-chat < irc-chat ;
|
||||
TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ;
|
||||
TUPLE: irc-nick-chat < irc-chat name ;
|
||||
SYMBOL: +server-chat+
|
||||
|
||||
: <irc-server-chat> ( -- irc-server-chat )
|
||||
irc-server-chat new
|
||||
<mailbox> >>in-messages ;
|
||||
|
||||
: <irc-channel-chat> ( name -- irc-channel-chat )
|
||||
irc-channel-chat new
|
||||
swap >>name
|
||||
<mailbox> >>in-messages
|
||||
f >>password
|
||||
H{ } clone >>participants
|
||||
t >>clear-participants ;
|
||||
|
||||
: <irc-nick-chat> ( name -- irc-nick-chat )
|
||||
irc-nick-chat new
|
||||
swap >>name
|
||||
<mailbox> >>in-messages ;
|
||||
|
||||
TUPLE: irc-profile server port nickname password ;
|
||||
C: <irc-profile> irc-profile
|
||||
|
||||
TUPLE: irc-client profile stream in-messages out-messages
|
||||
chats is-running nick connect reconnect-time is-ready
|
||||
exceptions ;
|
||||
|
||||
: <irc-client> ( profile -- irc-client )
|
||||
dup nickname>> irc-client new
|
||||
swap >>nick
|
||||
swap >>profile
|
||||
<mailbox> >>in-messages
|
||||
<mailbox> >>out-messages
|
||||
H{ } clone >>chats
|
||||
15 seconds >>reconnect-time
|
||||
V{ } clone >>exceptions
|
||||
[ <inet> latin1 <client> ] >>connect ;
|
||||
|
||||
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;
|
||||
|
|
@ -1,16 +1,7 @@
|
|||
USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ;
|
||||
USING: help.markup help.syntax quotations kernel
|
||||
irc.messages irc.messages.base irc.messages.parser irc.client.chats ;
|
||||
IN: irc.client
|
||||
|
||||
HELP: irc-client "IRC Client object" ;
|
||||
|
||||
HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
|
||||
|
||||
HELP: irc-channel-chat "Chat for irc channels" ;
|
||||
|
||||
HELP: irc-nick-chat "Chat for irc users" ;
|
||||
|
||||
HELP: irc-profile "IRC Client profile object" ;
|
||||
|
||||
HELP: connect-irc "Connecting to an irc server"
|
||||
{ $values { "irc-client" "an irc client object" } }
|
||||
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
|
||||
|
|
@ -69,6 +60,7 @@ ARTICLE: "irc.client" "IRC Client"
|
|||
{ { $link mode } "mode change" }
|
||||
{ { $link unhandled } "uninmplemented/unhandled message" }
|
||||
}
|
||||
|
||||
{ $heading "Special messages" }
|
||||
"Some special messages that are created by the library and not by the irc server."
|
||||
{ $table
|
||||
|
|
@ -79,7 +71,7 @@ ARTICLE: "irc.client" "IRC Client"
|
|||
|
||||
{ $heading "Example:" }
|
||||
{ $code
|
||||
"USING: irc.client ;"
|
||||
"USING: irc.client irc.client.chats ;"
|
||||
"SYMBOL: bot"
|
||||
"SYMBOL: mychannel"
|
||||
"! Create the profile and client objects"
|
||||
|
|
@ -91,7 +83,7 @@ ARTICLE: "irc.client" "IRC Client"
|
|||
"! Register and start chat (this joins the channel)"
|
||||
"mychannel get bot get attach-chat"
|
||||
"! Send a message to the channel"
|
||||
"\"what's up?\" mychannel get speak"
|
||||
"\"Hello World!\" mychannel get speak"
|
||||
"! Read a message from the channel"
|
||||
"mychannel get hear"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,380 +1,15 @@
|
|||
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
|
||||
accessors destructors namespaces io assocs arrays fry
|
||||
continuations threads strings classes combinators splitting hashtables
|
||||
ascii irc.messages irc.messages.base irc.messages.parser ;
|
||||
RENAME: join sequences => sjoin
|
||||
EXCLUDE: sequences => join ;
|
||||
USING: accessors concurrency.mailboxes destructors
|
||||
irc.client.base irc.client.chats irc.client.internals kernel
|
||||
namespaces sequences ;
|
||||
IN: irc.client
|
||||
|
||||
! ======================================
|
||||
! Setup and running objects
|
||||
! ======================================
|
||||
|
||||
CONSTANT: irc-port 6667 ! Default irc port
|
||||
|
||||
TUPLE: irc-profile server port nickname password ;
|
||||
C: <irc-profile> irc-profile
|
||||
|
||||
TUPLE: irc-client profile stream in-messages out-messages
|
||||
chats is-running nick connect reconnect-time is-ready ;
|
||||
|
||||
: <irc-client> ( profile -- irc-client )
|
||||
irc-client new
|
||||
swap >>profile
|
||||
<mailbox> >>in-messages
|
||||
<mailbox> >>out-messages
|
||||
H{ } clone >>chats
|
||||
dup profile>> nickname>> >>nick
|
||||
[ <inet> latin1 <client> ] >>connect
|
||||
15 seconds >>reconnect-time ;
|
||||
|
||||
TUPLE: irc-chat in-messages client ;
|
||||
TUPLE: irc-server-chat < irc-chat ;
|
||||
TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
|
||||
TUPLE: irc-nick-chat < irc-chat name ;
|
||||
SYMBOL: +server-chat+
|
||||
|
||||
! 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+
|
||||
SYMBOL: +nick+
|
||||
|
||||
! chat objects
|
||||
: <irc-server-chat> ( -- irc-server-chat )
|
||||
<mailbox> f irc-server-chat boa ;
|
||||
|
||||
: <irc-channel-chat> ( name -- irc-channel-chat )
|
||||
[ <mailbox> f ] dip f 60 seconds H{ } clone t
|
||||
irc-channel-chat boa ;
|
||||
|
||||
: <irc-nick-chat> ( name -- irc-nick-chat )
|
||||
[ <mailbox> f ] dip irc-nick-chat boa ;
|
||||
|
||||
! ======================================
|
||||
! Message objects
|
||||
! ======================================
|
||||
|
||||
TUPLE: participant-changed nick action parameter ;
|
||||
C: <participant-changed> participant-changed
|
||||
|
||||
SINGLETON: irc-chat-end ! sent to a chat 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
|
||||
|
||||
: terminate-irc ( irc-client -- )
|
||||
dup is-running>> [
|
||||
f >>is-running
|
||||
[ stream>> dispose ] keep
|
||||
[ in-messages>> ] [ out-messages>> ] bi 2array
|
||||
[ irc-end swap mailbox-put ] each
|
||||
] [ drop ] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: current-irc-client
|
||||
|
||||
! ======================================
|
||||
! Utils
|
||||
! ======================================
|
||||
|
||||
: irc> ( -- irc-client ) current-irc-client get ;
|
||||
: irc-write ( s -- ) irc> stream>> stream-write ;
|
||||
: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
|
||||
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
|
||||
: chat> ( name -- chat/f ) irc> chats>> at ;
|
||||
: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
|
||||
: me? ( string -- ? ) irc> nick>> = ;
|
||||
|
||||
GENERIC: to-chat ( message obj -- )
|
||||
|
||||
M: string to-chat
|
||||
chat> [ +server-chat+ chat> ] unless*
|
||||
[ to-chat ] [ drop ] if* ;
|
||||
|
||||
M: irc-chat to-chat in-messages>> mailbox-put ;
|
||||
M: sequence to-chat [ to-chat ] with each ;
|
||||
|
||||
: unregister-chat ( name -- )
|
||||
irc> chats>>
|
||||
[ at [ irc-chat-end ] dip to-chat ]
|
||||
[ delete-at ]
|
||||
2bi ;
|
||||
|
||||
: (remove-participant) ( nick chat -- )
|
||||
[ participants>> delete-at ]
|
||||
[ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
|
||||
|
||||
: remove-participant ( nick channel -- )
|
||||
chat> [ (remove-participant) ] [ drop ] if* ;
|
||||
|
||||
: chats-with-participant ( nick -- seq )
|
||||
irc> chats>> values
|
||||
[ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ]
|
||||
with filter ;
|
||||
|
||||
: remove-participant-from-all ( nick -- )
|
||||
dup chats-with-participant [ (remove-participant) ] with each ;
|
||||
|
||||
: notify-rename ( newnick oldnick chat -- )
|
||||
[ participant-changed new +nick+ >>action
|
||||
[ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
|
||||
|
||||
: rename-participant ( newnick oldnick chat -- )
|
||||
[ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
|
||||
[ notify-rename ] 3bi ;
|
||||
|
||||
: rename-participant-in-all ( oldnick newnick -- )
|
||||
swap dup chats-with-participant [ rename-participant ] with with each ;
|
||||
|
||||
: add-participant ( mode nick channel -- )
|
||||
chat>
|
||||
[ participants>> set-at ]
|
||||
[ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
|
||||
|
||||
: change-participant-mode ( channel mode nick -- )
|
||||
rot chat>
|
||||
[ participants>> set-at ]
|
||||
[ [ participant-changed new
|
||||
[ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
|
||||
3bi ; ! FIXME
|
||||
|
||||
! ======================================
|
||||
! IRC client messages
|
||||
! ======================================
|
||||
|
||||
: /NICK ( nick -- )
|
||||
"NICK " irc-write irc-print ;
|
||||
|
||||
: /LOGIN ( nick -- )
|
||||
dup /NICK
|
||||
"USER " irc-write irc-write
|
||||
" hostname servername :irc.factor" irc-print ;
|
||||
|
||||
: /CONNECT ( server port -- stream )
|
||||
irc> connect>> call( host port -- stream local ) drop ;
|
||||
|
||||
: /JOIN ( channel password -- )
|
||||
"JOIN " irc-write [ " :" swap 3append ] when* irc-print ;
|
||||
|
||||
: /PONG ( text -- )
|
||||
"PONG " irc-write irc-print ;
|
||||
|
||||
! ======================================
|
||||
! Server message handling
|
||||
! ======================================
|
||||
|
||||
GENERIC: initialize-chat ( chat -- )
|
||||
M: irc-chat initialize-chat drop ;
|
||||
M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
|
||||
|
||||
GENERIC: forward-name ( irc-message -- name )
|
||||
M: join forward-name trailing>> ;
|
||||
M: part forward-name channel>> ;
|
||||
M: kick forward-name channel>> ;
|
||||
M: mode forward-name name>> ;
|
||||
M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ;
|
||||
|
||||
UNION: single-forward join part kick mode privmsg ;
|
||||
UNION: multiple-forward nick quit ;
|
||||
UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
|
||||
GENERIC: forward-message ( irc-message -- )
|
||||
|
||||
M: irc-message forward-message
|
||||
+server-chat+ chat> [ to-chat ] [ drop ] if* ;
|
||||
|
||||
M: single-forward forward-message dup forward-name to-chat ;
|
||||
|
||||
M: multiple-forward forward-message
|
||||
dup sender>> chats-with-participant to-chat ;
|
||||
|
||||
M: broadcast-forward forward-message
|
||||
irc> chats>> values [ to-chat ] with each ;
|
||||
|
||||
GENERIC: process-message ( irc-message -- )
|
||||
M: object process-message drop ;
|
||||
M: rpl-welcome process-message
|
||||
nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
|
||||
values [ initialize-chat ] each ;
|
||||
M: ping process-message trailing>> /PONG ;
|
||||
M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
|
||||
|
||||
M: join process-message
|
||||
[ drop +normal+ ] [ sender>> ] [ trailing>> ] tri
|
||||
dup chat> [ add-participant ] [ 3drop ] if ;
|
||||
|
||||
M: part process-message
|
||||
[ sender>> ] [ channel>> ] bi remove-participant ;
|
||||
|
||||
M: kick process-message
|
||||
[ [ user>> ] [ channel>> ] bi remove-participant ]
|
||||
[ dup user>> me? [ unregister-chat ] [ drop ] if ]
|
||||
bi ;
|
||||
|
||||
M: quit process-message
|
||||
sender>> remove-participant-from-all ;
|
||||
|
||||
M: nick process-message
|
||||
[ sender>> ] [ trailing>> ] bi rename-participant-in-all ;
|
||||
|
||||
M: mode process-message ( mode -- )
|
||||
dup channel-mode? [
|
||||
[ name>> ] [ mode>> ] [ parameter>> ] tri
|
||||
[ change-participant-mode ] [ 2drop ] if*
|
||||
] [ drop ] if ;
|
||||
|
||||
: >nick/mode ( string -- nick mode )
|
||||
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
|
||||
|
||||
: names-reply>participants ( names-reply -- participants )
|
||||
nicks>> [ blank? ] trim " " split
|
||||
[ >nick/mode 2array ] map >hashtable ;
|
||||
|
||||
: maybe-clean-participants ( channel-chat -- )
|
||||
dup clean-participants>> [
|
||||
H{ } clone >>participants f >>clean-participants
|
||||
] when drop ;
|
||||
|
||||
M: rpl-names process-message
|
||||
[ names-reply>participants ] [ channel>> chat> ] bi [
|
||||
[ maybe-clean-participants ]
|
||||
[ participants>> 2array assoc-combine ]
|
||||
[ (>>participants) ] tri
|
||||
] [ drop ] if* ;
|
||||
|
||||
M: rpl-names-end process-message
|
||||
channel>> chat> [
|
||||
t >>clean-participants
|
||||
[ f f f <participant-changed> ] dip name>> to-chat
|
||||
] when* ;
|
||||
|
||||
! ======================================
|
||||
! Client message handling
|
||||
! ======================================
|
||||
|
||||
GENERIC: handle-outgoing-irc ( irc-message -- ? )
|
||||
M: irc-end handle-outgoing-irc drop f ;
|
||||
M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
|
||||
|
||||
! ======================================
|
||||
! Reader/Writer
|
||||
! ======================================
|
||||
|
||||
: handle-reader-message ( irc-message -- )
|
||||
irc> in-messages>> mailbox-put ;
|
||||
|
||||
DEFER: (connect-irc)
|
||||
|
||||
: (handle-disconnect) ( -- )
|
||||
irc>
|
||||
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
|
||||
[ dup reconnect-time>> sleep (connect-irc) ]
|
||||
[ nick>> /LOGIN ]
|
||||
tri ;
|
||||
|
||||
! FIXME: do something with the exception, store somewhere to help debugging
|
||||
: handle-disconnect ( error -- ? )
|
||||
drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
|
||||
|
||||
: (reader-loop) ( -- ? )
|
||||
irc> stream>> [
|
||||
|dispose stream-readln [
|
||||
string>irc-message handle-reader-message t
|
||||
] [
|
||||
f handle-disconnect
|
||||
] if*
|
||||
] with-destructors ;
|
||||
|
||||
: reader-loop ( -- ? )
|
||||
[ (reader-loop) ] [ handle-disconnect ] recover ;
|
||||
|
||||
: writer-loop ( -- ? )
|
||||
irc> out-messages>> mailbox-get handle-outgoing-irc ;
|
||||
|
||||
! ======================================
|
||||
! Processing loops
|
||||
! ======================================
|
||||
|
||||
: in-multiplexer-loop ( -- ? )
|
||||
irc> in-messages>> mailbox-get
|
||||
[ forward-message ] [ process-message ] [ irc-end? not ] tri ;
|
||||
|
||||
: strings>privmsg ( name string -- privmsg )
|
||||
" :" prepend append "PRIVMSG " prepend string>irc-message ;
|
||||
|
||||
: maybe-annotate-with-name ( name obj -- obj )
|
||||
{ { [ dup string? ] [ strings>privmsg ] }
|
||||
{ [ dup privmsg instance? ] [ swap >>name ] }
|
||||
[ nip ]
|
||||
} cond ;
|
||||
|
||||
GENERIC: annotate-message ( chat object -- object )
|
||||
M: object annotate-message nip ;
|
||||
M: part annotate-message swap name>> >>channel ;
|
||||
M: privmsg annotate-message swap name>> >>target ;
|
||||
M: string annotate-message [ name>> ] dip strings>privmsg ;
|
||||
|
||||
: spawn-irc ( -- )
|
||||
[ reader-loop ] "irc-reader-loop" spawn-server
|
||||
[ writer-loop ] "irc-writer-loop" spawn-server
|
||||
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
|
||||
3drop ;
|
||||
|
||||
GENERIC: (attach-chat) ( irc-chat -- )
|
||||
|
||||
M: irc-chat (attach-chat)
|
||||
[ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
|
||||
[ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
|
||||
bi ;
|
||||
|
||||
M: irc-server-chat (attach-chat)
|
||||
irc> >>client +server-chat+ irc> chats>> set-at ;
|
||||
|
||||
GENERIC: (remove-chat) ( irc-chat -- )
|
||||
|
||||
M: irc-nick-chat (remove-chat)
|
||||
name>> unregister-chat ;
|
||||
|
||||
M: irc-channel-chat (remove-chat)
|
||||
[ part new annotate-message irc> out-messages>> mailbox-put ] keep
|
||||
name>> unregister-chat ;
|
||||
|
||||
M: irc-server-chat (remove-chat)
|
||||
drop +server-chat+ unregister-chat ;
|
||||
|
||||
: (connect-irc) ( irc-client -- )
|
||||
{
|
||||
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
|
||||
[ (>>stream) ]
|
||||
[ t swap (>>is-running) ]
|
||||
[ in-messages>> [ irc-connected ] dip mailbox-put ]
|
||||
} cleave ;
|
||||
|
||||
: with-irc-client ( irc-client quot: ( -- ) -- )
|
||||
[ \ current-irc-client ] dip with-variable ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: connect-irc ( irc-client -- )
|
||||
dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
|
||||
|
||||
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
|
||||
|
||||
: detach-chat ( irc-chat -- )
|
||||
[ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
|
||||
|
||||
: speak ( message irc-chat -- )
|
||||
[ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
|
||||
[ (connect-irc) (do-login) spawn-irc ] with-irc ;
|
||||
|
||||
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ;
|
||||
: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ;
|
||||
: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ;
|
||||
: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
|
||||
: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel tools.test accessors arrays sequences
|
||||
io io.streams.duplex namespaces threads destructors
|
||||
calendar irc.client.private irc.client irc.messages
|
||||
concurrency.mailboxes classes assocs combinators irc.messages.parser ;
|
||||
calendar concurrency.mailboxes classes assocs combinators
|
||||
irc.messages.parser irc.client.base irc.client.chats
|
||||
irc.client.participants irc.client.internals ;
|
||||
EXCLUDE: irc.messages => join ;
|
||||
RENAME: join irc.messages => join_
|
||||
IN: irc.client.tests
|
||||
IN: irc.client.internals.tests
|
||||
|
||||
! Streams for testing
|
||||
TUPLE: mb-writer lines last-line disposed ;
|
||||
|
|
@ -28,19 +31,20 @@ M: mb-writer dispose drop ;
|
|||
t >>is-ready
|
||||
t >>is-running
|
||||
<test-stream> >>stream
|
||||
dup [ spawn-irc yield ] with-irc-client ;
|
||||
dup [ spawn-irc yield ] with-irc ;
|
||||
|
||||
! to be used inside with-irc-client quotations
|
||||
: %add-named-chat ( chat -- ) irc> attach-chat ;
|
||||
! to be used inside with-irc quotations
|
||||
: %add-named-chat ( chat -- ) (attach-chat) ;
|
||||
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
|
||||
: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
|
||||
: %push-lines ( lines -- ) [ %push-line ] each ;
|
||||
: %join ( channel -- ) <irc-channel-chat> (attach-chat) ;
|
||||
: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ;
|
||||
|
||||
: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
|
||||
[ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
|
||||
|
||||
: with-irc ( quot: ( -- ) -- )
|
||||
[ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline
|
||||
[ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! TESTS
|
||||
|
|
@ -50,13 +54,11 @@ M: mb-writer dispose drop ;
|
|||
|
||||
{ "factorbot" } [ irc> nick>> ] unit-test
|
||||
|
||||
! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
|
||||
|
||||
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
string>irc-message forward-name ] unit-test
|
||||
string>irc-message chat-name ] unit-test
|
||||
|
||||
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
|
||||
string>irc-message forward-name ] unit-test
|
||||
string>irc-message chat-name ] unit-test
|
||||
] with-irc
|
||||
|
||||
{ privmsg "#channel" "hello" } [
|
||||
|
|
@ -75,7 +77,12 @@ M: mb-writer dispose drop ;
|
|||
{ 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 ] [ stream>> out>> lines>> ] [ terminate-irc ] tri
|
||||
[
|
||||
(connect-irc)
|
||||
(do-login)
|
||||
irc> stream>> out>> lines>>
|
||||
(terminate-irc)
|
||||
] with-irc
|
||||
] unit-test
|
||||
|
||||
! Test join
|
||||
|
|
@ -90,16 +97,9 @@ M: mb-writer dispose drop ;
|
|||
":ircserver.net 353 factorbot @ #factortest :@factorbot "
|
||||
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
|
||||
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
|
||||
} [ %push-line ] each
|
||||
in-messages>> 0.1 seconds mailbox-get-timeout
|
||||
[ class ] [ trailing>> ] bi
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { T{ participant-changed f "somebody" +join+ } } [
|
||||
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
|
||||
":somebody!n=somebody@some.where JOIN :#factortest" %push-line
|
||||
[ participant-changed? ] read-matching-message
|
||||
} %push-lines
|
||||
[ join? ] read-matching-message
|
||||
[ class ] [ channel>> ] bi
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
|
|
@ -119,112 +119,95 @@ M: mb-writer dispose drop ;
|
|||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { mode } [
|
||||
[ { mode "#factortest" "+ns" } [
|
||||
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
|
||||
":ircserver.net MODE #factortest +ns" %push-line
|
||||
[ mode? ] read-matching-message class
|
||||
[ mode? ] read-matching-message
|
||||
[ class ] [ name>> ] [ mode>> ] tri
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
! Participant lists tests
|
||||
[ { H{ { "ircuser" +normal+ } } } [
|
||||
[ { { "ircuser" } } [
|
||||
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
|
||||
":ircuser!n=user@isp.net JOIN :#factortest" %push-line
|
||||
participants>>
|
||||
participants>> keys
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { H{ { "ircuser2" +normal+ } } } [
|
||||
[ { { "ircuser2" } } [
|
||||
"#factortest" <irc-channel-chat>
|
||||
H{ { "ircuser2" +normal+ }
|
||||
{ "ircuser" +normal+ } } clone >>participants
|
||||
{ "ircuser2" "ircuser" } [ over join-participant ] each
|
||||
[ %add-named-chat ] keep
|
||||
":ircuser!n=user@isp.net PART #factortest" %push-line
|
||||
participants>>
|
||||
participants>> keys
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { H{ { "ircuser2" +normal+ } } } [
|
||||
[ { { "ircuser2" } } [
|
||||
"#factortest" <irc-channel-chat>
|
||||
H{ { "ircuser2" +normal+ }
|
||||
{ "ircuser" +normal+ } } clone >>participants
|
||||
{ "ircuser2" "ircuser" } [ over join-participant ] each
|
||||
[ %add-named-chat ] keep
|
||||
":ircuser!n=user@isp.net QUIT" %push-line
|
||||
participants>>
|
||||
participants>> keys
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { H{ { "ircuser2" +normal+ } } } [
|
||||
[ { { "ircuser2" } } [
|
||||
"#factortest" <irc-channel-chat>
|
||||
H{ { "ircuser2" +normal+ }
|
||||
{ "ircuser" +normal+ } } clone >>participants
|
||||
{ "ircuser2" "ircuser" } [ over join-participant ] each
|
||||
[ %add-named-chat ] keep
|
||||
":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
|
||||
participants>>
|
||||
participants>> keys
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { H{ { "ircuser2" +normal+ } } } [
|
||||
[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [
|
||||
"#factortest" <irc-channel-chat>
|
||||
H{ { "ircuser" +normal+ } } clone >>participants
|
||||
"ircuser" over join-participant
|
||||
[ %add-named-chat ] keep
|
||||
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
|
||||
participants>>
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
|
||||
[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
|
||||
{ "ircuser" T{ participant { nick "ircuser" } } }
|
||||
{ "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
|
||||
"#factortest" <irc-channel-chat>
|
||||
H{ { "ircuser" +normal+ } } clone >>participants
|
||||
"ircuser" over join-participant
|
||||
[ %add-named-chat ] keep
|
||||
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
|
||||
":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line
|
||||
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
|
||||
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
|
||||
":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line
|
||||
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
|
||||
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
|
||||
":ircserver.net 353 factorbot @ #factortest :ircuser2 "
|
||||
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
|
||||
":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced "
|
||||
":ircserver.net 353 factorbot @ #factortest :ircuser "
|
||||
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
|
||||
} %push-lines
|
||||
participants>>
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
! Namelist change notification
|
||||
[ { T{ participant-changed f f f f } } [
|
||||
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
|
||||
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
|
||||
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
|
||||
[ participant-changed? ] read-matching-message
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { T{ participant-changed f "ircuser" +part+ f } } [
|
||||
"#factortest" <irc-channel-chat>
|
||||
H{ { "ircuser" +normal+ } } clone >>participants
|
||||
[ %add-named-chat ] keep
|
||||
":ircuser!n=user@isp.net QUIT" %push-line
|
||||
[ participant-changed? ] read-matching-message
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
|
||||
"#factortest" <irc-channel-chat>
|
||||
H{ { "ircuser" +normal+ } } clone >>participants
|
||||
[ %add-named-chat ] keep
|
||||
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
|
||||
[ participant-changed? ] read-matching-message
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
! Mode change
|
||||
[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
|
||||
[ { mode "#factortest" "+o" "ircuser" } [
|
||||
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
|
||||
"ircuser" over join-participant
|
||||
":ircserver.net MODE #factortest +o ircuser" %push-line
|
||||
[ participant-changed? ] read-matching-message
|
||||
[ mode? ] read-matching-message
|
||||
{ [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
[ { T{ participant { nick "ircuser" } { operator t } } } [
|
||||
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
|
||||
"ircuser" over join-participant
|
||||
":ircserver.net MODE #factortest +o ircuser" %push-line
|
||||
participants>> "ircuser" swap at
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
||||
! Send privmsg
|
||||
[ { "PRIVMSG #factortest :hello" } [
|
||||
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
|
||||
"hello" swap speak %pop-output-line
|
||||
"hello" swap (speak) %pop-output-line
|
||||
] unit-test
|
||||
] with-irc
|
||||
|
|
@ -0,0 +1,162 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs arrays concurrency.mailboxes continuations destructors
|
||||
hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
|
||||
strings words.symbol irc.messages.base irc.client.participants fry threads
|
||||
combinators irc.messages.parser ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.client.internals
|
||||
|
||||
: /NICK ( nick -- ) "NICK " prepend irc-print ;
|
||||
: /PONG ( text -- ) "PONG " prepend irc-print ;
|
||||
|
||||
: /LOGIN ( nick -- )
|
||||
dup /NICK
|
||||
"USER " prepend " hostname servername :irc.factor" append irc-print ;
|
||||
|
||||
: /CONNECT ( server port -- stream )
|
||||
irc> connect>> call( host port -- stream local ) drop ;
|
||||
|
||||
: /JOIN ( channel password -- )
|
||||
[ " :" swap 3append ] when* "JOIN " prepend irc-print ;
|
||||
|
||||
: (connect-irc) ( -- )
|
||||
irc> {
|
||||
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
|
||||
[ (>>stream) ]
|
||||
[ t swap (>>is-running) ]
|
||||
[ in-messages>> [ irc-connected ] dip mailbox-put ]
|
||||
} cleave ;
|
||||
|
||||
: (do-login) ( -- ) irc> nick>> /LOGIN ;
|
||||
|
||||
GENERIC: initialize-chat ( chat -- )
|
||||
M: irc-chat initialize-chat drop ;
|
||||
M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
|
||||
|
||||
GENERIC: chat-put ( message obj -- )
|
||||
M: irc-chat chat-put in-messages>> mailbox-put ;
|
||||
M: symbol chat-put chat> [ chat-put ] [ drop ] if* ;
|
||||
M: string chat-put chat> +server-chat+ or chat-put ;
|
||||
M: sequence chat-put [ chat-put ] with each ;
|
||||
|
||||
: delete-chat ( name -- ) irc> chats>> delete-at ;
|
||||
: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ;
|
||||
|
||||
! Server message handling
|
||||
|
||||
GENERIC: forward-message ( irc-message -- )
|
||||
M: irc-message forward-message +server-chat+ chat-put ;
|
||||
M: to-one-chat forward-message dup chat> chat-put ;
|
||||
M: to-all-chats forward-message chats> chat-put ;
|
||||
M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
|
||||
|
||||
GENERIC: process-message ( irc-message -- )
|
||||
M: object process-message drop ;
|
||||
M: ping process-message trailing>> /PONG ;
|
||||
M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
|
||||
M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
|
||||
M: quit process-message sender>> quit-participant ;
|
||||
M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
|
||||
M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
|
||||
|
||||
M: rpl-welcome process-message
|
||||
irc>
|
||||
swap nickname>> >>nick
|
||||
t >>is-ready
|
||||
chats>> values [ initialize-chat ] each ;
|
||||
|
||||
M: kick process-message
|
||||
[ [ user>> ] [ chat> ] bi part-participant ]
|
||||
[ dup user>> me? [ unregister-chat ] [ drop ] if ]
|
||||
bi ;
|
||||
|
||||
M: participant-mode process-message ( participant-mode -- )
|
||||
[ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ;
|
||||
|
||||
M: rpl-names process-message
|
||||
[ nicks>> ] [ chat> ] bi dup ?clear-participants
|
||||
'[ _ join-participant ] each ;
|
||||
|
||||
M: rpl-names-end process-message chat> t >>clear-participants drop ;
|
||||
|
||||
! Client message handling
|
||||
|
||||
GENERIC: handle-outgoing-irc ( irc-message -- ? )
|
||||
M: irc-end handle-outgoing-irc drop f ;
|
||||
M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
|
||||
|
||||
! Reader/Writer
|
||||
|
||||
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
|
||||
|
||||
: (handle-disconnect) ( -- )
|
||||
irc> in-messages>> irc-disconnected swap mailbox-put
|
||||
irc> reconnect-time>> sleep
|
||||
(connect-irc)
|
||||
(do-login) ;
|
||||
|
||||
: handle-disconnect ( error -- ? )
|
||||
[ irc> exceptions>> push ] when*
|
||||
irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
|
||||
|
||||
GENERIC: handle-input ( line/f -- ? )
|
||||
M: string handle-input string>irc-message handle-reader-message t ;
|
||||
M: f handle-input handle-disconnect ;
|
||||
|
||||
: (reader-loop) ( -- ? )
|
||||
stream> [ |dispose stream-readln handle-input ] with-destructors ;
|
||||
|
||||
: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ;
|
||||
: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ;
|
||||
|
||||
! Processing loops
|
||||
|
||||
: in-multiplexer-loop ( -- ? )
|
||||
irc> in-messages>> mailbox-get
|
||||
[ process-message ] [ forward-message ] [ irc-end? not ] tri ;
|
||||
|
||||
: strings>privmsg ( name string -- privmsg )
|
||||
" :" prepend append "PRIVMSG " prepend string>irc-message ;
|
||||
|
||||
GENERIC: annotate-message ( chat object -- object )
|
||||
M: object annotate-message nip ;
|
||||
M: to-channel annotate-message swap name>> >>channel ;
|
||||
M: to-target annotate-message swap name>> >>target ;
|
||||
M: mode annotate-message swap name>> >>name ;
|
||||
M: string annotate-message [ name>> ] dip strings>privmsg ;
|
||||
|
||||
: spawn-irc ( -- )
|
||||
[ reader-loop ] "irc-reader-loop" spawn-server
|
||||
[ writer-loop ] "irc-writer-loop" spawn-server
|
||||
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
|
||||
3drop ;
|
||||
|
||||
GENERIC: (attach-chat) ( irc-chat -- )
|
||||
|
||||
M: irc-chat (attach-chat)
|
||||
irc>
|
||||
[ [ chats>> ] [ >>client name>> swap ] 2bi set-at ]
|
||||
[ is-ready>> [ initialize-chat ] [ drop ] if ]
|
||||
2bi ;
|
||||
|
||||
M: irc-server-chat (attach-chat)
|
||||
irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
|
||||
|
||||
GENERIC: remove-chat ( irc-chat -- )
|
||||
M: irc-nick-chat remove-chat name>> unregister-chat ;
|
||||
M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
|
||||
|
||||
M: irc-channel-chat remove-chat
|
||||
[ part new annotate-message irc-send ]
|
||||
[ name>> unregister-chat ] bi ;
|
||||
|
||||
: (terminate-irc) ( -- )
|
||||
irc> dup is-running>> [
|
||||
f >>is-running
|
||||
[ stream>> dispose ] keep
|
||||
[ in-messages>> ] [ out-messages>> ] bi 2array
|
||||
[ irc-end swap mailbox-put ] each
|
||||
] [ drop ] if ;
|
||||
|
||||
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators fry hashtables
|
||||
irc.client.base irc.client.chats kernel sequences splitting ;
|
||||
IN: irc.client.participants
|
||||
|
||||
TUPLE: participant nick operator voice ;
|
||||
: <participant> ( name -- participant )
|
||||
{
|
||||
{ [ "@" ?head ] [ t f ] }
|
||||
{ [ "+" ?head ] [ f t ] }
|
||||
[ f f ]
|
||||
} cond participant boa ;
|
||||
|
||||
GENERIC: has-participant? ( name irc-chat -- ? )
|
||||
M: irc-chat has-participant? 2drop f ;
|
||||
M: irc-channel-chat has-participant? participants>> key? ;
|
||||
|
||||
: rename-X ( new old assoc quot: ( obj value -- obj ) -- )
|
||||
'[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline
|
||||
|
||||
: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ;
|
||||
: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ;
|
||||
: part-participant ( nick irc-chat -- ) participants>> delete-at ;
|
||||
: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ;
|
||||
|
||||
: quit-participant ( nick -- )
|
||||
dup participant-chats [ part-participant ] with each ;
|
||||
|
||||
: rename-participant* ( new old -- )
|
||||
[ dup participant-chats [ rename-participant ] with with each ]
|
||||
[ dup chat> [ rename-nick-chat ] [ 2drop ] if ]
|
||||
2bi ;
|
||||
|
||||
: join-participant ( nick irc-channel-chat -- )
|
||||
participants>> [ <participant> dup nick>> ] dip set-at ;
|
||||
|
||||
: apply-mode ( ? participant mode -- )
|
||||
{
|
||||
{ CHAR: o [ (>>operator) ] }
|
||||
{ CHAR: v [ (>>voice) ] }
|
||||
[ 3drop ]
|
||||
} case ;
|
||||
|
||||
: apply-modes ( mode-line participant -- )
|
||||
[ unclip CHAR: + = ] dip
|
||||
'[ [ _ _ ] dip apply-mode ] each ;
|
||||
|
||||
: change-participant-mode ( mode channel nick -- )
|
||||
swap chat> participants>> at apply-modes ;
|
||||
|
||||
: ?clear-participants ( channel-chat -- )
|
||||
dup clear-participants>> [
|
||||
f >>clear-participants participants>> clear-assoc
|
||||
] [ drop ] if ;
|
||||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2008 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry splitting ascii calendar accessors combinators
|
||||
arrays classes.tuple math.order words assocs strings
|
||||
irc.messages.base ;
|
||||
arrays classes.tuple math.order words assocs strings irc.messages.base ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.messages
|
||||
|
||||
|
|
@ -16,7 +15,7 @@ IRC: service "SERVICE" nickname _ distribution type _ : info ;
|
|||
IRC: quit "QUIT" : comment ;
|
||||
IRC: squit "SQUIT" server : comment ;
|
||||
! channel operations
|
||||
IRC: join "JOIN" channel ;
|
||||
IRC: join "JOIN" : channel ;
|
||||
IRC: part "PART" channel : comment ;
|
||||
IRC: topic "TOPIC" channel : topic ;
|
||||
IRC: names "NAMES" channel ;
|
||||
|
|
@ -61,3 +60,9 @@ IRC: rpl-names-end "366" nickname channel : comment ;
|
|||
! error replies
|
||||
IRC: rpl-nickname-in-use "433" _ name ;
|
||||
IRC: rpl-nick-collision "436" nickname : comment ;
|
||||
|
||||
M: rpl-names post-process-irc-message ( rpl-names -- )
|
||||
[ [ blank? ] trim " " split ] change-nicks drop ;
|
||||
|
||||
PREDICATE: channel-mode < mode name>> first "#&" member? ;
|
||||
PREDICATE: participant-mode < channel-mode parameter>> ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue