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

diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 472805f5ae193311ec89cf2fb8c78e70a4f475da..2dbbe8b8f5945b60094219237c26414d17af92e5 100644 (file)
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -2,8 +2,8 @@
 ! 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 qualified fry
-       continuations threads strings classes combinators
-       irc.messages irc.messages.private ;
+       continuations threads strings classes combinators splitting hashtables
+       ascii irc.messages irc.messages.private ;
 RENAME: join sequences => sjoin
 EXCLUDE: sequences => join ;
 IN: irc.client
@@ -27,7 +27,7 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages
 
 TUPLE: irc-listener in-messages out-messages ;
 TUPLE: irc-server-listener < irc-listener ;
-TUPLE: irc-channel-listener < irc-listener name password timeout ;
+TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
 TUPLE: irc-nick-listener < irc-listener name ;
 SYMBOL: +server-listener+
 
@@ -37,10 +37,10 @@ SYMBOL: +server-listener+
      <mailbox> <mailbox> irc-server-listener boa ;
 
 : <irc-channel-listener> ( name -- irc-channel-listener )
-     <mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
+     [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
 
 : <irc-nick-listener> ( name -- irc-nick-listener )
-     <mailbox> <mailbox> rot irc-nick-listener boa ;
+     [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
 
 ! ======================================
 ! Message objects
@@ -52,8 +52,8 @@ SINGLETON: irc-connected    ! sent when connection is established
 UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
 
 : terminate-irc ( irc-client -- )
-    [ in-messages>> irc-end swap mailbox-put ]
-    [ f >>is-running drop ]
+    [ [ irc-end ] dip in-messages>> mailbox-put ]
+    [ [ f ] dip (>>is-running) ]
     [ stream>> dispose ]
     tri ;
 
@@ -74,18 +74,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
     listener> [ +server-listener+ listener> ] unless*
     [ in-messages>> mailbox-put ] [ drop ] if* ;
 
+: remove-participant ( nick channel -- )
+    listener> [ participants>> delete-at ] [ drop ] if* ;
+
+: remove-participant-from-all ( nick -- )
+    irc> listeners>>
+    [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
+    assoc-each ;
+
+: add-participant ( nick mode channel -- )
+    listener> [ participants>> set-at ] [ 2drop ] if* ;
+
+DEFER: me?
+
+: maybe-forward-join ( join -- )
+    [ prefix>> parse-name me? ] keep and
+    [ irc> join-messages>> mailbox-put ] when* ;
+
 ! ======================================
 ! 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 ;
 
@@ -99,7 +108,7 @@ M: irc-message irc-message>string ( irc-message -- string )
 
 : /JOIN ( channel password -- )
     "JOIN " irc-write
-    [ " :" swap 3append ] when* irc-print ;
+    [ [ " :" ] dip 3append ] when* irc-print ;
 
 : /PART ( channel text -- )
     [ "PART " irc-write irc-write ] dip
@@ -153,17 +162,34 @@ M: privmsg handle-incoming-irc ( privmsg -- )
     dup irc-message-origin to-listener ;
 
 M: join handle-incoming-irc ( join -- )
-    [ [ prefix>> parse-name me? ] keep and
-      [ irc> join-messages>> mailbox-put ] when* ]
+    [ maybe-forward-join ]
     [ dup trailing>> to-listener ]
-    bi ;
+    [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+    tri ;
 
 M: part handle-incoming-irc ( part -- )
-    dup channel>> to-listener ;
+    [ dup channel>> to-listener ] keep
+    [ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
 
 M: kick handle-incoming-irc ( kick -- )
-    [ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
-    to-listener ;
+    [ dup channel>>  to-listener ]
+    [ [ who>> ] [ channel>> ] bi remove-participant ] 
+    [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+    tri ;
+
+M: quit handle-incoming-irc ( quit -- )
+    [ prefix>> parse-name remove-participant-from-all ] keep
+    call-next-method ;
+
+: >nick/mode ( string -- nick mode )
+    dup first "+@" member? [ unclip ] [ f ] if ;
+
+: names-reply>participants ( names-reply -- participants )
+    trailing>> [ blank? ] trim " " split
+    [ >nick/mode 2array ] map >hashtable ;
+
+M: names-reply handle-incoming-irc ( names-reply -- )
+    [ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ;
 
 M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
     broadcast-message-to-listeners ;
@@ -180,7 +206,7 @@ GENERIC: handle-outgoing-irc ( obj -- )
 M: privmsg handle-outgoing-irc ( privmsg -- )
     [ name>> ] [ trailing>> ] bi /PRIVMSG ;
 
-M: part handle-outgoing-irc ( privmsg -- )
+M: part handle-outgoing-irc ( part -- )
     [ channel>> ] [ trailing>> "" or ] bi /PART ;
 
 ! ======================================
@@ -188,8 +214,8 @@ M: part handle-outgoing-irc ( privmsg -- )
 ! ======================================
 
 : irc-mailbox-get ( mailbox quot -- )
-    swap 5 seconds
-    '[ , , , mailbox-get-timeout swap call ]
+    [ 5 seconds ] dip
+    '[ , , ,  [ mailbox-get-timeout ] dip call ]
     [ drop ] recover ; inline
 
 : handle-reader-message ( irc-message -- )
@@ -199,11 +225,12 @@ DEFER: (connect-irc)
 
 : (handle-disconnect) ( -- )
     irc>
-        [ in-messages>> irc-disconnected swap mailbox-put ]
+        [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
         [ dup reconnect-time>> sleep (connect-irc) ]
         [ profile>> nickname>> /LOGIN ]
     tri ;
 
+! FIXME: do something with the exception, store somewhere to help debugging
 : handle-disconnect ( error -- )
     drop irc> is-running>> [ (handle-disconnect) ] when ;
 
@@ -236,6 +263,7 @@ DEFER: (connect-irc)
     {
         { [ dup string? ] [ strings>privmsg ] }
         { [ dup privmsg instance? ] [ swap >>name ] }
+        [ nip ]
     } cond ;
 
 : listener-loop ( name listener -- )
@@ -275,7 +303,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
     [ name>> ] keep set+run-listener ;
 
 M: irc-server-listener (add-listener) ( irc-server-listener -- )
-    +server-listener+ swap set+run-listener ;
+    [ +server-listener+ ] dip set+run-listener ;
 
 GENERIC: (remove-listener) ( irc-listener -- )
 
@@ -283,8 +311,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
     name>> unregister-listener ;
 
 M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
-    [ [ out-messages>> ] [ name>> ] bi
-      \ part new swap >>channel mailbox-put ] keep
+    [ [ name>> ] [ out-messages>> ] bi
+      [ [ part new ] dip >>channel ] dip mailbox-put ] keep
     name>> unregister-listener ;
 
 M: irc-server-listener (remove-listener) ( irc-server-listener -- )
@@ -294,10 +322,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
     [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
         swap >>stream
         t >>is-running
-    in-messages>> irc-connected swap mailbox-put ;
+    in-messages>> [ irc-connected ] dip mailbox-put ;
 
 : with-irc-client ( irc-client quot -- )
-    >r current-irc-client r> with-variable ; inline
+    [ current-irc-client ] dip with-variable ; inline
 
 PRIVATE>
 

diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor
index f1beba9b26edfb535bf3da6deb9da545053e2b4a..205630d7903f9d4f1005a085ba98d17e62751409 100644 (file)
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@@ -1,13 +1,15 @@
 ! 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 ;
+USING: kernel fry splitting ascii calendar accessors combinators qualified
+       arrays classes.tuple math.order ;
+RENAME: join sequences => sjoin
+EXCLUDE: sequences => join ;
 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: join < irc-message ;
 TUPLE: part < irc-message channel ;
 TUPLE: quit < irc-message ;
 TUPLE: privmsg < irc-message name ;
@@ -16,8 +18,21 @@ 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: names-reply < irc-message who = channel ;
 TUPLE: unhandled < irc-message ;
 
+GENERIC: irc-message>client-line ( irc-message -- string )
+
+M: irc-message irc-message>client-line ( irc-message -- string )
+    [ command>> ]
+    [ parameters>> " " sjoin ]
+    [ trailing>> dup [ CHAR: : prefix ] when ]
+    tri 3array " " sjoin ;
+
+GENERIC: irc-message>server-line ( irc-message -- string )
+M: irc-message irc-message>server-line ( irc-message -- string )
+   drop "not implemented yet" ;
+
 <PRIVATE
 ! ======================================
 ! Message parsing
@@ -55,6 +70,7 @@ TUPLE: unhandled < irc-message ;
         { "NOTICE" [ \ notice ] }
         { "001" [ \ logged-in ] }
         { "433" [ \ nick-in-use ] }
+        { "353" [ \ names-reply ] }
         { "JOIN" [ \ join ] }
         { "PART" [ \ part ] }
         { "PRIVMSG" [ \ privmsg ] }

diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index cc138dad92f68dbd06d2cd3664b889613ded7b2e..54a177f61371dcaf2787b00a630979399ebe6e1e 100755 (executable)
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -5,7 +5,8 @@ USING: accessors kernel threads combinators concurrency.mailboxes
        sequences strings hashtables splitting fry assocs hashtables\r
        ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers\r
        ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs\r
-       io io.styles namespaces irc.client irc.messages ;\r
+       io io.styles namespaces irc.client irc.messages calendar\r
+       calendar.format ;\r
 \r
 IN: irc.ui\r
 \r
@@ -27,10 +28,20 @@ GENERIC: write-irc ( irc-message -- )
 M: privmsg write-irc\r
     "<" blue write-color\r
     [ prefix>> prefix>nick write ] keep\r
-    ">" blue write-color\r
-    " " write\r
+    "> " blue write-color\r
     trailing>> write ;\r
 \r
+TUPLE: own-message message nick timestamp ;\r
+\r
+: <own-message> ( message nick -- own-message )\r
+    now own-message boa ;\r
+\r
+M: own-message write-irc\r
+    "<" blue write-color\r
+    [ nick>> bold font-style associate format ] keep\r
+    "> " blue write-color\r
+    message>> write ;\r
+\r
 M: join write-irc\r
     "* " green write-color\r
     prefix>> prefix>nick write\r
@@ -63,15 +74,12 @@ M: irc-message write-irc
     drop ; ! catch all unimplemented writes, THIS WILL CHANGE    \r
 \r
 : print-irc ( irc-message -- )\r
-    write-irc nl ;\r
+    [ timestamp>> timestamp>hms write " " write ]\r
+    [ write-irc nl ] bi ;\r
 \r
 : send-message ( message listener client -- )\r
-    "<" blue write-color\r
-    profile>> nickname>> bold font-style associate format\r
-    ">" blue write-color\r
-    " " write\r
-    over write nl\r
-    out-messages>> mailbox-put ;\r
+    [ nip profile>> nickname>> <own-message> print-irc ]\r
+    [ drop write-message ] 3bi ;\r
 \r
 : display ( stream listener -- )\r
     '[ , [ [ t ]\r