Merge branch 'master' of git://factorcode.org/git/factor

Conflicts:

	extra/irc/messages/messages.factor

diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 2474fd643ac68fb7cdf93465bd746c02692c9074..62e28b2bbf946305ee69923c373ce984e9a55564 100644 (file)
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -183,7 +183,7 @@ GENERIC: forward-name ( irc-message -- name )
 M: join forward-name ( join -- name ) trailing>> ;
 M: part forward-name ( part -- name ) channel>> ;
 M: kick forward-name ( kick -- name ) channel>> ;
-M: mode forward-name ( mode -- name ) channel>> ;
+M: mode forward-name ( mode -- name ) name>> ;
 M: privmsg forward-name ( privmsg -- name )
     dup name>> me? [ irc-message-sender ] [ name>> ] if ;
 

diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor
index 20f4f1b2772189bb669bf3ea3f7c7ce97670e466..b61dd1644848eaf573dc8a6e57767a8fc786934a 100644 (file)
--- a/extra/irc/messages/messages-tests.factor
+++ b/extra/irc/messages/messages-tests.factor
@@ -6,54 +6,60 @@ IN: irc.messages.tests
 
 { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
 
-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
+{ T{ irc-message
+     { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
+     { prefix "someuser!n=user@some.where" }
+     { command  "PRIVMSG" }
+     { parameters { "#factortest" } }
+     { trailing "hi" } } }
 [ ":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
+{ T{ privmsg
+     { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
+     { prefix  "someuser!n=user@some.where" }
+     { command "PRIVMSG" }
+     { parameters { "#factortest" } }
+     { trailing "hi" }
+     { name "#factortest" } } }
 [ ":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
+{ T{ join
+     { line ":someuser!n=user@some.where JOIN :#factortest" }
+     { prefix "someuser!n=user@some.where" }
+     { command "JOIN" }
+     { parameters { } }
+     { trailing "#factortest" } } }
 [ ":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
+{ T{ mode
+     { line ":ircserver.net MODE #factortest +ns" }
+     { prefix "ircserver.net" }
+     { command "MODE" }
+     { parameters { "#factortest" "+ns" } }
+     { name "#factortest" }
+     { mode "+ns" } } }
 [ ":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
+{ T{ mode
+     { line ":ircserver.net MODE #factortest +o someuser" }
+     { prefix "ircserver.net" }
+     { command "MODE" }
+     { parameters { "#factortest" "+o" "someuser" } }
+     { name "#factortest" }
+     { mode "+o" }
+     { parameter "someuser" } } }
+[ ":ircserver.net MODE #factortest +o someuser"
+  parse-irc-line f >>timestamp ] unit-test
+
+{ T{ nick
+     { line ":someuser!n=user@some.where NICK :someuser2" }
+     { prefix "someuser!n=user@some.where" }
+     { command "NICK" }
+     { parameters  { } }
+     { trailing "someuser2" } } }
 [ ":someuser!n=user@some.where NICK :someuser2"
   parse-irc-line f >>timestamp ] unit-test
\ No newline at end of file

diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor
index 16066199edef33ea6eb32ff75740d5f1c37d7437..94f80dcf0cadda6b9c2d68f8acf33f2c9772abb5 100755 (executable)
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@@ -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 quotations ;
+       arrays classes.tuple math.order inverse ;
 RENAME: join sequences => sjoin
 EXCLUDE: sequences => join ;
 IN: irc.messages
@@ -18,8 +18,8 @@ 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 channel mode ;
-TUPLE: names-reply < irc-message who = channel ;
+TUPLE: mode < irc-message name mode parameter ;
+TUPLE: names-reply < irc-message who channel ;
 TUPLE: unhandled < irc-message ;
 
 : <irc-client-message> ( command parameters trailing -- irc-message )
@@ -28,41 +28,58 @@ TUPLE: unhandled < irc-message ;
 
 <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 )    channel>> 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 )
+GENERIC: command-string>> ( irc-message -- string )
+
+M: irc-message command-string>> ( irc-message -- string ) command>> ;
+M: ping        command-string>> ( ping -- string )    drop "PING" ;
+M: join        command-string>> ( join -- string )    drop "JOIN" ;
+M: part        command-string>> ( part -- string )    drop "PART" ;
+M: quit        command-string>> ( quit -- string )    drop "QUIT" ;
+M: nick        command-string>> ( nick -- string )    drop "NICK" ;
+M: privmsg     command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
+M: notice      command-string>> ( notice -- string )  drop "NOTICE" ;
+M: mode        command-string>> ( mode -- string )    drop "MODE" ;
+M: kick        command-string>> ( kick -- string )    drop "KICK" ;
+
+GENERIC: command-parameters>> ( irc-message -- seq )
+
+M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
+M: ping        command-parameters>> ( ping -- seq )    drop { } ;
+M: join        command-parameters>> ( join -- seq )    drop { } ;
+M: part        command-parameters>> ( part -- seq )    channel>> 1array ;
+M: quit        command-parameters>> ( quit -- seq )    drop { } ;
+M: nick        command-parameters>> ( nick -- seq )    drop { } ;
+M: privmsg     command-parameters>> ( privmsg -- seq ) name>> 1array ;
+M: notice      command-parameters>> ( norice -- seq )  type>> 1array ;
+M: kick command-parameters>> ( kick -- seq )
     [ channel>> ] [ who>> ] bi 2array ;
-M: mode irc-command-parameters ( mode -- seq )
+M: mode command-parameters>> ( mode -- seq )
     [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
 
+GENERIC: (>>command-parameters) ( params irc-message -- )
+
+M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ;
+M: logged-in (>>command-parameters) ( params part -- )  [ first ] dip (>>name) ;
+M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ;
+M: notice  (>>command-parameters) ( params notice -- )  [ first ] dip (>>type) ;
+M: part    (>>command-parameters) ( params part -- )
+    [ first ] dip (>>channel) ;
+M: kick    (>>command-parameters) ( params kick -- )
+    [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
+M: names-reply (>>command-parameters) ( params names-reply -- )
+    [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
+M: mode    (>>command-parameters) ( params mode -- )
+    { { [ [ 2array ] dip ] [ [ (>>mode) ] [ (>>name) ] bi ] }
+      { [ [ 3array ] dip ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
+    } switch ;
+
 PRIVATE>
 
 GENERIC: irc-message>client-line ( irc-message -- string )
 
 M: irc-message irc-message>client-line ( irc-message -- string )
-    [ irc-command-string ]
-    [ irc-command-parameters " " sjoin ]
+    [ command-string>> ]
+    [ command-parameters>> " " sjoin ]
     [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
     tri 3array " " sjoin ;
 
@@ -96,6 +113,15 @@ M: irc-message irc-message>server-line ( irc-message -- string )
 : split-trailing ( string -- string string/f )
     ":" split1 ;
 
+: copy-message-in ( origin dest -- )
+    { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
+      [ [ line>>       ] dip (>>line) ]
+      [ [ prefix>>     ] dip (>>prefix) ]
+      [ [ command>>    ] dip (>>command) ]
+      [ [ trailing>>   ] dip (>>trailing) ]
+      [ [ timestamp>>  ] dip (>>timestamp) ]
+    } 2cleave ;
+
 PRIVATE>
 
 UNION: sender-in-prefix privmsg join part quit kick mode nick ;
@@ -111,20 +137,17 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
 : 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 ] }
-        { "NICK" [ nick ] }
+        { "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 ] }
+        { "QUIT"    [ quit ] }
+        { "MODE"    [ mode ] }
+        { "KICK"    [ kick ] }
         [ drop unhandled ]
-    } case
-    [ [ tuple-slots ] [ parameters>> ] bi append ] dip
-    [ all-slots over [ length ] bi@ min head >quotation ] keep
-    '[ @ _ boa ] call ;
+    } case new [ copy-message-in ] keep ;