From 1c70bf833f105d4628c99f261290a92b7a9f592f Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 5 Mar 2009 23:11:46 -0200 Subject: [PATCH 01/21] irc: IRC messages reimplemented --- extra/irc/client/client-docs.factor | 8 +- extra/irc/client/client-tests.factor | 14 +- extra/irc/client/client.factor | 57 +++--- extra/irc/messages/base/authors.txt | 1 + extra/irc/messages/base/base.factor | 115 ++++++++++++ extra/irc/messages/base/summary.txt | 1 + extra/irc/messages/messages-tests.factor | 30 ++- extra/irc/messages/messages.factor | 230 ++++++----------------- extra/irc/messages/parser/authors.txt | 1 + extra/irc/messages/parser/parser.factor | 35 ++++ extra/irc/messages/parser/summary.txt | 1 + extra/irc/messages/summary.txt | 1 + 12 files changed, 262 insertions(+), 232 deletions(-) create mode 100644 extra/irc/messages/base/authors.txt create mode 100644 extra/irc/messages/base/base.factor create mode 100644 extra/irc/messages/base/summary.txt create mode 100644 extra/irc/messages/parser/authors.txt create mode 100644 extra/irc/messages/parser/parser.factor create mode 100644 extra/irc/messages/parser/summary.txt create mode 100644 extra/irc/messages/summary.txt diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 6d4fae9b83..d95d2bc2c6 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 irc.messages ; +USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ; IN: irc.client HELP: irc-client "IRC Client object" ; @@ -56,15 +56,15 @@ ARTICLE: "irc.client" "IRC Client" "Some of the RFC defined irc messages as objects:" { $table { { $link irc-message } "base of all irc messages" } - { { $link logged-in } "logged in to server" } + { { $link rpl-welcome } "logged in to server" } { { $link ping } "ping message" } { { $link join } "channel join" } { { $link part } "channel part" } { { $link quit } "quit from irc" } { { $link privmsg } "private message (to client or channel)" } { { $link kick } "kick from channel" } - { { $link roomlist } "list of participants in channel" } - { { $link nick-in-use } "chosen nick is in use by another client" } + { { $link rpl-names } "list of participants in channel" } + { { $link rpl-nickname-in-use } "chosen nick is in use by another client" } { { $link notice } "notice message" } { { $link mode } "mode change" } { { $link unhandled } "uninmplemented/unhandled message" } diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index c1cbdcf8b8..4f25531eee 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,7 +1,7 @@ USING: kernel tools.test accessors arrays sequences io io.streams.duplex namespaces threads destructors - calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes assocs combinators ; + calendar irc.client.private irc.client irc.messages + concurrency.mailboxes classes assocs combinators irc.messages.parser ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -49,13 +49,13 @@ M: mb-writer dispose drop ; { "factorbot" } [ irc> nick>> ] unit-test - { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test +! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line forward-name ] unit-test + string>irc-message forward-name ] unit-test { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - parse-irc-line forward-name ] unit-test + string>irc-message forward-name ] unit-test ] with-irc ! Test login and nickname set @@ -102,7 +102,7 @@ M: mb-writer dispose drop ; "#factortest" [ %add-named-chat ] keep ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line [ privmsg? ] read-matching-message - [ class ] [ name>> ] [ trailing>> ] tri + [ class ] [ target>> ] [ trailing>> ] tri ] unit-test ] with-irc @@ -110,7 +110,7 @@ M: mb-writer dispose drop ; "ircuser" [ %add-named-chat ] keep ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line [ privmsg? ] read-matching-message - [ class ] [ name>> ] [ trailing>> ] tri + [ class ] [ target>> ] [ trailing>> ] tri ] unit-test ] with-irc diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 97fa659209..7986a726ba 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -3,7 +3,7 @@ USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages ; + ascii irc.messages irc.messages.base irc.messages.parser call ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -74,12 +74,12 @@ SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established : terminate-irc ( irc-client -- ) - [ is-running>> ] keep and [ + dup is-running>> [ f >>is-running [ stream>> dispose ] keep [ in-messages>> ] [ out-messages>> ] bi 2array [ irc-end swap mailbox-put ] each - ] when* ; + ] [ drop ] if ; > mailbox-put ; : chats-with-participant ( nick -- seq ) irc> chats>> values - [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ] + [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] with filter ; : to-chats-with-participant ( message nickname -- ) @@ -165,11 +165,10 @@ M: irc-chat to-chat in-messages>> mailbox-put ; " hostname servername :irc.factor" irc-print ; : /CONNECT ( server port -- stream ) - irc> connect>> call drop ; inline + irc> connect>> call( host port -- stream local ) drop ; : /JOIN ( channel password -- ) - "JOIN " irc-write - [ [ " :" ] dip 3append ] when* irc-print ; + "JOIN " irc-write [ " :" swap 3append ] when* irc-print ; : /PONG ( text -- ) "PONG " irc-write irc-print ; @@ -187,7 +186,7 @@ M: join forward-name trailing>> ; M: part forward-name channel>> ; M: kick forward-name channel>> ; M: mode forward-name name>> ; -M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ; +M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ; UNION: single-forward join part kick mode privmsg ; UNION: multiple-forward nick quit ; @@ -200,48 +199,48 @@ M: irc-message forward-message M: single-forward forward-message dup forward-name to-chat ; M: multiple-forward forward-message - dup irc-message-sender to-chats-with-participant ; + dup sender>> to-chats-with-participant ; M: broadcast-forward forward-message irc> chats>> values [ to-chat ] with each ; GENERIC: process-message ( irc-message -- ) M: object process-message drop ; -M: logged-in process-message - name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri +M: rpl-welcome process-message + nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri values [ initialize-chat ] each ; M: ping process-message trailing>> /PONG ; -M: nick-in-use process-message name>> "_" append /NICK ; +M: rpl-nickname-in-use process-message name>> "_" append /NICK ; M: join process-message - [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri + [ drop +normal+ ] [ sender>> ] [ trailing>> ] tri dup chat> [ add-participant ] [ 3drop ] if ; M: part process-message - [ irc-message-sender ] [ channel>> ] bi remove-participant ; + [ sender>> ] [ channel>> ] bi remove-participant ; M: kick process-message - [ [ who>> ] [ channel>> ] bi remove-participant ] - [ dup who>> me? [ unregister-chat ] [ drop ] if ] + [ [ user>> ] [ channel>> ] bi remove-participant ] + [ dup user>> me? [ unregister-chat ] [ drop ] if ] bi ; M: quit process-message - irc-message-sender remove-participant-from-all ; + sender>> remove-participant-from-all ; M: nick process-message - [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; + [ sender>> ] [ trailing>> ] bi rename-participant-in-all ; M: mode process-message ( mode -- ) - [ channel-mode? ] keep and [ + dup channel-mode? [ [ name>> ] [ mode>> ] [ parameter>> ] tri [ change-participant-mode ] [ 2drop ] if* - ] when* ; + ] [ drop ] if ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; : names-reply>participants ( names-reply -- participants ) - trailing>> [ blank? ] trim " " split + nicks>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; : maybe-clean-participants ( channel-chat -- ) @@ -249,14 +248,14 @@ M: mode process-message ( mode -- ) H{ } clone >>participants f >>clean-participants ] when drop ; -M: names-reply process-message +M: rpl-names process-message [ names-reply>participants ] [ channel>> chat> ] bi [ [ maybe-clean-participants ] [ participants>> 2array assoc-combine ] [ (>>participants) ] tri ] [ drop ] if* ; -M: end-of-names process-message +M: rpl-names-end process-message channel>> chat> [ t >>clean-participants [ f f f ] dip name>> to-chat @@ -268,7 +267,7 @@ M: end-of-names process-message GENERIC: handle-outgoing-irc ( irc-message -- ? ) M: irc-end handle-outgoing-irc drop f ; -M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ; +M: irc-message handle-outgoing-irc irc-message>string irc-print t ; ! ====================================== ! Reader/Writer @@ -293,9 +292,9 @@ DEFER: (connect-irc) : (reader-loop) ( -- ? ) irc> stream>> [ |dispose stream-readln [ - parse-irc-line handle-reader-message t + string>irc-message handle-reader-message t ] [ - handle-disconnect + f handle-disconnect ] if* ] with-destructors ; @@ -314,7 +313,7 @@ DEFER: (connect-irc) [ forward-message ] [ process-message ] [ irc-end? not ] tri ; : strings>privmsg ( name string -- privmsg ) - privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; + privmsg new [ (>>trailing) ] keep [ (>>target) ] keep ; : maybe-annotate-with-name ( name obj -- obj ) { { [ dup string? ] [ strings>privmsg ] } @@ -325,7 +324,7 @@ DEFER: (connect-irc) GENERIC: annotate-message ( chat object -- object ) M: object annotate-message nip ; M: part annotate-message swap name>> >>channel ; -M: privmsg annotate-message swap name>> >>name ; +M: privmsg annotate-message swap name>> >>target ; M: string annotate-message [ name>> ] dip strings>privmsg ; : spawn-irc ( -- ) @@ -335,7 +334,7 @@ M: string annotate-message [ name>> ] dip strings>privmsg ; 3drop ; GENERIC: (attach-chat) ( irc-chat -- ) -USE: prettyprint + M: irc-chat (attach-chat) [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ] [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ] diff --git a/extra/irc/messages/base/authors.txt b/extra/irc/messages/base/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/messages/base/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor new file mode 100644 index 0000000000..7350ef9320 --- /dev/null +++ b/extra/irc/messages/base/base.factor @@ -0,0 +1,115 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.parser classes.tuple + combinators fry generic.parser kernel lexer + mirrors namespaces parser sequences splitting strings words ; +IN: irc.messages.base + +TUPLE: irc-message line prefix command parameters trailing timestamp sender ; +TUPLE: unhandled < irc-message ; + +SYMBOL: string-irc-type-mapping +string-irc-type-mapping [ H{ } clone ] initialize + +: register-irc-message-type ( type string -- ) + string-irc-type-mapping get set-at ; + +: irc>type ( string -- irc-message-class ) + string-irc-type-mapping get at unhandled or ; + +GENERIC: irc-trailing-slot ( irc-message -- string/f ) +M: irc-message irc-trailing-slot + drop f ; + +GENERIC: irc-parameter-slots ( irc-message -- seq ) +M: irc-message irc-parameter-slots + drop f ; + +GENERIC: process-irc-trailing ( irc-message -- ) +M: irc-message process-irc-trailing + dup irc-trailing-slot [ + swap [ trailing>> swap ] [ ] bi set-at + ] [ drop ] if* ; + +GENERIC: process-irc-prefix ( irc-message -- ) +M: irc-message process-irc-prefix + drop ; + + + +GENERIC: process-irc-parameters ( irc-message -- ) +M: irc-message process-irc-parameters + dup irc-parameter-slots [ + swap [ parameters>> swap ] [ [slot-setter] ] bi 2each + ] [ drop ] if* ; + +GENERIC: post-process-irc-message ( irc-message -- ) +M: irc-message post-process-irc-message drop ; + +GENERIC: fill-irc-message-slots ( irc-message -- ) +M: irc-message fill-irc-message-slots + { + [ process-irc-trailing ] + [ process-irc-prefix ] + [ process-irc-parameters ] + [ post-process-irc-message ] + } cleave ; + +GENERIC: irc-command-string ( irc-message -- string ) +M: irc-message irc-command-string drop f ; + +! FIXME: inverse of post-process is missing +GENERIC: set-irc-parameters ( irc-message -- ) +M: irc-message set-irc-parameters + dup irc-parameter-slots + [ over '[ _ at ] map >>parameters ] when* drop ; + +GENERIC: set-irc-trailing ( irc-message -- ) +M: irc-message set-irc-trailing + dup irc-trailing-slot [ over at >>trailing ] when* drop ; + +GENERIC: set-irc-command ( irc-message -- ) +M: irc-message set-irc-command + [ irc-command-string ] [ (>>command) ] bi ; + +: irc-message>string ( irc-message -- string ) + { + [ prefix>> ] + [ command>> ] + [ parameters>> " " join ] + [ trailing>> dup [ CHAR: : prefix ] when ] + } cleave 4array sift " " join ; + + + +#! SYNTAX: +#! IRC: type "COMMAND" slot1 ...; +#! IRC: type "COMMAND" slot1 ... : trailing-slot; +: IRC: ( name string parameters -- ) + CREATE-CLASS + [ scan-object register-irc-message-type ] keep + ";" parse-tokens + [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; parsing diff --git a/extra/irc/messages/base/summary.txt b/extra/irc/messages/base/summary.txt new file mode 100644 index 0000000000..1a05067707 --- /dev/null +++ b/extra/irc/messages/base/summary.txt @@ -0,0 +1 @@ +IRC messages base implementation diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index ac1d003b1b..abe94de8ef 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -1,19 +1,10 @@ USING: kernel tools.test accessors arrays - irc.messages irc.messages.private ; + irc.messages.parser irc.messages ; EXCLUDE: sequences => join ; IN: irc.messages.tests -{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test - -{ 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 +! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test { T{ privmsg { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" } @@ -21,9 +12,10 @@ IN: irc.messages.tests { command "PRIVMSG" } { parameters { "#factortest" } } { trailing "hi" } - { name "#factortest" } } } + { target "#factortest" } + { text "hi" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ join { line ":someuser!n=user@some.where JOIN :#factortest" } @@ -32,7 +24,7 @@ IN: irc.messages.tests { parameters { } } { trailing "#factortest" } } } [ ":someuser!n=user@some.where JOIN :#factortest" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ mode { line ":ircserver.net MODE #factortest +ns" } @@ -42,7 +34,7 @@ IN: irc.messages.tests { name "#factortest" } { mode "+ns" } } } [ ":ircserver.net MODE #factortest +ns" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ mode { line ":ircserver.net MODE #factortest +o someuser" } @@ -53,7 +45,7 @@ IN: irc.messages.tests { mode "+o" } { parameter "someuser" } } } [ ":ircserver.net MODE #factortest +o someuser" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test { T{ nick { line ":someuser!n=user@some.where NICK :someuser2" } @@ -62,9 +54,9 @@ IN: irc.messages.tests { parameters { } } { trailing "someuser2" } } } [ ":someuser!n=user@some.where NICK :someuser2" - parse-irc-line f >>timestamp ] unit-test + string>irc-message f >>timestamp ] unit-test -{ T{ nick-in-use +{ T{ rpl-nickname-in-use { line ":ircserver.net 433 * nickname :Nickname is already in use" } { prefix "ircserver.net" } { command "433" } @@ -72,4 +64,4 @@ IN: irc.messages.tests { name "nickname" } { trailing "Nickname is already in use" } } } [ ":ircserver.net 433 * nickname :Nickname is already in use" - parse-irc-line f >>timestamp ] unit-test \ No newline at end of file + string>irc-message 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 c88bbc072a..e0f9a15eff 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,179 +1,63 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators - arrays classes.tuple math.order ; -RENAME: join sequences => sjoin + arrays classes.tuple math.order words assocs strings + irc.messages.base ; 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 ; -TUPLE: part < irc-message channel ; -TUPLE: quit < irc-message ; -TUPLE: nick < 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 name ; -TUPLE: notice < irc-message type ; -TUPLE: mode < irc-message name mode parameter ; -TUPLE: names-reply < irc-message who channel ; -TUPLE: end-of-names < irc-message who channel ; -TUPLE: unhandled < irc-message ; - -: ( command parameters trailing -- irc-message ) - irc-message new - now >>timestamp - swap >>trailing - swap >>parameters - swap >>command ; - -> ( 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 command-parameters>> ( mode -- seq ) - [ name>> ] [ channel>> ] [ mode>> ] tri 3array ; - -GENERIC# >>command-parameters 1 ( irc-message params -- irc-message ) - -M: irc-message >>command-parameters ( irc-message params -- irc-message ) - drop ; - -M: logged-in >>command-parameters ( part params -- part ) - first >>name ; - -M: privmsg >>command-parameters ( privmsg params -- privmsg ) - first >>name ; - -M: notice >>command-parameters ( notice params -- notice ) - first >>type ; - -M: part >>command-parameters ( part params -- part ) - first >>channel ; - -M: kick >>command-parameters ( kick params -- kick ) - first2 [ >>channel ] [ >>who ] bi* ; - -M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use ) - second >>name ; - -M: names-reply >>command-parameters ( names-reply params -- names-reply ) - first3 nip [ >>who ] [ >>channel ] bi* ; - -M: end-of-names >>command-parameters ( names-reply params -- names-reply ) - first2 [ >>who ] [ >>channel ] bi* ; - -M: mode >>command-parameters ( mode params -- mode ) - dup length { - { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] } - { 2 [ first2 [ >>name ] [ >>mode ] bi* ] } - [ drop first >>name dup trailing>> >>mode ] - } case ; - -PRIVATE> - -GENERIC: irc-message>client-line ( irc-message -- string ) - -M: irc-message irc-message>client-line ( irc-message -- string ) - [ command-string>> ] - [ command-parameters>> " " sjoin ] - [ trailing>> [ CHAR: : prefix ] [ "" ] if* ] - 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" ; - -> >>line ] - [ prefix>> >>prefix ] - [ command>> >>command ] - [ trailing>> >>trailing ] - [ timestamp>> >>timestamp ] - [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ] - } cleave ; - -PRIVATE> - -UNION: sender-in-prefix privmsg join part quit kick mode nick ; -GENERIC: irc-message-sender ( irc-message -- sender ) -M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) - prefix>> parse-name ; - -: string>irc-message ( string -- object ) - dup split-prefix split-trailing - [ [ blank? ] trim " " split unclip swap ] dip - now irc-message boa ; - -: irc-message>command ( irc-message -- command ) - [ - command>> { - { "PING" [ ping ] } - { "NOTICE" [ notice ] } - { "001" [ logged-in ] } - { "433" [ nick-in-use ] } - { "353" [ names-reply ] } - { "366" [ end-of-names ] } - { "JOIN" [ join ] } - { "PART" [ part ] } - { "NICK" [ nick ] } - { "PRIVMSG" [ privmsg ] } - { "QUIT" [ quit ] } - { "MODE" [ mode ] } - { "KICK" [ kick ] } - [ drop unhandled ] - } case new - ] keep copy-message-in ; - -: parse-irc-line ( string -- message ) - string>irc-message irc-message>command ; +! connection +IRC: pass "PASS" password ; +IRC: nick "NICK" nickname ; +IRC: user "USER" user mode _ : realname ; +IRC: oper "OPER" name password ; +IRC: mode "MODE" name mode parameter ; +IRC: service "SERVICE" nickname _ distribution type _ : info ; +IRC: quit "QUIT" : comment ; +IRC: squit "SQUIT" server : comment ; +! channel operations +IRC: join "JOIN" channel ; +IRC: part "PART" channel : comment ; +IRC: topic "TOPIC" channel : topic ; +IRC: names "NAMES" channel ; +IRC: list "LIST" channel ; +IRC: invite "INVITE" nickname channel ; +IRC: kick "KICK" channel user : comment ; +! chating +IRC: privmsg "PRIVMSG" target : text ; +IRC: notice "NOTICE" target : text ; +! server queries +IRC: motd "MOTD" target ; +IRC: lusers "LUSERS" mask target ; +IRC: version "VERSION" target ; +IRC: stats "STATS" query target ; +IRC: links "LINKS" server mask ; +IRC: time "TIME" target ; +IRC: connect "CONNECT" server port remote-server ; +IRC: trace "TRACE" target ; +IRC: admin "ADMIN" target ; +IRC: info "INFO" target ; +! service queries +IRC: servlist "SERVLIST" mask type ; +IRC: squery "SQUERY" service-name : text ; +! user queries +IRC: who "WHO" mask operator ; +IRC: whois "WHOIS" target mask ; +IRC: whowas "WHOWAS" nickname count target ; +! misc +IRC: kill "KILL" nickname : comment ; +IRC: ping "PING" server1 server2 ; +IRC: pong "PONG" server1 server2 ; +IRC: error "ERROR" : message ; +! numeric replies +IRC: rpl-welcome "001" nickname : comment ; +IRC: rpl-whois-user "311" nicnamek user host _ : real-name ; +IRC: rpl-channel-modes "324" channel mode params ; +IRC: rpl-notopic "331" channel : topic ; +IRC: rpl-topic "332" channel : topic ; +IRC: rpl-inviting "341" channel nickname ; +IRC: rpl-names "353" nickname _ channel : nicks ; +IRC: rpl-names-end "366" nickname channel : comment ; +! error replies +IRC: rpl-nickname-in-use "433" _ name ; +IRC: rpl-nick-collision "436" nickname : comment ; diff --git a/extra/irc/messages/parser/authors.txt b/extra/irc/messages/parser/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/messages/parser/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor new file mode 100644 index 0000000000..1fa07fc772 --- /dev/null +++ b/extra/irc/messages/parser/parser.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: kernel fry splitting ascii calendar accessors combinators + arrays classes.tuple math.order words assocs + irc.messages.base sequences ; +IN: irc.messages.parser + +> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ; +PRIVATE> + +: string>irc-message ( string -- irc-message ) + dup split-message + [ [ irc>type new ] [ >>command ] bi ] + [ >>parameters ] + [ >>trailing ] + tri* + [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri + now >>timestamp dup sender >>sender ; diff --git a/extra/irc/messages/parser/summary.txt b/extra/irc/messages/parser/summary.txt new file mode 100644 index 0000000000..7ec732aae1 --- /dev/null +++ b/extra/irc/messages/parser/summary.txt @@ -0,0 +1 @@ +Basic parser for irc messages diff --git a/extra/irc/messages/summary.txt b/extra/irc/messages/summary.txt new file mode 100644 index 0000000000..cf3a8ae07a --- /dev/null +++ b/extra/irc/messages/summary.txt @@ -0,0 +1 @@ +IRC message definitions From 5bfe50018e0d918944bc05c7b2dea4cc2c59e741 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 16:14:49 -0200 Subject: [PATCH 02/21] irc.messages: Update tests --- extra/irc/messages/messages-tests.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index abe94de8ef..d88eeabc73 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -13,7 +13,8 @@ IN: irc.messages.tests { parameters { "#factortest" } } { trailing "hi" } { target "#factortest" } - { text "hi" } } } + { text "hi" } + { sender "someuser" } } } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" string>irc-message f >>timestamp ] unit-test @@ -22,7 +23,8 @@ IN: irc.messages.tests { prefix "someuser!n=user@some.where" } { command "JOIN" } { parameters { } } - { trailing "#factortest" } } } + { trailing "#factortest" } + { sender "someuser" } } } [ ":someuser!n=user@some.where JOIN :#factortest" string>irc-message f >>timestamp ] unit-test @@ -52,7 +54,8 @@ IN: irc.messages.tests { prefix "someuser!n=user@some.where" } { command "NICK" } { parameters { } } - { trailing "someuser2" } } } + { trailing "someuser2" } + { sender "someuser" } } } [ ":someuser!n=user@some.where NICK :someuser2" string>irc-message f >>timestamp ] unit-test From 527b50fa5691601997284c2b9d082e0e4d43b01b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 20:43:25 -0200 Subject: [PATCH 03/21] irc.client: Fix strings>privmsg, add test --- extra/irc/client/client-tests.factor | 5 +++++ extra/irc/client/client.factor | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 4f25531eee..07b9df2ab7 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -58,6 +58,11 @@ M: mb-writer dispose drop ; string>irc-message forward-name ] unit-test ] with-irc +{ privmsg "#channel" "hello" } [ + "#channel" "hello" strings>privmsg + [ class ] [ target>> ] [ trailing>> ] tri +] unit-test + ! Test login and nickname set [ { "factorbot2" } [ ":some.where 001 factorbot2 :Welcome factorbot2" %push-line diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 7986a726ba..c7e90eb802 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -313,7 +313,7 @@ DEFER: (connect-irc) [ forward-message ] [ process-message ] [ irc-end? not ] tri ; : strings>privmsg ( name string -- privmsg ) - privmsg new [ (>>trailing) ] keep [ (>>target) ] keep ; + " :" prepend append "PRIVMSG " prepend string>irc-message ; : maybe-annotate-with-name ( name obj -- obj ) { { [ dup string? ] [ strings>privmsg ] } From f3577572ec75ccd4703881233663f505edbf84ad Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 7 Mar 2009 20:54:28 -0200 Subject: [PATCH 04/21] irc.client: add test --- extra/irc/client/client-tests.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 07b9df2ab7..9e96cc249b 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -34,6 +34,7 @@ M: mb-writer dispose drop ; : %add-named-chat ( chat -- ) irc> attach-chat ; : %push-line ( line -- ) irc> stream>> in>> push-line yield ; : %join ( channel -- ) irc> attach-chat ; +: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; @@ -79,8 +80,7 @@ M: mb-writer dispose drop ; ! Test join [ { "JOIN #factortest" } [ - "#factortest" %join - irc> stream>> out>> lines>> pop + "#factortest" %join %pop-output-line ] unit-test ] with-irc @@ -221,3 +221,10 @@ M: mb-writer dispose drop ; [ participant-changed? ] read-matching-message ] unit-test ] with-irc + +! Send privmsg +[ { "PRIVMSG #factortest :hello" } [ + "#factortest" [ %add-named-chat ] keep + "hello" swap speak %pop-output-line + ] unit-test +] with-irc From 93a3c18c59b99ec86be5f5d52e9e853eaed4e6eb Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 20 Mar 2009 10:15:13 -0300 Subject: [PATCH 05/21] irc.client: Make to-chat work with sequences --- extra/irc/client/client.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index c7e90eb802..ee46cd954a 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -104,6 +104,7 @@ M: string to-chat [ to-chat ] [ drop ] if* ; M: irc-chat to-chat in-messages>> mailbox-put ; +M: sequence to-chat [ to-chat ] with each ; : unregister-chat ( name -- ) irc> chats>> @@ -123,9 +124,6 @@ M: irc-chat to-chat in-messages>> mailbox-put ; [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] with filter ; -: to-chats-with-participant ( message nickname -- ) - chats-with-participant [ to-chat ] with each ; - : remove-participant-from-all ( nick -- ) dup chats-with-participant [ (remove-participant) ] with each ; @@ -199,7 +197,7 @@ M: irc-message forward-message M: single-forward forward-message dup forward-name to-chat ; M: multiple-forward forward-message - dup sender>> to-chats-with-participant ; + dup sender>> chats-with-participant to-chat ; M: broadcast-forward forward-message irc> chats>> values [ to-chat ] with each ; From 4cc3dfb3c5e8662708937cd9f01b411946aff72b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sat, 21 Mar 2009 19:45:18 -0300 Subject: [PATCH 06/21] irc.client: Fix, don't try to USE 'call' --- 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 ee46cd954a..f2d671e30d 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -3,7 +3,7 @@ USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.base irc.messages.parser call ; + ascii irc.messages irc.messages.base irc.messages.parser ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client From 4d722001e9a4e2c2010731b91bc6577f91bd4841 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Wed, 8 Apr 2009 23:26:58 -0300 Subject: [PATCH 07/21] irc.messages: use SYNTAX: instead of parsing --- extra/irc/messages/base/base.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor index 7350ef9320..d67d226d9b 100644 --- a/extra/irc/messages/base/base.factor +++ b/extra/irc/messages/base/base.factor @@ -108,8 +108,8 @@ PRIVATE> #! SYNTAX: #! IRC: type "COMMAND" slot1 ...; #! IRC: type "COMMAND" slot1 ... : trailing-slot; -: IRC: ( name string parameters -- ) +SYNTAX: IRC: ( name string parameters -- ) CREATE-CLASS [ scan-object register-irc-message-type ] keep ";" parse-tokens - [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; parsing + [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ; From 0fda643ab1e35c43a9b94b67f0138e9499c3f72e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 11 Apr 2009 20:30:51 -0500 Subject: [PATCH 08/21] Optimizing string>number --- basis/hints/hints.factor | 4 +- .../transforms/transforms.factor | 86 ++++++++++++------- core/math/parser/parser-tests.factor | 10 +-- core/math/parser/parser.factor | 74 ++++++++-------- 4 files changed, 103 insertions(+), 71 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 2534e0121f..d44bf92bf4 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -3,7 +3,7 @@ USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs byte-arrays byte-vectors io.binary io.streams.string splitting -math generic generic.standard generic.standard.engines classes +math math.parser generic generic.standard generic.standard.engines classes hashtables ; IN: hints @@ -118,6 +118,8 @@ SYNTAX: HINTS: \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop +\ base> { string fixnum } "specializer" set-word-prop + M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index c2b348f5f1..dfa46be7e2 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel kernel.private combinators.private -words sequences generic math math.order namespaces make quotations assocs -combinators combinators.short-circuit classes.tuple +words sequences generic math math.order namespaces make quotations +assocs combinators combinators.short-circuit classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations locals -generalizations stack-checker.backend stack-checker.state -stack-checker.visitor stack-checker.errors stack-checker.values -stack-checker.recursive-state ; +sequences.private generalizations stack-checker.backend +stack-checker.state stack-checker.visitor stack-checker.errors +stack-checker.values stack-checker.recursive-state ; IN: stack-checker.transforms : give-up-transform ( word -- ) @@ -106,40 +106,68 @@ IN: stack-checker.transforms ] [ drop f ] if ] 1 define-transform -! Membership testing -CONSTANT: bit-member-max 256 +! Fast at for integer maps +CONSTANT: lookup-table-at-max 256 -: bit-member? ( seq -- ? ) +: lookup-table-at? ( assoc -- ? ) #! Can we use a fast byte array test here? { - [ length 4 > ] - [ [ integer? ] all? ] - [ [ 0 bit-member-max between? ] any? ] + [ assoc-size 4 > ] + [ values [ ] all? ] + [ keys [ integer? ] all? ] + [ keys [ 0 lookup-table-at-max between? ] all? ] } 1&& ; -: bit-member-seq ( seq -- flags ) - [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ; +: lookup-table-seq ( assoc -- table ) + [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; -: bit-member-quot ( seq -- newquot ) - bit-member-seq +: lookup-table-quot ( seq -- newquot ) + lookup-table-seq '[ - _ { - { [ over fixnum? ] [ ?nth 1 eq? ] } - { [ over bignum? ] [ ?nth 1 eq? ] } - [ 2drop f ] - } cond + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup >boolean + ] [ 2drop f f ] if + ] [ 2drop f f ] if ] ; -: member-quot ( seq -- newquot ) - dup bit-member? [ - bit-member-quot - ] [ - dup length 4 <= [ - [ drop f ] swap - [ literalize [ t ] ] { } map>assoc linear-case-quot +: fast-lookup-table-at? ( assoc -- ? ) + values { + [ [ integer? ] all? ] + [ [ 0 254 between? ] all? ] + } 1&& ; + +: fast-lookup-table-seq ( assoc -- table ) + lookup-table-seq [ 255 or ] B{ } map-as ; + +: fast-lookup-table-quot ( seq -- newquot ) + fast-lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup 255 eq? [ drop f f ] [ t ] if + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: at-quot ( assoc -- quot ) + dup lookup-table-at? [ + dup fast-lookup-table-at? [ + fast-lookup-table-quot ] [ - unique [ key? ] curry + lookup-table-quot ] if + ] [ drop f ] if ; + +\ at* [ at-quot ] 1 define-transform + +! Membership testing +: member-quot ( seq -- newquot ) + dup length 4 <= [ + [ drop f ] swap + [ literalize [ t ] ] { } map>assoc linear-case-quot + ] [ + unique [ key? ] curry ] if ; \ member? [ @@ -170,4 +198,4 @@ CONSTANT: bit-member-max 256 \ shuffle [ shuffle-mapping nths-quot -] 1 define-transform \ No newline at end of file +] 1 define-transform diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 0fb2559854..c655965e35 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -95,17 +95,17 @@ unit-test [ 1 0 >base ] must-fail [ 1 -1 >base ] must-fail -[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test +[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test -[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test +[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test -[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test +[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test [ t ] [ "0/0." string>number fp-nan? ] unit-test -[ 1.0/0.0 ] [ "1/0." string>number ] unit-test +[ 1/0. ] [ "1/0." string>number ] unit-test -[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test +[ -1/0. ] [ "-1/0." string>number ] unit-test [ "-0.0" ] [ -0.0 number>string ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 0d8f0c0b08..0a637c2eab 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.private namespaces sequences strings -arrays combinators splitting math assocs make ; +USING: kernel math.private namespaces sequences sequences.private +strings arrays combinators splitting math assocs make ; IN: math.parser : digit> ( ch -- n ) @@ -28,13 +28,19 @@ IN: math.parser { CHAR: d 13 } { CHAR: e 14 } { CHAR: f 15 } - } at ; + } at 255 or ; inline : string>digits ( str -- digits ) - [ digit> ] { } map-as ; + [ digit> ] B{ } map-as ; inline -: digits>integer ( seq radix -- n ) - 0 swap [ swapd * + ] curry reduce ; +: (digits>integer) ( valid? accum digit radix -- valid? accum ) + 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline + +: each-digit ( seq radix quot -- n/f ) + [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline + +: digits>integer ( seq radix -- n/f ) + [ (digits>integer) ] each-digit ; inline DEFER: base> @@ -43,6 +49,9 @@ DEFER: base> SYMBOL: radix SYMBOL: negative? +: string>natural ( seq radix -- n/f ) + [ [ digit> ] dip (digits>integer) ] each-digit ; inline + : sign ( -- str ) negative? get "-" "+" ? ; : with-radix ( radix quot -- ) @@ -54,37 +63,30 @@ SYMBOL: negative? sign split1 [ (base>) ] dip dup [ (base>) ] [ drop 0 swap ] if ; -: string>ratio ( str -- a/b ) - "-" ?head dup negative? set swap - "/" split1 (base>) [ whole-part ] dip - 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ; +: string>ratio ( str radix -- a/b ) + [ + "-" ?head dup negative? set swap + "/" split1 (base>) [ whole-part ] dip + 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if + ] with-radix ; -: valid-digits? ( seq -- ? ) - { - { [ dup empty? ] [ drop f ] } - { [ f over memq? ] [ drop f ] } - [ radix get [ < ] curry all? ] - } cond ; - -: string>integer ( str -- n/f ) - "-" ?head swap - string>digits dup valid-digits? - [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ; +: string>integer ( str radix -- n/f ) + over first-unsafe CHAR: - = [ + [ rest-slice ] dip string>natural dup [ neg ] when + ] [ + string>natural + ] if ; inline PRIVATE> : base> ( str radix -- n/f ) - [ - CHAR: / over member? [ - string>ratio - ] [ - CHAR: . over member? [ - string>float - ] [ - string>integer - ] if - ] if - ] with-radix ; + over empty? [ 2drop f ] [ + over [ "/." member? ] find nip { + { CHAR: / [ string>ratio ] } + { CHAR: . [ drop string>float ] } + [ drop string>integer ] + } case + ] if ; : string>number ( str -- n/f ) 10 base> ; : bin> ( str -- n/f ) 2 base> ; @@ -147,9 +149,9 @@ M: ratio >base M: float >base drop { - { [ dup fp-nan? ] [ drop "0.0/0.0" ] } - { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] } - { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] } + { [ dup fp-nan? ] [ drop "0/0." ] } + { [ dup 1/0. = ] [ drop "1/0." ] } + { [ dup -1/0. = ] [ drop "-1/0." ] } { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] } [ float>string fix-float ] } cond ; From 85d595d8b68635cf8ba884847db92aab6a444a21 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Thu, 9 Apr 2009 00:04:42 -0300 Subject: [PATCH 09/21] irc.client: Big refactor --- extra/irc/client/base/base.factor | 37 ++ extra/irc/client/chats/chats-docs.factor | 20 + extra/irc/client/chats/chats.factor | 50 +++ extra/irc/client/client-docs.factor | 18 +- extra/irc/client/client.factor | 381 +----------------- .../internals-tests.factor} | 147 +++---- extra/irc/client/internals/internals.factor | 162 ++++++++ .../client/participants/participants.factor | 55 +++ extra/irc/messages/messages.factor | 11 +- 9 files changed, 410 insertions(+), 471 deletions(-) create mode 100644 extra/irc/client/base/base.factor create mode 100644 extra/irc/client/chats/chats-docs.factor create mode 100644 extra/irc/client/chats/chats.factor rename extra/irc/client/{client-tests.factor => internals/internals-tests.factor} (57%) create mode 100644 extra/irc/client/internals/internals.factor create mode 100644 extra/irc/client/participants/participants.factor diff --git a/extra/irc/client/base/base.factor b/extra/irc/client/base/base.factor new file mode 100644 index 0000000000..f54e18ac4b --- /dev/null +++ b/extra/irc/client/base/base.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs concurrency.mailboxes io kernel namespaces +strings words.symbol irc.client.chats irc.messages ; +EXCLUDE: sequences => join ; +IN: irc.client.base + +SYMBOL: current-irc-client + +: irc> ( -- irc-client ) current-irc-client get ; +: stream> ( -- stream ) irc> stream>> ; +: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ; +: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; +: chats> ( -- seq ) irc> chats>> values ; +: me? ( string -- ? ) irc> nick>> = ; + +: with-irc ( irc-client quot: ( -- ) -- ) + \ current-irc-client swap with-variable ; inline + +UNION: to-target privmsg notice ; +UNION: to-channel join part topic kick rpl-channel-modes + rpl-notopic rpl-topic rpl-names rpl-names-end ; +UNION: to-one-chat to-target to-channel mode ; +UNION: to-many-chats nick quit ; +UNION: to-all-chats irc-end irc-disconnected irc-connected ; +PREDICATE: to-me < to-target target>> me? ; + +GENERIC: chat-name ( irc-message -- name ) +M: mode chat-name name>> ; +M: to-target chat-name target>> ; +M: to-me chat-name sender>> ; +M: to-channel chat-name channel>> ; + +GENERIC: chat> ( obj -- chat/f ) +M: string chat> irc> chats>> at ; +M: symbol chat> irc> chats>> at ; +M: to-one-chat chat> chat-name +server-chat+ or chat> ; diff --git a/extra/irc/client/chats/chats-docs.factor b/extra/irc/client/chats/chats-docs.factor new file mode 100644 index 0000000000..66fd1a207d --- /dev/null +++ b/extra/irc/client/chats/chats-docs.factor @@ -0,0 +1,20 @@ +USING: help.markup help.syntax quotations kernel ; +IN: irc.client.chats + +HELP: irc-client "IRC Client object" ; + +HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ; + +HELP: irc-channel-chat "Chat for irc channels" ; + +HELP: irc-nick-chat "Chat for irc users" ; + +HELP: irc-profile "IRC Client profile object" ; + +HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ; + +HELP: irc-end "Message sent when the client isn't running anymore, a chat should stop after it receives this message." ; + +HELP: irc-disconnected "Message sent to notify chats that connection was lost." ; + +HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ; diff --git a/extra/irc/client/chats/chats.factor b/extra/irc/client/chats/chats.factor new file mode 100644 index 0000000000..7910afb22a --- /dev/null +++ b/extra/irc/client/chats/chats.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit +destructors arrays sequences ; +IN: irc.client.chats + +CONSTANT: irc-port 6667 ! Default irc port + +TUPLE: irc-chat in-messages client ; +TUPLE: irc-server-chat < irc-chat ; +TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ; +TUPLE: irc-nick-chat < irc-chat name ; +SYMBOL: +server-chat+ + +: ( -- irc-server-chat ) + irc-server-chat new + >>in-messages ; + +: ( name -- irc-channel-chat ) + irc-channel-chat new + swap >>name + >>in-messages + f >>password + H{ } clone >>participants + t >>clear-participants ; + +: ( name -- irc-nick-chat ) + irc-nick-chat new + swap >>name + >>in-messages ; + +TUPLE: irc-profile server port nickname password ; +C: irc-profile + +TUPLE: irc-client profile stream in-messages out-messages + chats is-running nick connect reconnect-time is-ready + exceptions ; + +: ( profile -- irc-client ) + dup nickname>> irc-client new + swap >>nick + swap >>profile + >>in-messages + >>out-messages + H{ } clone >>chats + 15 seconds >>reconnect-time + V{ } clone >>exceptions + [ latin1 ] >>connect ; + +SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ; diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index d95d2bc2c6..ad674cb0c1 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -1,16 +1,7 @@ -USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser ; +USING: help.markup help.syntax quotations kernel +irc.messages irc.messages.base irc.messages.parser irc.client.chats ; IN: irc.client -HELP: irc-client "IRC Client object" ; - -HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ; - -HELP: irc-channel-chat "Chat for irc channels" ; - -HELP: irc-nick-chat "Chat for irc users" ; - -HELP: irc-profile "IRC Client profile object" ; - HELP: connect-irc "Connecting to an irc server" { $values { "irc-client" "an irc client object" } } { $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ; @@ -69,6 +60,7 @@ ARTICLE: "irc.client" "IRC Client" { { $link mode } "mode change" } { { $link unhandled } "uninmplemented/unhandled message" } } + { $heading "Special messages" } "Some special messages that are created by the library and not by the irc server." { $table @@ -79,7 +71,7 @@ ARTICLE: "irc.client" "IRC Client" { $heading "Example:" } { $code - "USING: irc.client ;" + "USING: irc.client irc.client.chats ;" "SYMBOL: bot" "SYMBOL: mychannel" "! Create the profile and client objects" @@ -91,7 +83,7 @@ ARTICLE: "irc.client" "IRC Client" "! Register and start chat (this joins the channel)" "mychannel get bot get attach-chat" "! Send a message to the channel" - "\"what's up?\" mychannel get speak" + "\"Hello World!\" mychannel get speak" "! Read a message from the channel" "mychannel get hear" } diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index f2d671e30d..ae48d3ac4e 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -1,380 +1,15 @@ ! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov. ! 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 fry - continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.base irc.messages.parser ; -RENAME: join sequences => sjoin -EXCLUDE: sequences => join ; +USING: accessors concurrency.mailboxes destructors +irc.client.base irc.client.chats irc.client.internals kernel +namespaces sequences ; IN: irc.client -! ====================================== -! Setup and running objects -! ====================================== - -CONSTANT: irc-port 6667 ! Default irc port - -TUPLE: irc-profile server port nickname password ; -C: irc-profile - -TUPLE: irc-client profile stream in-messages out-messages - chats is-running nick connect reconnect-time is-ready ; - -: ( profile -- irc-client ) - irc-client new - swap >>profile - >>in-messages - >>out-messages - H{ } clone >>chats - dup profile>> nickname>> >>nick - [ latin1 ] >>connect - 15 seconds >>reconnect-time ; - -TUPLE: irc-chat in-messages client ; -TUPLE: irc-server-chat < irc-chat ; -TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ; -TUPLE: irc-nick-chat < irc-chat name ; -SYMBOL: +server-chat+ - -! participant modes -SYMBOL: +operator+ -SYMBOL: +voice+ -SYMBOL: +normal+ - -: participant-mode ( n -- mode ) - H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; - -! participant changed actions -SYMBOL: +join+ -SYMBOL: +part+ -SYMBOL: +mode+ -SYMBOL: +nick+ - -! chat objects -: ( -- irc-server-chat ) - f irc-server-chat boa ; - -: ( name -- irc-channel-chat ) - [ f ] dip f 60 seconds H{ } clone t - irc-channel-chat boa ; - -: ( name -- irc-nick-chat ) - [ f ] dip irc-nick-chat boa ; - -! ====================================== -! Message objects -! ====================================== - -TUPLE: participant-changed nick action parameter ; -C: participant-changed - -SINGLETON: irc-chat-end ! sent to a chat to stop its execution -SINGLETON: irc-end ! sent when the client isn't running anymore -SINGLETON: irc-disconnected ! sent when connection is lost -SINGLETON: irc-connected ! sent when connection is established - -: terminate-irc ( irc-client -- ) - dup is-running>> [ - f >>is-running - [ stream>> dispose ] keep - [ in-messages>> ] [ out-messages>> ] bi 2array - [ irc-end swap mailbox-put ] each - ] [ drop ] if ; - - ( -- irc-client ) current-irc-client get ; -: irc-write ( s -- ) irc> stream>> stream-write ; -: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ; -: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; -: chat> ( name -- chat/f ) irc> chats>> at ; -: channel-mode? ( mode -- ? ) name>> first "#&" member? ; -: me? ( string -- ? ) irc> nick>> = ; - -GENERIC: to-chat ( message obj -- ) - -M: string to-chat - chat> [ +server-chat+ chat> ] unless* - [ to-chat ] [ drop ] if* ; - -M: irc-chat to-chat in-messages>> mailbox-put ; -M: sequence to-chat [ to-chat ] with each ; - -: unregister-chat ( name -- ) - irc> chats>> - [ at [ irc-chat-end ] dip to-chat ] - [ delete-at ] - 2bi ; - -: (remove-participant) ( nick chat -- ) - [ participants>> delete-at ] - [ [ +part+ f ] dip to-chat ] 2bi ; - -: remove-participant ( nick channel -- ) - chat> [ (remove-participant) ] [ drop ] if* ; - -: chats-with-participant ( nick -- seq ) - irc> chats>> values - [ dup irc-channel-chat? [ participants>> key? ] [ 2drop f ] if ] - with filter ; - -: remove-participant-from-all ( nick -- ) - dup chats-with-participant [ (remove-participant) ] with each ; - -: notify-rename ( newnick oldnick chat -- ) - [ participant-changed new +nick+ >>action - [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ; - -: rename-participant ( newnick oldnick chat -- ) - [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ] - [ notify-rename ] 3bi ; - -: rename-participant-in-all ( oldnick newnick -- ) - swap dup chats-with-participant [ rename-participant ] with with each ; - -: add-participant ( mode nick channel -- ) - chat> - [ participants>> set-at ] - [ [ +join+ f ] dip to-chat ] 2bi ; - -: change-participant-mode ( channel mode nick -- ) - rot chat> - [ participants>> set-at ] - [ [ participant-changed new - [ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ] - 3bi ; ! FIXME - -! ====================================== -! IRC client messages -! ====================================== - -: /NICK ( nick -- ) - "NICK " irc-write irc-print ; - -: /LOGIN ( nick -- ) - dup /NICK - "USER " irc-write irc-write - " hostname servername :irc.factor" irc-print ; - -: /CONNECT ( server port -- stream ) - irc> connect>> call( host port -- stream local ) drop ; - -: /JOIN ( channel password -- ) - "JOIN " irc-write [ " :" swap 3append ] when* irc-print ; - -: /PONG ( text -- ) - "PONG " irc-write irc-print ; - -! ====================================== -! Server message handling -! ====================================== - -GENERIC: initialize-chat ( chat -- ) -M: irc-chat initialize-chat drop ; -M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ; - -GENERIC: forward-name ( irc-message -- name ) -M: join forward-name trailing>> ; -M: part forward-name channel>> ; -M: kick forward-name channel>> ; -M: mode forward-name name>> ; -M: privmsg forward-name dup target>> me? [ sender>> ] [ target>> ] if ; - -UNION: single-forward join part kick mode privmsg ; -UNION: multiple-forward nick quit ; -UNION: broadcast-forward irc-end irc-disconnected irc-connected ; -GENERIC: forward-message ( irc-message -- ) - -M: irc-message forward-message - +server-chat+ chat> [ to-chat ] [ drop ] if* ; - -M: single-forward forward-message dup forward-name to-chat ; - -M: multiple-forward forward-message - dup sender>> chats-with-participant to-chat ; - -M: broadcast-forward forward-message - irc> chats>> values [ to-chat ] with each ; - -GENERIC: process-message ( irc-message -- ) -M: object process-message drop ; -M: rpl-welcome process-message - nickname>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri - values [ initialize-chat ] each ; -M: ping process-message trailing>> /PONG ; -M: rpl-nickname-in-use process-message name>> "_" append /NICK ; - -M: join process-message - [ drop +normal+ ] [ sender>> ] [ trailing>> ] tri - dup chat> [ add-participant ] [ 3drop ] if ; - -M: part process-message - [ sender>> ] [ channel>> ] bi remove-participant ; - -M: kick process-message - [ [ user>> ] [ channel>> ] bi remove-participant ] - [ dup user>> me? [ unregister-chat ] [ drop ] if ] - bi ; - -M: quit process-message - sender>> remove-participant-from-all ; - -M: nick process-message - [ sender>> ] [ trailing>> ] bi rename-participant-in-all ; - -M: mode process-message ( mode -- ) - dup channel-mode? [ - [ name>> ] [ mode>> ] [ parameter>> ] tri - [ change-participant-mode ] [ 2drop ] if* - ] [ drop ] if ; - -: >nick/mode ( string -- nick mode ) - dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; - -: names-reply>participants ( names-reply -- participants ) - nicks>> [ blank? ] trim " " split - [ >nick/mode 2array ] map >hashtable ; - -: maybe-clean-participants ( channel-chat -- ) - dup clean-participants>> [ - H{ } clone >>participants f >>clean-participants - ] when drop ; - -M: rpl-names process-message - [ names-reply>participants ] [ channel>> chat> ] bi [ - [ maybe-clean-participants ] - [ participants>> 2array assoc-combine ] - [ (>>participants) ] tri - ] [ drop ] if* ; - -M: rpl-names-end process-message - channel>> chat> [ - t >>clean-participants - [ f f f ] dip name>> to-chat - ] when* ; - -! ====================================== -! Client message handling -! ====================================== - -GENERIC: handle-outgoing-irc ( irc-message -- ? ) -M: irc-end handle-outgoing-irc drop f ; -M: irc-message handle-outgoing-irc irc-message>string irc-print t ; - -! ====================================== -! Reader/Writer -! ====================================== - -: handle-reader-message ( irc-message -- ) - irc> in-messages>> mailbox-put ; - -DEFER: (connect-irc) - -: (handle-disconnect) ( -- ) - irc> - [ [ irc-disconnected ] dip in-messages>> mailbox-put ] - [ dup reconnect-time>> sleep (connect-irc) ] - [ nick>> /LOGIN ] - tri ; - -! FIXME: do something with the exception, store somewhere to help debugging -: handle-disconnect ( error -- ? ) - drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ; - -: (reader-loop) ( -- ? ) - irc> stream>> [ - |dispose stream-readln [ - string>irc-message handle-reader-message t - ] [ - f handle-disconnect - ] if* - ] with-destructors ; - -: reader-loop ( -- ? ) - [ (reader-loop) ] [ handle-disconnect ] recover ; - -: writer-loop ( -- ? ) - irc> out-messages>> mailbox-get handle-outgoing-irc ; - -! ====================================== -! Processing loops -! ====================================== - -: in-multiplexer-loop ( -- ? ) - irc> in-messages>> mailbox-get - [ forward-message ] [ process-message ] [ irc-end? not ] tri ; - -: strings>privmsg ( name string -- privmsg ) - " :" prepend append "PRIVMSG " prepend string>irc-message ; - -: maybe-annotate-with-name ( name obj -- obj ) - { { [ dup string? ] [ strings>privmsg ] } - { [ dup privmsg instance? ] [ swap >>name ] } - [ nip ] - } cond ; - -GENERIC: annotate-message ( chat object -- object ) -M: object annotate-message nip ; -M: part annotate-message swap name>> >>channel ; -M: privmsg annotate-message swap name>> >>target ; -M: string annotate-message [ name>> ] dip strings>privmsg ; - -: spawn-irc ( -- ) - [ reader-loop ] "irc-reader-loop" spawn-server - [ writer-loop ] "irc-writer-loop" spawn-server - [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server - 3drop ; - -GENERIC: (attach-chat) ( irc-chat -- ) - -M: irc-chat (attach-chat) - [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ] - [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ] - bi ; - -M: irc-server-chat (attach-chat) - irc> >>client +server-chat+ irc> chats>> set-at ; - -GENERIC: (remove-chat) ( irc-chat -- ) - -M: irc-nick-chat (remove-chat) - name>> unregister-chat ; - -M: irc-channel-chat (remove-chat) - [ part new annotate-message irc> out-messages>> mailbox-put ] keep - name>> unregister-chat ; - -M: irc-server-chat (remove-chat) - drop +server-chat+ unregister-chat ; - -: (connect-irc) ( irc-client -- ) - { - [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] - [ (>>stream) ] - [ t swap (>>is-running) ] - [ in-messages>> [ irc-connected ] dip mailbox-put ] - } cleave ; - -: with-irc-client ( irc-client quot: ( -- ) -- ) - [ \ current-irc-client ] dip with-variable ; inline - -PRIVATE> - : connect-irc ( irc-client -- ) - dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ; - -: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ; - -: detach-chat ( irc-chat -- ) - [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ; - -: speak ( message irc-chat -- ) - [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ; + [ (connect-irc) (do-login) spawn-irc ] with-irc ; +: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ; +: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ; +: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ; : hear ( irc-chat -- message ) in-messages>> mailbox-get ; +: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ; diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/internals/internals-tests.factor similarity index 57% rename from extra/irc/client/client-tests.factor rename to extra/irc/client/internals/internals-tests.factor index 9e96cc249b..e358e59058 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -1,10 +1,13 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test accessors arrays sequences - io io.streams.duplex namespaces threads destructors - calendar irc.client.private irc.client irc.messages - concurrency.mailboxes classes assocs combinators irc.messages.parser ; +io io.streams.duplex namespaces threads destructors +calendar concurrency.mailboxes classes assocs combinators +irc.messages.parser irc.client.base irc.client.chats +irc.client.participants irc.client.internals ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ -IN: irc.client.tests +IN: irc.client.internals.tests ! Streams for testing TUPLE: mb-writer lines last-line disposed ; @@ -28,19 +31,20 @@ M: mb-writer dispose drop ; t >>is-ready t >>is-running >>stream - dup [ spawn-irc yield ] with-irc-client ; + dup [ spawn-irc yield ] with-irc ; -! to be used inside with-irc-client quotations -: %add-named-chat ( chat -- ) irc> attach-chat ; +! to be used inside with-irc quotations +: %add-named-chat ( chat -- ) (attach-chat) ; : %push-line ( line -- ) irc> stream>> in>> push-line yield ; -: %join ( channel -- ) irc> attach-chat ; +: %push-lines ( lines -- ) [ %push-line ] each ; +: %join ( channel -- ) (attach-chat) ; : %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; : with-irc ( quot: ( -- ) -- ) - [ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline + [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! TESTS @@ -50,13 +54,11 @@ M: mb-writer dispose drop ; { "factorbot" } [ irc> nick>> ] unit-test -! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test - { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message forward-name ] unit-test + string>irc-message chat-name ] unit-test { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - string>irc-message forward-name ] unit-test + string>irc-message chat-name ] unit-test ] with-irc { privmsg "#channel" "hello" } [ @@ -75,7 +77,12 @@ M: mb-writer dispose drop ; { V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ "someserver" irc-port "factorbot" f [ 2drop t ] >>connect - [ connect-irc ] [ stream>> out>> lines>> ] [ terminate-irc ] tri + [ + (connect-irc) + (do-login) + irc> stream>> out>> lines>> + (terminate-irc) + ] with-irc ] unit-test ! Test join @@ -84,22 +91,15 @@ M: mb-writer dispose drop ; ] unit-test ] with-irc -[ { join_ "#factortest" } [ +[ { join_ "#factortest"} [ "#factortest" [ %add-named-chat ] keep { ":factorbot!n=factorbo@some.where JOIN :#factortest" ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" - } [ %push-line ] each - in-messages>> 0.1 seconds mailbox-get-timeout - [ class ] [ trailing>> ] bi - ] unit-test -] with-irc - -[ { T{ participant-changed f "somebody" +join+ } } [ - "#factortest" [ %add-named-chat ] keep - ":somebody!n=somebody@some.where JOIN :#factortest" %push-line - [ participant-changed? ] read-matching-message + } %push-lines + [ join? ] read-matching-message + [ class ] [ channel>> ] bi ] unit-test ] with-irc @@ -119,112 +119,95 @@ M: mb-writer dispose drop ; ] unit-test ] with-irc -[ { mode } [ +[ { mode "#factortest" "+ns" } [ "#factortest" [ %add-named-chat ] keep ":ircserver.net MODE #factortest +ns" %push-line - [ mode? ] read-matching-message class + [ mode? ] read-matching-message + [ class ] [ name>> ] [ mode>> ] tri ] unit-test ] with-irc ! Participant lists tests -[ { H{ { "ircuser" +normal+ } } } [ +[ { { "ircuser" } } [ "#factortest" [ %add-named-chat ] keep ":ircuser!n=user@isp.net JOIN :#factortest" %push-line - participants>> + participants>> keys ] unit-test ] with-irc -[ { H{ { "ircuser2" +normal+ } } } [ +[ { { "ircuser2" } } [ "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants + { "ircuser2" "ircuser" } [ over join-participant ] each [ %add-named-chat ] keep ":ircuser!n=user@isp.net PART #factortest" %push-line - participants>> + participants>> keys ] unit-test ] with-irc -[ { H{ { "ircuser2" +normal+ } } } [ +[ { { "ircuser2" } } [ "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants + { "ircuser2" "ircuser" } [ over join-participant ] each [ %add-named-chat ] keep ":ircuser!n=user@isp.net QUIT" %push-line - participants>> + participants>> keys ] unit-test ] with-irc -[ { H{ { "ircuser2" +normal+ } } } [ +[ { { "ircuser2" } } [ "#factortest" - H{ { "ircuser2" +normal+ } - { "ircuser" +normal+ } } clone >>participants + { "ircuser2" "ircuser" } [ over join-participant ] each [ %add-named-chat ] keep ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line - participants>> + participants>> keys ] unit-test ] with-irc -[ { H{ { "ircuser2" +normal+ } } } [ +[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [ "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants + "ircuser" over join-participant [ %add-named-chat ] keep ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line participants>> ] unit-test ] with-irc -[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [ +[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } } + { "ircuser" T{ participant { nick "ircuser" } } } + { "voiced" T{ participant { nick "voiced" } { voice t } } } } } [ "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants + "ircuser" over join-participant [ %add-named-chat ] keep - ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line - ":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line - ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line - ":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line + { ":ircserver.net 353 factorbot @ #factortest :@factorbot " + ":ircserver.net 353 factorbot @ #factortest :ircuser2 " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + ":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced " + ":ircserver.net 353 factorbot @ #factortest :ircuser " + ":ircserver.net 366 factorbot #factortest :End of /NAMES list." + } %push-lines participants>> ] unit-test ] with-irc -! Namelist change notification -[ { T{ participant-changed f f f f } } [ - "#factortest" [ %add-named-chat ] keep - ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line - ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -[ { T{ participant-changed f "ircuser" +part+ f } } [ - "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user@isp.net QUIT" %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [ - "#factortest" - H{ { "ircuser" +normal+ } } clone >>participants - [ %add-named-chat ] keep - ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line - [ participant-changed? ] read-matching-message - ] unit-test -] with-irc - -! Mode change -[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [ +[ { mode "#factortest" "+o" "ircuser" } [ "#factortest" [ %add-named-chat ] keep + "ircuser" over join-participant ":ircserver.net MODE #factortest +o ircuser" %push-line - [ participant-changed? ] read-matching-message + [ mode? ] read-matching-message + { [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave + ] unit-test +] with-irc + +[ { T{ participant { nick "ircuser" } { operator t } } } [ + "#factortest" [ %add-named-chat ] keep + "ircuser" over join-participant + ":ircserver.net MODE #factortest +o ircuser" %push-line + participants>> "ircuser" swap at ] unit-test ] with-irc ! Send privmsg [ { "PRIVMSG #factortest :hello" } [ "#factortest" [ %add-named-chat ] keep - "hello" swap speak %pop-output-line + "hello" swap (speak) %pop-output-line ] unit-test ] with-irc diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor new file mode 100644 index 0000000000..2081ae4510 --- /dev/null +++ b/extra/irc/client/internals/internals.factor @@ -0,0 +1,162 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs arrays concurrency.mailboxes continuations destructors +hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces +strings words.symbol irc.messages.base irc.client.participants fry threads +combinators irc.messages.parser ; +EXCLUDE: sequences => join ; +IN: irc.client.internals + +: /NICK ( nick -- ) "NICK " prepend irc-print ; +: /PONG ( text -- ) "PONG " prepend irc-print ; + +: /LOGIN ( nick -- ) + dup /NICK + "USER " prepend " hostname servername :irc.factor" append irc-print ; + +: /CONNECT ( server port -- stream ) + irc> connect>> call( host port -- stream local ) drop ; + +: /JOIN ( channel password -- ) + [ " :" swap 3append ] when* "JOIN " prepend irc-print ; + +: (connect-irc) ( -- ) + irc> { + [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] + [ (>>stream) ] + [ t swap (>>is-running) ] + [ in-messages>> [ irc-connected ] dip mailbox-put ] + } cleave ; + +: (do-login) ( -- ) irc> nick>> /LOGIN ; + +GENERIC: initialize-chat ( chat -- ) +M: irc-chat initialize-chat drop ; +M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ; + +GENERIC: chat-put ( message obj -- ) +M: irc-chat chat-put in-messages>> mailbox-put ; +M: symbol chat-put chat> [ chat-put ] [ drop ] if* ; +M: string chat-put chat> +server-chat+ or chat-put ; +M: sequence chat-put [ chat-put ] with each ; + +: delete-chat ( name -- ) irc> chats>> delete-at ; +: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ; + +! Server message handling + +GENERIC: forward-message ( irc-message -- ) +M: irc-message forward-message +server-chat+ chat-put ; +M: to-one-chat forward-message dup chat> chat-put ; +M: to-all-chats forward-message chats> chat-put ; +M: to-many-chats forward-message dup sender>> participant-chats chat-put ; + +GENERIC: process-message ( irc-message -- ) +M: object process-message drop ; +M: ping process-message trailing>> /PONG ; +M: join process-message [ sender>> ] [ chat> ] bi join-participant ; +M: part process-message [ sender>> ] [ chat> ] bi part-participant ; +M: quit process-message sender>> quit-participant ; +M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ; +M: rpl-nickname-in-use process-message name>> "_" append /NICK ; + +M: rpl-welcome process-message + irc> + swap nickname>> >>nick + t >>is-ready + chats>> values [ initialize-chat ] each ; + +M: kick process-message + [ [ user>> ] [ chat> ] bi part-participant ] + [ dup user>> me? [ unregister-chat ] [ drop ] if ] + bi ; + +M: participant-mode process-message ( participant-mode -- ) + [ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ; + +M: rpl-names process-message + [ nicks>> ] [ chat> ] bi dup ?clear-participants + '[ _ join-participant ] each ; + +M: rpl-names-end process-message chat> t >>clear-participants drop ; + +! Client message handling + +GENERIC: handle-outgoing-irc ( irc-message -- ? ) +M: irc-end handle-outgoing-irc drop f ; +M: irc-message handle-outgoing-irc irc-message>string irc-print t ; + +! Reader/Writer + +: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ; + +: (handle-disconnect) ( -- ) + irc> in-messages>> irc-disconnected swap mailbox-put + irc> reconnect-time>> sleep + (connect-irc) + (do-login) ; + +: handle-disconnect ( error -- ? ) + [ irc> exceptions>> push ] when* + irc> is-running>> [ (handle-disconnect) t ] [ f ] if ; + +GENERIC: handle-input ( line/f -- ? ) +M: string handle-input string>irc-message handle-reader-message t ; +M: f handle-input handle-disconnect ; + +: (reader-loop) ( -- ? ) + stream> [ |dispose stream-readln handle-input ] with-destructors ; + +: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ; +: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ; + +! Processing loops + +: in-multiplexer-loop ( -- ? ) + irc> in-messages>> mailbox-get + [ process-message ] [ forward-message ] [ irc-end? not ] tri ; + +: strings>privmsg ( name string -- privmsg ) + " :" prepend append "PRIVMSG " prepend string>irc-message ; + +GENERIC: annotate-message ( chat object -- object ) +M: object annotate-message nip ; +M: to-channel annotate-message swap name>> >>channel ; +M: to-target annotate-message swap name>> >>target ; +M: mode annotate-message swap name>> >>name ; +M: string annotate-message [ name>> ] dip strings>privmsg ; + +: spawn-irc ( -- ) + [ reader-loop ] "irc-reader-loop" spawn-server + [ writer-loop ] "irc-writer-loop" spawn-server + [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server + 3drop ; + +GENERIC: (attach-chat) ( irc-chat -- ) + +M: irc-chat (attach-chat) + irc> + [ [ chats>> ] [ >>client name>> swap ] 2bi set-at ] + [ is-ready>> [ initialize-chat ] [ drop ] if ] + 2bi ; + +M: irc-server-chat (attach-chat) + irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ; + +GENERIC: remove-chat ( irc-chat -- ) +M: irc-nick-chat remove-chat name>> unregister-chat ; +M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ; + +M: irc-channel-chat remove-chat + [ part new annotate-message irc-send ] + [ name>> unregister-chat ] bi ; + +: (terminate-irc) ( -- ) + irc> dup is-running>> [ + f >>is-running + [ stream>> dispose ] keep + [ in-messages>> ] [ out-messages>> ] bi 2array + [ irc-end swap mailbox-put ] each + ] [ drop ] if ; + +: (speak) ( message irc-chat -- ) swap annotate-message irc-send ; \ No newline at end of file diff --git a/extra/irc/client/participants/participants.factor b/extra/irc/client/participants/participants.factor new file mode 100644 index 0000000000..8d367dbb95 --- /dev/null +++ b/extra/irc/client/participants/participants.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators fry hashtables +irc.client.base irc.client.chats kernel sequences splitting ; +IN: irc.client.participants + +TUPLE: participant nick operator voice ; +: ( name -- participant ) + { + { [ "@" ?head ] [ t f ] } + { [ "+" ?head ] [ f t ] } + [ f f ] + } cond participant boa ; + +GENERIC: has-participant? ( name irc-chat -- ? ) +M: irc-chat has-participant? 2drop f ; +M: irc-channel-chat has-participant? participants>> key? ; + +: rename-X ( new old assoc quot: ( obj value -- obj ) -- ) + '[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline + +: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ; +: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ; +: part-participant ( nick irc-chat -- ) participants>> delete-at ; +: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ; + +: quit-participant ( nick -- ) + dup participant-chats [ part-participant ] with each ; + +: rename-participant* ( new old -- ) + [ dup participant-chats [ rename-participant ] with with each ] + [ dup chat> [ rename-nick-chat ] [ 2drop ] if ] + 2bi ; + +: join-participant ( nick irc-channel-chat -- ) + participants>> [ dup nick>> ] dip set-at ; + +: apply-mode ( ? participant mode -- ) + { + { CHAR: o [ (>>operator) ] } + { CHAR: v [ (>>voice) ] } + [ 3drop ] + } case ; + +: apply-modes ( mode-line participant -- ) + [ unclip CHAR: + = ] dip + '[ [ _ _ ] dip apply-mode ] each ; + +: change-participant-mode ( mode channel nick -- ) + swap chat> participants>> at apply-modes ; + +: ?clear-participants ( channel-chat -- ) + dup clear-participants>> [ + f >>clear-participants participants>> clear-assoc + ] [ drop ] if ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index e0f9a15eff..32d19906f0 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators - arrays classes.tuple math.order words assocs strings - irc.messages.base ; +arrays classes.tuple math.order words assocs strings irc.messages.base ; EXCLUDE: sequences => join ; IN: irc.messages @@ -16,7 +15,7 @@ IRC: service "SERVICE" nickname _ distribution type _ : info ; IRC: quit "QUIT" : comment ; IRC: squit "SQUIT" server : comment ; ! channel operations -IRC: join "JOIN" channel ; +IRC: join "JOIN" : channel ; IRC: part "PART" channel : comment ; IRC: topic "TOPIC" channel : topic ; IRC: names "NAMES" channel ; @@ -61,3 +60,9 @@ IRC: rpl-names-end "366" nickname channel : comment ; ! error replies IRC: rpl-nickname-in-use "433" _ name ; IRC: rpl-nick-collision "436" nickname : comment ; + +M: rpl-names post-process-irc-message ( rpl-names -- ) + [ [ blank? ] trim " " split ] change-nicks drop ; + +PREDICATE: channel-mode < mode name>> first "#&" member? ; +PREDICATE: participant-mode < channel-mode parameter>> ; From 837ab3d982ea5b39466eee611e9243889e45c011 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 12 Apr 2009 16:35:29 -0300 Subject: [PATCH 10/21] irc.gitbot: Fix USEs line --- extra/irc/gitbot/gitbot.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 3b7694a347..d145b3bd2c 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry irc.client irc.client.private kernel namespaces +USING: fry irc.client irc.client.chats kernel namespaces sequences threads io.encodings.8-bit io.launcher io splitting make mason.common mason.updates calendar math alarms ; IN: irc.gitbot From 8eedc105a980c0c03d1c949e545fc26258d3564f Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 12 Apr 2009 16:47:55 -0300 Subject: [PATCH 11/21] Add missing bsd copyright notices, authors.txt, summary.txt files --- extra/irc/client/base/authors.txt | 1 + extra/irc/client/chats/authors.txt | 1 + extra/irc/client/chats/chats-docs.factor | 2 ++ extra/irc/client/chats/summary.txt | 1 + extra/irc/client/client-docs.factor | 2 ++ extra/irc/client/internals/authors.txt | 1 + extra/irc/client/internals/summary.txt | 1 + extra/irc/client/participants/authors.txt | 1 + extra/irc/client/participants/summary.txt | 1 + extra/irc/messages/messages-tests.factor | 2 ++ extra/irc/messages/messages.factor | 2 +- 11 files changed, 14 insertions(+), 1 deletion(-) create mode 100644 extra/irc/client/base/authors.txt create mode 100644 extra/irc/client/chats/authors.txt create mode 100644 extra/irc/client/chats/summary.txt create mode 100644 extra/irc/client/internals/authors.txt create mode 100644 extra/irc/client/internals/summary.txt create mode 100644 extra/irc/client/participants/authors.txt create mode 100644 extra/irc/client/participants/summary.txt diff --git a/extra/irc/client/base/authors.txt b/extra/irc/client/base/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/client/base/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/client/chats/authors.txt b/extra/irc/client/chats/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/client/chats/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/client/chats/chats-docs.factor b/extra/irc/client/chats/chats-docs.factor index 66fd1a207d..d84e38f499 100644 --- a/extra/irc/client/chats/chats-docs.factor +++ b/extra/irc/client/chats/chats-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax quotations kernel ; IN: irc.client.chats diff --git a/extra/irc/client/chats/summary.txt b/extra/irc/client/chats/summary.txt new file mode 100644 index 0000000000..6e9493bfa5 --- /dev/null +++ b/extra/irc/client/chats/summary.txt @@ -0,0 +1 @@ +IRC Client and Chat object definitions diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index ad674cb0c1..496c2caa32 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax quotations kernel irc.messages irc.messages.base irc.messages.parser irc.client.chats ; IN: irc.client diff --git a/extra/irc/client/internals/authors.txt b/extra/irc/client/internals/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/client/internals/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/client/internals/summary.txt b/extra/irc/client/internals/summary.txt new file mode 100644 index 0000000000..a831199ba0 --- /dev/null +++ b/extra/irc/client/internals/summary.txt @@ -0,0 +1 @@ +IRC Client internals diff --git a/extra/irc/client/participants/authors.txt b/extra/irc/client/participants/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/irc/client/participants/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/irc/client/participants/summary.txt b/extra/irc/client/participants/summary.txt new file mode 100644 index 0000000000..3e88e61f5d --- /dev/null +++ b/extra/irc/client/participants/summary.txt @@ -0,0 +1 @@ +IRC Client chat participants handling diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index d88eeabc73..74cd95c09a 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test accessors arrays irc.messages.parser irc.messages ; EXCLUDE: sequences => join ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 32d19906f0..2ea476e1b4 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Bruno Deferrari +! Copyright (C) 2009 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry splitting ascii calendar accessors combinators arrays classes.tuple math.order words assocs strings irc.messages.base ; From e8d37558cbbcebf6307e60f0137944fa09144da6 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 12 Apr 2009 16:52:24 -0300 Subject: [PATCH 12/21] irc.client: Fix typos --- extra/irc/client/chats/chats-docs.factor | 2 +- extra/irc/client/client-docs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/irc/client/chats/chats-docs.factor b/extra/irc/client/chats/chats-docs.factor index d84e38f499..8ab2968eb7 100644 --- a/extra/irc/client/chats/chats-docs.factor +++ b/extra/irc/client/chats/chats-docs.factor @@ -15,7 +15,7 @@ HELP: irc-profile "IRC Client profile object" ; HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ; -HELP: irc-end "Message sent when the client isn't running anymore, a chat should stop after it receives this message." ; +HELP: irc-end "Message sent when the client isn't running anymore, the chat should stop after it receives this message." ; HELP: irc-disconnected "Message sent to notify chats that connection was lost." ; diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 496c2caa32..aa0bcb3bf3 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -67,7 +67,7 @@ ARTICLE: "irc.client" "IRC Client" "Some special messages that are created by the library and not by the irc server." { $table { { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " } - { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." } + { { $link irc-end } " sent when the client isn't running anymore, the chat should stop after it receives this message." } { { $link irc-disconnected } " sent to notify chats that connection was lost." } { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } } From d8f144a8e9bf578dfab69cc22bce6af4fa16cd5a Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 12 Apr 2009 19:44:46 -0300 Subject: [PATCH 13/21] irc: Fix problems in tests --- .../client/internals/internals-tests.factor | 34 +++++++++---------- extra/irc/messages/messages-tests.factor | 3 +- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index e358e59058..d20ae50bcc 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -43,7 +43,7 @@ M: mb-writer dispose drop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; -: with-irc ( quot: ( -- ) -- ) +: spawning-irc ( quot: ( -- ) -- ) [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -59,7 +59,7 @@ M: mb-writer dispose drop ; { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" string>irc-message chat-name ] unit-test -] with-irc +] spawning-irc { privmsg "#channel" "hello" } [ "#channel" "hello" strings>privmsg @@ -71,7 +71,7 @@ M: mb-writer dispose drop ; ":some.where 001 factorbot2 :Welcome factorbot2" %push-line irc> nick>> ] unit-test -] with-irc +] spawning-irc ! Test connect { V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [ @@ -89,7 +89,7 @@ M: mb-writer dispose drop ; [ { "JOIN #factortest" } [ "#factortest" %join %pop-output-line ] unit-test -] with-irc +] spawning-irc [ { join_ "#factortest"} [ "#factortest" [ %add-named-chat ] keep @@ -101,7 +101,7 @@ M: mb-writer dispose drop ; [ join? ] read-matching-message [ class ] [ channel>> ] bi ] unit-test -] with-irc +] spawning-irc [ { privmsg "#factortest" "hello" } [ "#factortest" [ %add-named-chat ] keep @@ -109,7 +109,7 @@ M: mb-writer dispose drop ; [ privmsg? ] read-matching-message [ class ] [ target>> ] [ trailing>> ] tri ] unit-test -] with-irc +] spawning-irc [ { privmsg "factorbot" "hello" } [ "ircuser" [ %add-named-chat ] keep @@ -117,7 +117,7 @@ M: mb-writer dispose drop ; [ privmsg? ] read-matching-message [ class ] [ target>> ] [ trailing>> ] tri ] unit-test -] with-irc +] spawning-irc [ { mode "#factortest" "+ns" } [ "#factortest" [ %add-named-chat ] keep @@ -125,7 +125,7 @@ M: mb-writer dispose drop ; [ mode? ] read-matching-message [ class ] [ name>> ] [ mode>> ] tri ] unit-test -] with-irc +] spawning-irc ! Participant lists tests [ { { "ircuser" } } [ @@ -133,7 +133,7 @@ M: mb-writer dispose drop ; ":ircuser!n=user@isp.net JOIN :#factortest" %push-line participants>> keys ] unit-test -] with-irc +] spawning-irc [ { { "ircuser2" } } [ "#factortest" @@ -142,7 +142,7 @@ M: mb-writer dispose drop ; ":ircuser!n=user@isp.net PART #factortest" %push-line participants>> keys ] unit-test -] with-irc +] spawning-irc [ { { "ircuser2" } } [ "#factortest" @@ -151,7 +151,7 @@ M: mb-writer dispose drop ; ":ircuser!n=user@isp.net QUIT" %push-line participants>> keys ] unit-test -] with-irc +] spawning-irc [ { { "ircuser2" } } [ "#factortest" @@ -160,7 +160,7 @@ M: mb-writer dispose drop ; ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line participants>> keys ] unit-test -] with-irc +] spawning-irc [ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [ "#factortest" @@ -169,7 +169,7 @@ M: mb-writer dispose drop ; ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line participants>> ] unit-test -] with-irc +] spawning-irc [ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } } { "ircuser" T{ participant { nick "ircuser" } } } @@ -186,7 +186,7 @@ M: mb-writer dispose drop ; } %push-lines participants>> ] unit-test -] with-irc +] spawning-irc [ { mode "#factortest" "+o" "ircuser" } [ "#factortest" [ %add-named-chat ] keep @@ -195,7 +195,7 @@ M: mb-writer dispose drop ; [ mode? ] read-matching-message { [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave ] unit-test -] with-irc +] spawning-irc [ { T{ participant { nick "ircuser" } { operator t } } } [ "#factortest" [ %add-named-chat ] keep @@ -203,11 +203,11 @@ M: mb-writer dispose drop ; ":ircserver.net MODE #factortest +o ircuser" %push-line participants>> "ircuser" swap at ] unit-test -] with-irc +] spawning-irc ! Send privmsg [ { "PRIVMSG #factortest :hello" } [ "#factortest" [ %add-named-chat ] keep "hello" swap (speak) %pop-output-line ] unit-test -] with-irc +] spawning-irc diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 74cd95c09a..218ed92018 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -26,7 +26,8 @@ IN: irc.messages.tests { command "JOIN" } { parameters { } } { trailing "#factortest" } - { sender "someuser" } } } + { sender "someuser" } + { channel "#factortest" } } } [ ":someuser!n=user@some.where JOIN :#factortest" string>irc-message f >>timestamp ] unit-test From b6a8e023a5a0fcb64564178bfa42e590c575fae8 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 13 Apr 2009 01:17:04 +0200 Subject: [PATCH 14/21] Fix: setting WM_CLASS in X11 backend using UTF8 string --- basis/ui/backend/x11/x11.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 5a2a8974e7..d4b2959297 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -225,7 +225,7 @@ M: x-clipboard paste-clipboard utf8 encode dup length XChangeProperty drop ; : set-class ( dpy window -- ) - XA_WM_CLASS XA_STRING 8 PropModeReplace "Factor" + XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor" utf8 encode dup length XChangeProperty drop ; M: x11-ui-backend set-title ( string world -- ) From 69017ce41f757892a2e9d3bbcefb5993a9c44c12 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 14 Apr 2009 01:56:06 +0200 Subject: [PATCH 15/21] FUEL: fix for call( indentation. --- misc/fuel/fuel-syntax.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 7aba6282d6..1c88989366 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -262,7 +262,8 @@ ("\\_\\)" (1 "\\)" (2 "\\)" + (2 "" (1 ">b")) ;; Let and lambda: ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) @@ -275,6 +276,7 @@ ("\\_<\\(}\\)\\_>" (1 "){")) ;; Parenthesis: ("\\_<\\((\\)\\_>" (1 "()")) + ("\\_" (1 "()")) ("\\_<\\()\\)\\_>" (1 ")(")) ("\\_<(\\((\\)\\_>" (1 "()")) ("\\_<\\()\\))\\_>" (1 ")(")) From 1596d9aeaeeb27628ab0dea6344073a4d4324197 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Mon, 13 Apr 2009 19:03:17 -0500 Subject: [PATCH 16/21] mason: add workaround for cygwin git issue --- extra/mason/cleanup/cleanup.factor | 2 +- extra/mason/common/common.factor | 15 +++++++++++++-- extra/mason/release/archive/archive.factor | 2 +- extra/mason/release/tidy/tidy.factor | 4 ++-- 4 files changed, 17 insertions(+), 6 deletions(-) mode change 100644 => 100755 extra/mason/cleanup/cleanup.factor mode change 100644 => 100755 extra/mason/common/common.factor mode change 100644 => 100755 extra/mason/release/archive/archive.factor mode change 100644 => 100755 extra/mason/release/tidy/tidy.factor diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor old mode 100644 new mode 100755 index a2c087392a..a273696f51 --- a/extra/mason/cleanup/cleanup.factor +++ b/extra/mason/cleanup/cleanup.factor @@ -18,6 +18,6 @@ IN: mason.cleanup build-dir [ compress-image compress-test-log - "factor" delete-tree + "factor" really-delete-tree ] with-directory ] unless ; diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor old mode 100644 new mode 100755 index 3cd38e1ff4..047bdaa844 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -2,11 +2,22 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories -io.launcher io.encodings.utf8 prettyprint +io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals ; +calendar.format arrays mason.config locals system ; IN: mason.common +HOOK: really-delete-tree os ( path -- ) + +M: windows really-delete-tree + #! Workaround: Cygwin GIT creates read-only files for + #! some reason. + [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ] + [ delete-tree ] + bi ; + +M: unix really-delete-tree delete-tree ; + : short-running-process ( command -- ) #! Give network operations at most 15 minutes to complete. diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor old mode 100644 new mode 100755 index 5ef424ad4f..fff8b83c23 --- a/extra/mason/release/archive/archive.factor +++ b/extra/mason/release/archive/archive.factor @@ -29,7 +29,7 @@ IN: mason.release.archive "-fs" "HFS+" "-volname" "factor" } archive-name suffix try-process - "dmg-root" delete-tree ; + "dmg-root" really-delete-tree ; : make-unix-archive ( -- ) [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ; diff --git a/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor old mode 100644 new mode 100755 index 497be09044..054b15f0f5 --- a/extra/mason/release/tidy/tidy.factor +++ b/extra/mason/release/tidy/tidy.factor @@ -12,11 +12,11 @@ IN: mason.release.tidy append ; : remove-common-files ( -- ) - common-files [ delete-tree ] each ; + common-files [ really-delete-tree ] each ; : remove-factor-app ( -- ) target-os get "macosx" = - [ "Factor.app" delete-tree ] unless ; + [ "Factor.app" really-delete-tree ] unless ; : tidy ( -- ) "factor" [ remove-factor-app remove-common-files ] with-directory ; From 0ffd43e2e3a6e81af4370fec2224e9be2c846d83 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 19:48:08 -0500 Subject: [PATCH 17/21] 1.0/0.0 => 1/0. --- basis/db/tuples/tuples-tests.factor | 6 +++--- basis/furnace/cache/cache.factor | 2 +- basis/math/functions/functions-tests.factor | 4 ++-- basis/math/libm/libm-docs.factor | 2 +- basis/wrap/wrap.factor | 2 +- core/math/floats/floats-tests.factor | 2 -- core/math/integers/integers.factor | 2 +- extra/benchmark/raytracer/raytracer.factor | 2 +- 8 files changed, 10 insertions(+), 12 deletions(-) diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index d4a58fa4fc..375ee509bb 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -411,7 +411,7 @@ TUPLE: exam id name score ; T{ exam f 4 "Cartman" 41 } } ] [ - T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples + T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples ] unit-test [ @@ -419,7 +419,7 @@ TUPLE: exam id name score ; T{ exam f 1 "Kyle" 100 } } ] [ - T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples + T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples ] unit-test [ @@ -430,7 +430,7 @@ TUPLE: exam id name score ; T{ exam f 4 "Cartman" 41 } } ] [ - T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples + T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples ] unit-test [ diff --git a/basis/furnace/cache/cache.factor b/basis/furnace/cache/cache.factor index a5308c171e..fe2840c9eb 100644 --- a/basis/furnace/cache/cache.factor +++ b/basis/furnace/cache/cache.factor @@ -22,7 +22,7 @@ server-state f : expire-state ( class -- ) new - -1.0/0.0 millis [a,b] >>expires + -1/0. millis [a,b] >>expires delete-tuples ; TUPLE: server-state-manager < filter-responder timeout ; diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 4c9d151fd8..397a7cc2f3 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -22,9 +22,9 @@ IN: math.functions.tests [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test [ t ] [ 0 0 ^ fp-nan? ] unit-test -[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test +[ 1/0. ] [ 0 -2 ^ ] unit-test [ t ] [ 0 0.0 ^ fp-nan? ] unit-test -[ 1.0/0.0 ] [ 0 -2.0 ^ ] unit-test +[ 1/0. ] [ 0 -2.0 ^ ] unit-test [ 0 ] [ 0 3.0 ^ ] unit-test [ 0 ] [ 0 3 ^ ] unit-test diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor index bf4c608d77..a890a59c19 100644 --- a/basis/math/libm/libm-docs.factor +++ b/basis/math/libm/libm-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions" $nl "They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:" { $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" } -{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" } +{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } "Trigonometric functions:" { $subsection fcos } { $subsection fsin } diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 58957ba8e7..482d50ab5f 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -30,7 +30,7 @@ SYMBOL: line-ideal { [ lines>> car 1list? ] [ top-fits? ] } 1|| ; :: min-by ( seq quot -- elt ) - f 1.0/0.0 seq [| key value new | + f 1/0. seq [| key value new | new quot call :> newvalue newvalue value < [ new newvalue ] [ key value ] if ] each drop ; inline diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 27cc510ea2..9f8f7b06fc 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -56,8 +56,6 @@ unit-test [ t ] [ 0.0 zero? ] unit-test [ t ] [ -0.0 zero? ] unit-test -! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test - [ 0 ] [ 1/0. >bignum ] unit-test [ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index e88caa7703..868d9fc02e 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -122,7 +122,7 @@ M: bignum (log2) bignum-log2 ; 2drop 0.0 ] [ dup zero? [ - 2drop 1.0/0.0 + 2drop 1/0. ] [ pre-scale /f-loop over odd? diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index a4df1fe04d..642b3dbb93 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -53,7 +53,7 @@ C: sphere : sphere-t ( b d -- t ) -+ dup 0.0 < - [ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline + [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline : sphere-b&v ( sphere ray -- b v ) [ sphere-v ] [ nip ] 2bi From cb6f59ff5b4ef9b87ce059bc12e12f6b24feeea1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 20:25:55 -0500 Subject: [PATCH 18/21] Fix unit test failure in math.parser --- core/math/parser/parser.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 0a637c2eab..3fd62e69a0 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -50,7 +50,9 @@ SYMBOL: radix SYMBOL: negative? : string>natural ( seq radix -- n/f ) - [ [ digit> ] dip (digits>integer) ] each-digit ; inline + over empty? [ 2drop f ] [ + [ [ digit> ] dip (digits>integer) ] each-digit + ] if ; inline : sign ( -- str ) negative? get "-" "+" ? ; From a4e62dfdba8f84ddd543379345d6600d6bc2af31 Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 13 Apr 2009 14:47:39 -0500 Subject: [PATCH 19/21] Fix for math.parser syntax change --- .../compiler/tree/propagation/recursive/recursive.factor | 4 ++-- basis/math/functions/functions.factor | 2 +- basis/math/intervals/intervals.factor | 8 ++++---- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 1bcd36f6b0..b8d1760a0b 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -28,8 +28,8 @@ IN: compiler.tree.propagation.recursive { { [ 2dup interval-subset? ] [ empty-interval ] } { [ over empty-interval eq? ] [ empty-interval ] } - { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] } - { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] } + { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] } + { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] } [ [-inf,inf] ] } cond interval-union nip ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 1eac321e3b..a6beb87345 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -81,7 +81,7 @@ PRIVATE> 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline : 0^ ( x -- z ) - dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline + dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline : (^mod) ( n x y -- z ) make-bits 1 [ diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 4fbc880971..02ea181f4e 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -40,13 +40,13 @@ TUPLE: interval { from read-only } { to read-only } ; : [a,a] ( a -- interval ) closed-point dup ; foldable -: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline +: [-inf,a] ( a -- interval ) -1/0. swap [a,b] ; inline -: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline +: [-inf,a) ( a -- interval ) -1/0. swap [a,b) ; inline -: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline +: [a,inf] ( a -- interval ) 1/0. [a,b] ; inline -: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline +: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline : [-inf,inf] ( -- interval ) full-interval ; inline From b1c1b4aba73ffb6401db40ca0b204b917ef1a86b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 15:11:32 -0500 Subject: [PATCH 20/21] Fix pango.layouts issue on 64-bit systems --- basis/pango/layouts/layouts.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/pango/layouts/layouts.factor b/basis/pango/layouts/layouts.factor index defcdec6f8..25aee74ca4 100644 --- a/basis/pango/layouts/layouts.factor +++ b/basis/pango/layouts/layouts.factor @@ -44,7 +44,7 @@ FUNCTION: PangoLayoutLine* pango_layout_get_line_readonly ( PangoLayout* layout, int line ) ; FUNCTION: void -pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, gboolean trailing, int* x_pos ) ; +pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, uint trailing, int* x_pos ) ; FUNCTION: gboolean pango_layout_line_x_to_index ( PangoLayoutLine* line, int x_pos, int* index_, int* trailing ) ; @@ -122,7 +122,7 @@ MEMO: missing-font-metrics ( font -- metrics ) : line-offset>x ( layout n -- x ) #! n is an index into the UTF8 encoding of the text [ drop first-line ] [ swap string>> >utf8-index ] 2bi - f 0 [ pango_layout_line_index_to_x ] keep + 0 0 [ pango_layout_line_index_to_x ] keep *int pango>float ; : x>line-offset ( layout x -- n ) @@ -205,4 +205,4 @@ SYMBOL: cached-layouts : cached-line ( font string -- line ) cached-layout layout>> first-line ; -[ cached-layouts set-global ] "pango.layouts" add-init-hook \ No newline at end of file +[ cached-layouts set-global ] "pango.layouts" add-init-hook From b6ee0dca3be2c6fda889232eefe766706e01ce35 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 13 Apr 2009 15:17:04 -0500 Subject: [PATCH 21/21] Fix compile warning --- build-support/factor.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index ad64c541fe..2fec39f14a 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -199,7 +199,7 @@ find_architecture() { write_test_program() { echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } c_find_word_size() {