Merge branch 'master' of git://factorforge.org/git/william42

db4
Doug Coleman 2008-07-31 20:54:32 -05:00
commit 29ce373330
5 changed files with 117 additions and 36 deletions

View File

@ -43,7 +43,7 @@ IN: irc.client.tests
":some.where 001 factorbot :Welcome factorbot" ":some.where 001 factorbot :Welcome factorbot"
} make-client } make-client
{ [ connect-irc ] { [ connect-irc ]
[ drop 1 seconds sleep ] [ drop 0.1 seconds sleep ]
[ profile>> nickname>> ] [ profile>> nickname>> ]
[ terminate-irc ] [ terminate-irc ]
} cleave ] unit-test } cleave ] unit-test
@ -57,8 +57,8 @@ IN: irc.client.tests
} make-client } make-client
{ [ "factorbot" set-nick ] { [ "factorbot" set-nick ]
[ connect-irc ] [ connect-irc ]
[ drop 1 seconds sleep ] [ drop 0.1 seconds sleep ]
[ join-messages>> 1 seconds mailbox-get-timeout ] [ join-messages>> 0.1 seconds mailbox-get-timeout ]
[ terminate-irc ] [ terminate-irc ]
} cleave } cleave
[ class ] [ trailing>> ] bi ] unit-test [ class ] [ trailing>> ] bi ] unit-test
@ -101,3 +101,75 @@ IN: irc.client.tests
} cleave } cleave
[ class ] [ name>> ] [ trailing>> ] tri [ class ] [ name>> ] [ trailing>> ] tri
] unit-test ] unit-test
! Participants lists tests
{ H{ { "somedude" +normal+ } } } [
{ ":somedude!n=user@isp.net JOIN :#factortest" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude!n=user@isp.net PART #factortest" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude!n=user@isp.net QUIT" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
! Namelist notification
{ T{ participant-changed f f f } } [
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
] unit-test

View File

@ -218,9 +218,9 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ; dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- ) M: join handle-incoming-irc ( join -- )
{ [ maybe-forward-join ] ! keep { [ maybe-forward-join ]
[ dup trailing>> to-listener ] [ dup trailing>> to-listener ]
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
[ handle-participant-change ] [ handle-participant-change ]
} cleave ; } cleave ;
@ -231,19 +231,18 @@ M: part handle-incoming-irc ( part -- )
tri ; tri ;
M: kick handle-incoming-irc ( kick -- ) M: kick handle-incoming-irc ( kick -- )
{ [ dup channel>> to-listener ] { [ dup channel>> to-listener ]
[ [ who>> ] [ channel>> ] bi remove-participant ] [ [ who>> ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ] [ handle-participant-change ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ] [ dup who>> me? [ unregister-listener ] [ drop ] if ]
} cleave ; } cleave ;
M: quit handle-incoming-irc ( quit -- ) M: quit handle-incoming-irc ( quit -- )
{ [ dup prefix>> parse-name listeners-with-participant [ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ] [ to-listener ] with each ]
[ handle-participant-change ] [ prefix>> parse-name remove-participant-from-all ]
[ prefix>> parse-name remove-participant-from-all ] [ handle-participant-change ]
[ call-next-method ] tri ;
} cleave ;
: >nick/mode ( string -- nick mode ) : >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@ -253,8 +252,10 @@ M: quit handle-incoming-irc ( quit -- )
[ >nick/mode 2array ] map >hashtable ; [ >nick/mode 2array ] map >hashtable ;
M: names-reply handle-incoming-irc ( names-reply -- ) M: names-reply handle-incoming-irc ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi [ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ] [ drop ] if* ; [ (>>participants) ]
[ [ f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ; broadcast-message-to-listeners ;

View File

@ -40,8 +40,18 @@ mode new
"ircserver.net" >>prefix "ircserver.net" >>prefix
"MODE" >>command "MODE" >>command
{ "#factortest" "+ns" } >>parameters { "#factortest" "+ns" } >>parameters
"#factortest" >>channel "#factortest" >>channel
"+ns" >>mode "+ns" >>mode
1array 1array
[ ":ircserver.net MODE #factortest +ns" [ ":ircserver.net MODE #factortest +ns"
parse-irc-line f >>timestamp ] unit-test
nick new
":someuser!n=user@some.where NICK :someuser2" >>line
"someuser!n=user@some.where" >>prefix
"NICK" >>command
{ } >>parameters
"someuser2" >>trailing
1array
[ ":someuser!n=user@some.where NICK :someuser2"
parse-irc-line f >>timestamp ] unit-test parse-irc-line f >>timestamp ] unit-test

View File

@ -12,6 +12,7 @@ TUPLE: ping < irc-message ;
TUPLE: join < irc-message ; TUPLE: join < irc-message ;
TUPLE: part < irc-message channel ; TUPLE: part < irc-message channel ;
TUPLE: quit < irc-message ; TUPLE: quit < irc-message ;
TUPLE: nick < irc-message ;
TUPLE: privmsg < irc-message name ; TUPLE: privmsg < irc-message name ;
TUPLE: kick < irc-message channel who ; TUPLE: kick < irc-message channel who ;
TUPLE: roomlist < irc-message channel names ; TUPLE: roomlist < irc-message channel names ;
@ -34,6 +35,7 @@ M: ping irc-command-string ( ping -- string ) drop "PING" ;
M: join irc-command-string ( join -- string ) drop "JOIN" ; M: join irc-command-string ( join -- string ) drop "JOIN" ;
M: part irc-command-string ( part -- string ) drop "PART" ; M: part irc-command-string ( part -- string ) drop "PART" ;
M: quit irc-command-string ( quit -- string ) drop "QUIT" ; M: quit irc-command-string ( quit -- string ) drop "QUIT" ;
M: nick irc-command-string ( nick -- string ) drop "NICK" ;
M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ; M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ;
M: notice irc-command-string ( notice -- string ) drop "NOTICE" ; M: notice irc-command-string ( notice -- string ) drop "NOTICE" ;
M: mode irc-command-string ( mode -- string ) drop "MODE" ; M: mode irc-command-string ( mode -- string ) drop "MODE" ;
@ -46,6 +48,7 @@ M: ping irc-command-parameters ( ping -- seq ) drop { } ;
M: join irc-command-parameters ( join -- seq ) drop { } ; M: join irc-command-parameters ( join -- seq ) drop { } ;
M: part irc-command-parameters ( part -- seq ) name>> 1array ; M: part irc-command-parameters ( part -- seq ) name>> 1array ;
M: quit irc-command-parameters ( quit -- seq ) drop { } ; M: quit irc-command-parameters ( quit -- seq ) drop { } ;
M: nick irc-command-parameters ( nick -- seq ) drop { } ;
M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ; M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ;
M: notice irc-command-parameters ( norice -- seq ) type>> 1array ; M: notice irc-command-parameters ( norice -- seq ) type>> 1array ;
M: kick irc-command-parameters ( kick -- seq ) M: kick irc-command-parameters ( kick -- seq )
@ -110,6 +113,7 @@ PRIVATE>
{ "353" [ names-reply ] } { "353" [ names-reply ] }
{ "JOIN" [ join ] } { "JOIN" [ join ] }
{ "PART" [ part ] } { "PART" [ part ] }
{ "NICK" [ nick ] }
{ "PRIVMSG" [ privmsg ] } { "PRIVMSG" [ privmsg ] }
{ "QUIT" [ quit ] } { "QUIT" [ quit ] }
{ "MODE" [ mode ] } { "MODE" [ mode ] }

View File

@ -5,7 +5,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables sequences strings hashtables splitting fry assocs hashtables
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
io io.styles namespaces calendar calendar.format models continuations io io.styles namespaces calendar calendar.format models continuations
irc.client irc.client.private irc.messages irc.messages.private irc.client irc.client.private irc.messages irc.messages.private
irc.ui.commandparser irc.ui.load qualified ; irc.ui.commandparser irc.ui.load qualified ;
@ -20,7 +20,7 @@ SYMBOL: client
TUPLE: ui-window client tabs ; TUPLE: ui-window client tabs ;
TUPLE: irc-tab < frame listener client listmodel ; TUPLE: irc-tab < frame listener client userlist ;
: write-color ( str color -- ) : write-color ( str color -- )
foreground associate format ; foreground associate format ;
@ -116,16 +116,15 @@ M: irc-message write-irc
GENERIC: handle-inbox ( tab message -- ) GENERIC: handle-inbox ( tab message -- )
: filter-participants ( assoc val -- alist ) : filter-participants ( pack alist val color -- )
[ >alist ] dip '[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;
'[ second , = ] filter ;
: update-participants ( tab -- ) : update-participants ( tab -- )
[ listmodel>> ] [ listener>> participants>> ] bi [ userlist>> [ clear-gadget ] keep ]
[ +operator+ filter-participants ] [ listener>> participants>> ] bi
[ +voice+ filter-participants ] [ +operator+ green filter-participants ]
[ +normal+ filter-participants ] tri [ +voice+ blue filter-participants ]
append append swap set-model ; [ +normal+ black filter-participants ] 2tri ;
M: participant-changed handle-inbox M: participant-changed handle-inbox
drop update-participants ; drop update-participants ;
@ -162,11 +161,6 @@ irc-editor "general" f {
{ T{ key-down f f "ENTER" } editor-send } { T{ key-down f f "ENTER" } editor-send }
} define-command-map } define-command-map
: <irc-list> ( -- gadget model )
[ drop ]
[ first2 [ <label> ] dip >>color ]
{ } <model> [ <list> ] keep ;
: <irc-tab> ( listener client -- irc-tab ) : <irc-tab> ( listener client -- irc-tab )
irc-tab new-frame irc-tab new-frame
swap client>> >>client swap >>listener swap client>> >>client swap >>listener
@ -175,19 +169,19 @@ irc-editor "general" f {
: <irc-channel-tab> ( listener client -- irc-tab ) : <irc-channel-tab> ( listener client -- irc-tab )
<irc-tab> <irc-tab>
<irc-list> [ <scroller> @right grid-add ] dip >>listmodel <pile> [ <scroller> @right grid-add ] keep >>userlist ;
[ update-participants ] keep ;
: <irc-server-tab> ( listener client -- irc-tab ) : <irc-server-tab> ( listener client -- irc-tab )
<irc-tab> ; <irc-tab> ;
M: irc-tab graft* M: irc-tab graft*
[ listener>> ] [ client>> ] bi [ listener>> ] [ client>> ] bi add-listener ;
add-listener ;
M: irc-tab ungraft* M: irc-tab ungraft*
[ listener>> ] [ client>> ] bi [ listener>> ] [ client>> ] bi remove-listener ;
remove-listener ;
M: irc-tab pref-dim*
drop { 480 480 } ;
: join-channel ( name ui-window -- ) : join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip [ dup <irc-channel-listener> ] dip