Merge branch 'master' of git://tiodante.com/git/factor

db4
U-WSCHLIEP-PC\wschliep 2008-07-09 21:54:03 -04:00
commit e8dfa79ab0
4 changed files with 99 additions and 74 deletions

View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax quotations kernel ;
USING: help.markup help.syntax quotations kernel irc.messages ;
IN: irc.client
HELP: irc-client "IRC Client object"

View File

@ -1,9 +1,11 @@
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators concurrency.mailboxes fry io strings
io.encodings.8-bit io.sockets kernel namespaces sequences
splitting threads calendar classes.tuple
classes ascii assocs accessors destructors continuations ;
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
accessors destructors namespaces io assocs arrays qualified fry
continuations threads strings classes combinators
irc.messages irc.messages.private ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
IN: irc.client
! ======================================
@ -27,6 +29,7 @@ TUPLE: irc-listener in-messages out-messages ;
TUPLE: irc-server-listener < irc-listener ;
TUPLE: irc-channel-listener < irc-listener name password timeout ;
TUPLE: irc-nick-listener < irc-listener name ;
SYMBOL: +server-listener+
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
@ -48,20 +51,6 @@ 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 ;
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: logged-in < irc-message name ;
TUPLE: ping < irc-message ;
TUPLE: join < irc-message ;
TUPLE: part < irc-message channel ;
TUPLE: quit < 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: unhandled < irc-message ;
: terminate-irc ( irc-client -- )
[ in-messages>> irc-end swap mailbox-put ]
[ f >>is-running drop ]
@ -82,13 +71,21 @@ TUPLE: unhandled < irc-message ;
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
: to-listener ( message name -- )
listener> [ f listener> ] unless*
listener> [ +server-listener+ listener> ] unless*
[ in-messages>> mailbox-put ] [ drop ] if* ;
! ======================================
! IRC client messages
! ======================================
GENERIC: irc-message>string ( irc-message -- string )
M: irc-message irc-message>string ( irc-message -- string )
[ command>> ]
[ parameters>> " " sjoin ]
[ trailing>> dup [ CHAR: : prefix ] when ]
tri 3array " " sjoin ;
: /NICK ( nick -- )
"NICK " irc-write irc-print ;
@ -125,53 +122,6 @@ TUPLE: unhandled < irc-message ;
: /PONG ( text -- )
"PONG " irc-write irc-print ;
! ======================================
! Message parsing
! ======================================
: split-at-first ( seq separators -- before after )
dupd '[ , member? ] find
[ cut 1 tail ]
[ swap ]
if ;
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
: parse-name ( string -- string )
remove-heading-: "!" split-at-first drop ;
: split-prefix ( string -- string/f string )
dup ":" head?
[ remove-heading-: " " split1 ]
[ f swap ]
if ;
: split-trailing ( string -- string string/f )
":" split1 ;
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
now irc-message boa ;
: parse-irc-line ( string -- message )
string>irc-message
dup command>> {
{ "PING" [ \ ping ] }
{ "NOTICE" [ \ notice ] }
{ "001" [ \ logged-in ] }
{ "433" [ \ nick-in-use ] }
{ "JOIN" [ \ join ] }
{ "PART" [ \ part ] }
{ "PRIVMSG" [ \ privmsg ] }
{ "QUIT" [ \ quit ] }
{ "MODE" [ \ mode ] }
{ "KICK" [ \ kick ] }
[ drop \ unhandled ]
} case
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
[ all-slots length head ] keep slots>tuple ;
! ======================================
! Server message handling
! ======================================
@ -188,7 +138,7 @@ TUPLE: unhandled < irc-message ;
GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- )
f listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
+server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
M: logged-in handle-incoming-irc ( logged-in -- )
name>> irc> profile>> (>>nickname) ;
@ -203,8 +153,10 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
dup trailing>> listener>
[ irc> join-messages>> ] unless* mailbox-put ;
[ [ prefix>> parse-name me? ] keep and
[ irc> join-messages>> mailbox-put ] when* ]
[ dup channel>> to-listener ]
bi ;
M: part handle-incoming-irc ( part -- )
dup channel>> to-listener ;
@ -222,11 +174,14 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
GENERIC: handle-outgoing-irc ( obj -- )
! M: irc-message handle-outgoing-irc ( irc-message -- )
! irc-message>string irc-print ;
M: privmsg handle-outgoing-irc ( privmsg -- )
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
M: part handle-outgoing-irc ( privmsg -- )
[ channel>> ] [ trailing>> "" or ] bi /PART ;
[ channel>> ] [ trailing>> "" or ] bi /PART ;
! ======================================
! Reader/Writer
@ -320,7 +275,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
[ name>> ] keep set+run-listener ;
M: irc-server-listener (add-listener) ( irc-server-listener -- )
f swap set+run-listener ;
+server-listener+ swap set+run-listener ;
GENERIC: (remove-listener) ( irc-listener -- )
@ -333,7 +288,7 @@ M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
name>> unregister-listener ;
M: irc-server-listener (remove-listener) ( irc-server-listener -- )
drop f unregister-listener ;
drop +server-listener+ unregister-listener ;
: (connect-irc) ( irc-client -- )
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep

View File

@ -0,0 +1 @@
Bruno Deferrari

View File

@ -0,0 +1,69 @@
! Copyright (C) 2008 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry sequences splitting ascii calendar accessors combinators
classes.tuple math.order ;
IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: logged-in < irc-message name ;
TUPLE: ping < irc-message ;
TUPLE: join < irc-message channel ;
TUPLE: part < irc-message channel ;
TUPLE: quit < 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: unhandled < irc-message ;
<PRIVATE
! ======================================
! Message parsing
! ======================================
: split-at-first ( seq separators -- before after )
dupd '[ , member? ] find
[ cut 1 tail ]
[ swap ]
if ;
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
: parse-name ( string -- string )
remove-heading-: "!" split-at-first drop ;
: split-prefix ( string -- string/f string )
dup ":" head?
[ remove-heading-: " " split1 ]
[ f swap ]
if ;
: split-trailing ( string -- string string/f )
":" split1 ;
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
now irc-message boa ;
: parse-irc-line ( string -- message )
string>irc-message
dup command>> {
{ "PING" [ \ ping ] }
{ "NOTICE" [ \ notice ] }
{ "001" [ \ logged-in ] }
{ "433" [ \ nick-in-use ] }
{ "JOIN" [ \ join ] }
{ "PART" [ \ part ] }
{ "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 ;
PRIVATE>