From f190a9d8cb31c5359cc1afd7ebed331fbb988b86 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 30 Jun 2008 12:31:21 -0300 Subject: [PATCH 1/8] irc.client: Clean a bit. --- extra/irc/client/client-tests.factor | 8 ++++---- extra/irc/client/client.factor | 12 +++--------- 2 files changed, 7 insertions(+), 13 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 24a753d615..f7065664dd 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -14,7 +14,7 @@ IN: irc.client.tests swap [ 2nip f ] curry >>connect ; : set-nick ( irc-client nickname -- ) - [ nick>> ] dip >>name drop ; + swap profile>> (>>nickname) ; : with-dummy-client ( quot -- ) rot with-variable ; inline @@ -42,9 +42,9 @@ privmsg new parse-irc-line f >>timestamp ] unit-test { "" } make-client dup "factorbot" set-nick current-irc-client [ - { t } [ irc> nick>> name>> me? ] unit-test + { t } [ irc> profile>> nickname>> me? ] unit-test - { "factorbot" } [ irc> nick>> name>> ] unit-test + { "factorbot" } [ irc> profile>> nickname>> ] unit-test { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test @@ -63,7 +63,7 @@ privmsg new ":some.where 001 factorbot :Welcome factorbot" } make-client [ connect-irc ] keep 1 seconds sleep - nick>> name>> ] unit-test + profile>> nickname>> ] unit-test { join_ "#factortest" } [ { ":factorbot!n=factorbo@some.where JOIN :#factortest" diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 5b8fbf62ee..45f2df3bdc 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -14,18 +14,12 @@ SYMBOL: current-irc-client : irc-port 6667 ; ! Default irc port -! "setup" objects TUPLE: irc-profile server port nickname password ; C: irc-profile -! "live" objects -TUPLE: nick name channels log ; -C: nick - -TUPLE: irc-client profile nick stream in-messages out-messages join-messages +TUPLE: irc-client profile stream in-messages out-messages join-messages listeners is-running connect reconnect-time ; : ( profile -- irc-client ) - f V{ } clone V{ } clone f H{ } clone f [ latin1 ] 15 seconds irc-client boa ; @@ -182,7 +176,7 @@ TUPLE: unhandled < irc-message ; ! ====================================== : me? ( string -- ? ) - irc> nick>> name>> = ; + irc> profile>> nickname>> = ; : irc-message-origin ( irc-message -- name ) dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; @@ -196,7 +190,7 @@ M: irc-message handle-incoming-irc ( irc-message -- ) f listener> [ in-messages>> mailbox-put ] [ drop ] if* ; M: logged-in handle-incoming-irc ( logged-in -- ) - name>> irc> nick>> (>>name) ; + name>> irc> profile>> (>>nickname) ; M: ping handle-incoming-irc ( ping -- ) trailing>> /PONG ; From 9f002ca5243ff2bd4fbb64733205df7efa586ee8 Mon Sep 17 00:00:00 2001 From: "U-WSCHLIEP-PC\\wschliep" Date: Tue, 8 Jul 2008 13:22:18 -0400 Subject: [PATCH 2/8] Added backtrack library --- extra/backtrack/authors.txt | 1 + extra/backtrack/backtrack.factor | 20 ++++++++++++++++++++ extra/backtrack/description.txt | 1 + 3 files changed, 22 insertions(+) create mode 100755 extra/backtrack/authors.txt create mode 100755 extra/backtrack/backtrack.factor create mode 100755 extra/backtrack/description.txt diff --git a/extra/backtrack/authors.txt b/extra/backtrack/authors.txt new file mode 100755 index 0000000000..50c9c38812 --- /dev/null +++ b/extra/backtrack/authors.txt @@ -0,0 +1 @@ +William Schlieper \ No newline at end of file diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor new file mode 100755 index 0000000000..7ab11abd6d --- /dev/null +++ b/extra/backtrack/backtrack.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel continuations sequences namespaces fry ; + +IN: backtrack + +SYMBOL: failure + +: amb ( seq -- elt ) + failure get + '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each + , continue ] callcc1 ; + +: fail ( -- ) + f amb drop ; + +: require ( ? -- ) + [ fail ] unless ; + diff --git a/extra/backtrack/description.txt b/extra/backtrack/description.txt new file mode 100755 index 0000000000..d2d3918a98 --- /dev/null +++ b/extra/backtrack/description.txt @@ -0,0 +1 @@ +Simple non-determinism \ No newline at end of file From d4aae8a183dd11847cc1bf663065bb1c408aecde Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Mon, 30 Jun 2008 12:31:21 -0300 Subject: [PATCH 3/8] irc.client: Clean a bit. --- extra/irc/client/client-tests.factor | 8 ++++---- extra/irc/client/client.factor | 12 +++--------- 2 files changed, 7 insertions(+), 13 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 24a753d615..f7065664dd 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -14,7 +14,7 @@ IN: irc.client.tests swap [ 2nip f ] curry >>connect ; : set-nick ( irc-client nickname -- ) - [ nick>> ] dip >>name drop ; + swap profile>> (>>nickname) ; : with-dummy-client ( quot -- ) rot with-variable ; inline @@ -42,9 +42,9 @@ privmsg new parse-irc-line f >>timestamp ] unit-test { "" } make-client dup "factorbot" set-nick current-irc-client [ - { t } [ irc> nick>> name>> me? ] unit-test + { t } [ irc> profile>> nickname>> me? ] unit-test - { "factorbot" } [ irc> nick>> name>> ] unit-test + { "factorbot" } [ irc> profile>> nickname>> ] unit-test { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test @@ -63,7 +63,7 @@ privmsg new ":some.where 001 factorbot :Welcome factorbot" } make-client [ connect-irc ] keep 1 seconds sleep - nick>> name>> ] unit-test + profile>> nickname>> ] unit-test { join_ "#factortest" } [ { ":factorbot!n=factorbo@some.where JOIN :#factortest" diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 5b8fbf62ee..45f2df3bdc 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -14,18 +14,12 @@ SYMBOL: current-irc-client : irc-port 6667 ; ! Default irc port -! "setup" objects TUPLE: irc-profile server port nickname password ; C: irc-profile -! "live" objects -TUPLE: nick name channels log ; -C: nick - -TUPLE: irc-client profile nick stream in-messages out-messages join-messages +TUPLE: irc-client profile stream in-messages out-messages join-messages listeners is-running connect reconnect-time ; : ( profile -- irc-client ) - f V{ } clone V{ } clone f H{ } clone f [ latin1 ] 15 seconds irc-client boa ; @@ -182,7 +176,7 @@ TUPLE: unhandled < irc-message ; ! ====================================== : me? ( string -- ? ) - irc> nick>> name>> = ; + irc> profile>> nickname>> = ; : irc-message-origin ( irc-message -- name ) dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; @@ -196,7 +190,7 @@ M: irc-message handle-incoming-irc ( irc-message -- ) f listener> [ in-messages>> mailbox-put ] [ drop ] if* ; M: logged-in handle-incoming-irc ( logged-in -- ) - name>> irc> nick>> (>>name) ; + name>> irc> profile>> (>>nickname) ; M: ping handle-incoming-irc ( ping -- ) trailing>> /PONG ; From 33fccfe4a4a1ecc9f85d2bf672fe9c3b410e906a Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 8 Jul 2008 16:57:53 -0300 Subject: [PATCH 4/8] irc.client: Add more words, fixes, update docs. --- extra/irc/client/client-docs.factor | 23 ++++++++++++++--- extra/irc/client/client.factor | 38 ++++++++++++++++++++++++++--- 2 files changed, 53 insertions(+), 8 deletions(-) diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 2a66f3a701..a675e663c3 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -21,13 +21,25 @@ HELP: connect-irc "Connecting to an irc server" { $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ; HELP: add-listener "Listening to irc channels/users/etc" -{ $values { "irc-client" "an irc client object" } { "irc-listener" "an irc listener object" } } +{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } } { $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ; +HELP: remove-listener "Stop an unregister listener" +{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } } +{ $description "Unregisters " { $snippet "irc-listener" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ; + HELP: terminate-irc "Terminates an irc client" { $values { "irc-client" "an irc client object" } } { $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ; +HELP: write-message "Sends a message through a listener" +{ $values { "message" "a string or irc message object" } { "irc-listener" "an irc listener object" } } +{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-listener" } ". Strings are automatically promoted to privmsg objects." } ; + +HELP: read-message "Reads a message from a listener" +{ $values { "irc-listener" "an irc listener object" } { "message" "an irc message object" } } +{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-listener" } "." } ; + ARTICLE: "irc.client" "IRC Client" "An IRC Client library" { $heading "IRC objects:" } @@ -42,6 +54,9 @@ ARTICLE: "irc.client" "IRC Client" { $subsection connect-irc } { $subsection terminate-irc } { $subsection add-listener } +{ $subsection remove-listener } +{ $subsection read-message } +{ $subsection write-message } { $heading "IRC messages" } "Some of the RFC defined irc messages as objects:" { $table @@ -78,11 +93,11 @@ ARTICLE: "irc.client" "IRC Client" "! Create a channel listener" "\"#mychannel123\" mychannel set" "! Register and start listener (this joins the channel)" - "bot get mychannel get add-listener" + "mychannel get bot get add-listener" "! Send a message to the channel" - "\"what's up?\" mychannel get out-messages>> mailbox-put" + "\"what's up?\" mychannel get write-message" "! Read a message from the channel" - "mychannel get in-messages>> mailbox-get" + "mychannel get read-message" } ; diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 45f2df3bdc..0a627cca1c 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -169,7 +169,8 @@ TUPLE: unhandled < irc-message ; { "KICK" [ \ kick ] } [ drop \ unhandled ] } case - [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ; + [ [ tuple-slots ] [ parameters>> ] bi append ] dip + [ all-slots length head ] keep slots>tuple ; ! ====================================== ! Server message handling @@ -205,6 +206,9 @@ M: join handle-incoming-irc ( join -- ) dup trailing>> listener> [ irc> join-messages>> ] unless* mailbox-put ; +M: part handle-incoming-irc ( part -- ) + dup channel>> to-listener ; + M: kick handle-incoming-irc ( kick -- ) [ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when to-listener ; @@ -221,6 +225,9 @@ GENERIC: handle-outgoing-irc ( obj -- ) M: privmsg handle-outgoing-irc ( privmsg -- ) [ name>> ] [ trailing>> ] bi /PRIVMSG ; +M: part handle-outgoing-irc ( privmsg -- ) + [ channel>> ] [ trailing>> "" or ] bi /PART ; + ! ====================================== ! Reader/Writer ! ====================================== @@ -300,6 +307,7 @@ DEFER: (connect-irc) 2bi ; GENERIC: (add-listener) ( irc-listener -- ) + M: irc-channel-listener (add-listener) ( irc-channel-listener -- ) [ [ name>> ] [ password>> ] bi /JOIN ] [ [ [ drop irc> join-messages>> ] @@ -314,19 +322,41 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- ) M: irc-server-listener (add-listener) ( irc-server-listener -- ) f swap set+run-listener ; +GENERIC: (remove-listener) ( irc-listener -- ) + +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>> unregister-listener ; + +M: irc-server-listener (remove-listener) ( irc-server-listener -- ) + drop f unregister-listener ; + : (connect-irc) ( irc-client -- ) [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep swap >>stream t >>is-running in-messages>> irc-connected swap mailbox-put ; +: with-irc-client ( irc-client quot -- ) + >r current-irc-client r> with-variable ; inline + PRIVATE> : connect-irc ( irc-client -- ) - dup current-irc-client [ + dup [ [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi spawn-irc - ] with-variable ; + ] with-irc-client ; : add-listener ( irc-listener irc-client -- ) - current-irc-client rot '[ , (add-listener) ] with-variable ; + swap '[ , (add-listener) ] with-irc-client ; + +: remove-listener ( irc-listener irc-client -- ) + swap '[ , (remove-listener) ] with-irc-client ; + +: write-message ( message irc-listener -- ) out-messages>> mailbox-put ; +: read-message ( irc-listener -- message ) in-messages>> mailbox-get ; From 4b0dc8747a57f4442a95fcba8bf38d8700bd8a77 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 9 Jul 2008 18:17:19 -0300 Subject: [PATCH 5/8] irc.client: Fix "part" messages --- extra/irc/client/client.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 0a627cca1c..5d80b0648f 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -52,7 +52,7 @@ 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 name channel ; +TUPLE: part < irc-message channel ; TUPLE: quit < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; From 4141399bebdd10ccf67b23ff8d2652de7c627a68 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 9 Jul 2008 22:48:17 -0300 Subject: [PATCH 6/8] irc.client: Move message tuples and parser to irc.messages, fix join handling --- extra/irc/client/client-docs.factor | 2 +- extra/irc/client/client.factor | 101 ++++++++-------------------- extra/irc/messages/authors.txt | 1 + extra/irc/messages/messages.factor | 69 +++++++++++++++++++ 4 files changed, 99 insertions(+), 74 deletions(-) create mode 100644 extra/irc/messages/authors.txt create mode 100644 extra/irc/messages/messages.factor diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index a675e663c3..6bb6a6328e 100644 --- a/extra/irc/client/client-docs.factor +++ b/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" diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 5d80b0648f..ffe78437a7 100644 --- a/extra/irc/client/client.factor +++ b/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 - 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 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 diff --git a/extra/irc/messages/authors.txt b/extra/irc/messages/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/messages/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor new file mode 100644 index 0000000000..f1beba9b26 --- /dev/null +++ b/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 ; + +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> From dda15b0d0617c9e251d4fec51fe163cef3eab408 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 9 Jul 2008 23:11:39 -0300 Subject: [PATCH 7/8] irc.client: Fix join message handling --- extra/irc/client/client.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index ffe78437a7..472805f5ae 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -155,7 +155,7 @@ M: privmsg handle-incoming-irc ( privmsg -- ) M: join handle-incoming-irc ( join -- ) [ [ prefix>> parse-name me? ] keep and [ irc> join-messages>> mailbox-put ] when* ] - [ dup channel>> to-listener ] + [ dup trailing>> to-listener ] bi ; M: part handle-incoming-irc ( part -- ) From 07c38a867df3177fa9abe96e16ec76ab04e69c82 Mon Sep 17 00:00:00 2001 From: "U-WSCHLIEP-PC\\wschliep" Date: Thu, 10 Jul 2008 02:38:48 -0400 Subject: [PATCH 8/8] Added extra/irc/ui and extra/ui/gadgets/tabs --- extra/irc/ui/authors.txt | 1 + extra/irc/ui/summary.txt | 1 + extra/irc/ui/ui.factor | 130 ++++++++++++++++++++++++++++++ extra/ui/gadgets/tabs/authors.txt | 1 + extra/ui/gadgets/tabs/summary.txt | 1 + extra/ui/gadgets/tabs/tabs.factor | 51 ++++++++++++ 6 files changed, 185 insertions(+) create mode 100755 extra/irc/ui/authors.txt create mode 100755 extra/irc/ui/summary.txt create mode 100755 extra/irc/ui/ui.factor create mode 100755 extra/ui/gadgets/tabs/authors.txt create mode 100755 extra/ui/gadgets/tabs/summary.txt create mode 100755 extra/ui/gadgets/tabs/tabs.factor diff --git a/extra/irc/ui/authors.txt b/extra/irc/ui/authors.txt new file mode 100755 index 0000000000..50c9c38812 --- /dev/null +++ b/extra/irc/ui/authors.txt @@ -0,0 +1 @@ +William Schlieper \ No newline at end of file diff --git a/extra/irc/ui/summary.txt b/extra/irc/ui/summary.txt new file mode 100755 index 0000000000..284672b951 --- /dev/null +++ b/extra/irc/ui/summary.txt @@ -0,0 +1 @@ +A simple IRC client \ No newline at end of file diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor new file mode 100755 index 0000000000..ef2bfd3d55 --- /dev/null +++ b/extra/irc/ui/ui.factor @@ -0,0 +1,130 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors kernel threads combinators concurrency.mailboxes + sequences strings hashtables splitting fry assocs hashtables + ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers + ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs + io io.styles namespaces irc.client irc.messages ; + +IN: irc.ui + +SYMBOL: client + +TUPLE: ui-window client tabs ; + +: write-color ( str color -- ) + foreground associate format ; +: red { 0.5 0 0 1 } ; +: green { 0 0.5 0 1 } ; +: blue { 0 0 1 1 } ; + +: prefix>nick ( prefix -- nick ) + "!" split first ; + +GENERIC: write-irc ( irc-message -- ) + +M: privmsg write-irc + "<" blue write-color + [ prefix>> prefix>nick write ] keep + ">" blue write-color + " " write + trailing>> write ; + +M: join write-irc + "* " green write-color + prefix>> prefix>nick write + " has entered the channel." green write-color ; + +M: part write-irc + "* " red write-color + [ prefix>> prefix>nick write ] keep + " has left the channel(" red write-color + trailing>> write + ")" red write-color ; + +M: quit write-irc + "* " red write-color + [ prefix>> prefix>nick write ] keep + " has left IRC(" red write-color + trailing>> write + ")" red write-color ; + +M: irc-end write-irc + drop "* You have left IRC" red write-color ; + +M: irc-disconnected write-irc + drop "* Disconnected" red write-color ; + +M: irc-connected write-irc + drop "* Connected" green write-color ; + +M: irc-message write-irc + drop ; ! catch all unimplemented writes, THIS WILL CHANGE + +: print-irc ( irc-message -- ) + write-irc nl ; + +: send-message ( message listener client -- ) + "<" blue write-color + profile>> nickname>> bold font-style associate format + ">" blue write-color + " " write + over write nl + out-messages>> mailbox-put ; + +: display ( stream listener -- ) + '[ , [ [ t ] + [ , read-message print-irc ] + [ ] while ] with-output-stream ] "ircv" spawn drop ; + +: ( listener -- pane ) + + [ swap display ] keep ; + +TUPLE: irc-editor outstream listener client ; + +: ( pane listener client -- editor ) + [ irc-editor construct-editor + swap >>listener swap >>outstream + ] dip client>> >>client ; + +: editor-send ( irc-editor -- ) + { [ outstream>> ] + [ editor-string ] + [ listener>> ] + [ client>> ] + [ "" swap set-editor-string ] } cleave + '[ , , , send-message ] with-output-stream ; + +irc-editor "general" f { + { T{ key-down f f "RET" } editor-send } + { T{ key-down f f "ENTER" } editor-send } +} define-command-map + +: irc-page ( name pane editor tabbed -- ) + [ [ @bottom frame, ! editor + @center frame, ! pane + ] make-frame swap ] dip add-page ; + +: join-channel ( name ui-window -- ) + [ dup ] dip + [ client>> add-listener ] + [ drop dup ] + [ [ ] keep ] 2tri + tabs>> irc-page ; + +: irc-window ( ui-window -- ) + [ tabs>> ] + [ client>> profile>> server>> ] bi + open-window ; + +: ui-connect ( profile -- ui-window ) + ui-window new over >>client swap + [ connect-irc ] + [ listeners>> +server-listener+ swap at + "Server" associate >>tabs ] bi ; + +: freenode-connect ( -- ui-window ) + "irc.freenode.org" 8001 "factor-irc" f + ui-connect [ irc-window ] keep ; diff --git a/extra/ui/gadgets/tabs/authors.txt b/extra/ui/gadgets/tabs/authors.txt new file mode 100755 index 0000000000..50c9c38812 --- /dev/null +++ b/extra/ui/gadgets/tabs/authors.txt @@ -0,0 +1 @@ +William Schlieper \ No newline at end of file diff --git a/extra/ui/gadgets/tabs/summary.txt b/extra/ui/gadgets/tabs/summary.txt new file mode 100755 index 0000000000..a55610bcc0 --- /dev/null +++ b/extra/ui/gadgets/tabs/summary.txt @@ -0,0 +1 @@ +Tabbed windows \ No newline at end of file diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor new file mode 100755 index 0000000000..113ea84443 --- /dev/null +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors kernel fry math math.vectors sequences arrays vectors assocs + hashtables models models.range models.compose combinators + ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs + ui.gadgets.incremental ui.gadgets.viewports ui.gadgets.books ; + +IN: ui.gadgets.tabs + +TUPLE: tabbed names model toggler content ; + +DEFER: (del-page) + +: add-toggle ( model n name toggler -- ) + [ [ gadget-parent '[ , , , (del-page) ] "X" swap + @right frame, ] 3keep + [ swapd @center frame, ] dip ] make-frame + swap add-gadget ; + +: redo-toggler ( tabbed -- ) + [ names>> ] [ model>> ] [ toggler>> ] tri + [ clear-gadget ] keep + [ [ length ] keep ] 2dip + '[ , _ _ , add-toggle ] 2each ; + +: (del-page) ( n name tabbed -- ) + { [ [ remove ] change-names redo-toggler ] + [ [ names>> length ] [ model>> ] bi + [ [ = ] keep swap [ 1- ] when + [ > ] keep swap [ 1- ] when dup ] change-model ] + [ content>> nth-gadget unparent ] + [ model>> [ ] change-model ] ! refresh + } cleave ; + +: add-page ( page name tabbed -- ) + [ names>> push ] 2keep + [ [ model>> swap ] + [ names>> length 1 - swap ] + [ toggler>> ] tri add-toggle ] + [ content>> add-gadget ] bi ; + +: del-page ( name tabbed -- ) + [ names>> index ] 2keep (del-page) ; + +: ( assoc -- tabbed ) + tabbed new + [ 1 >>fill g-> (>>toggler) @left frame, + [ keys >vector g (>>names) ] + [ values 0 [ g-> (>>content) @center frame, ] keep ] bi + g swap >>model redo-toggler ] build-frame ;