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

extra/irc/client/client-docs.factor

@@ -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"

extra/irc/client/client.factor

@@ -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
+USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
-       io.encodings.8-bit io.sockets kernel namespaces sequences
+       accessors destructors namespaces io assocs arrays qualified fry
-       splitting threads calendar classes.tuple
+       continuations threads strings classes combinators
-       classes ascii assocs accessors destructors continuations ;
+       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>
+    [ [ prefix>> parse-name me? ] keep and
-    [ irc> join-messages>> ] unless* mailbox-put ;
+      [ irc> join-messages>> mailbox-put ] when* ]
+    [ dup channel>> to-listener ]
+    bi ;
 
 M: part handle-incoming-irc ( part -- )
     dup channel>> to-listener ;
@@ -222,6 +174,9 @@ 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 ;
 
@@ -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

extra/irc/messages/authors.txt

@@ -0,0 +1 @@
+Bruno Deferrari

extra/irc/messages/messages.factor

@@ -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>