Merge branch 'master' of git://factorforge.org/git/william42
commit
29ce373330
|
@ -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
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
|
@ -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 ] }
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue