steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-07-31 20:54:32 -05:00
parent 554247dab5 804a76afc8
commit 29ce373330
5 changed files with 117 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
extra/irc/client/client-tests.factor
View File

@ -43,7 +43,7 @@ IN: irc.client.tests
":some.where 001 factorbot :Welcome factorbot"
} make-client
{ [ connect-irc ]
[ drop 1 seconds sleep ]
[ drop 0.1 seconds sleep ]
[ profile>> nickname>> ]
[ terminate-irc ]
} cleave ] unit-test
@ -57,8 +57,8 @@ IN: irc.client.tests
} make-client
{ [ "factorbot" set-nick ]
[ connect-irc ]
[ drop 1 seconds sleep ]
[ join-messages>> 1 seconds mailbox-get-timeout ]
[ drop 0.1 seconds sleep ]
[ join-messages>> 0.1 seconds mailbox-get-timeout ]
[ terminate-irc ]
} cleave
[ class ] [ trailing>> ] bi ] unit-test
@ -101,3 +101,75 @@ IN: irc.client.tests
} cleave
[ class ] [ name>> ] [ trailing>> ] tri
] 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

23
extra/irc/client/client.factor
View File

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

12
extra/irc/messages/messages-tests.factor
View File

@ -40,8 +40,18 @@ mode new
"ircserver.net" >>prefix
"MODE" >>command
{ "#factortest" "+ns" } >>parameters
"#factortest" >>channel
"#factortest" >>channel
"+ns" >>mode
1array
[ ":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

4
extra/irc/messages/messages.factor
View File

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

36
extra/irc/ui/ui.factor
View File

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