Merge branch 'master' of git://factorforge.org/git/william42
commit
305fbdc915
|
@ -160,7 +160,7 @@ IN: irc.client.tests
|
||||||
} cleave
|
} cleave
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Namelist notification
|
! Namelist change notification
|
||||||
{ T{ participant-changed f f f } } [
|
{ T{ participant-changed f f f } } [
|
||||||
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
|
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
|
||||||
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
|
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
|
||||||
|
@ -172,4 +172,19 @@ IN: irc.client.tests
|
||||||
[ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
|
[ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
|
||||||
[ terminate-irc ]
|
[ terminate-irc ]
|
||||||
} cleave
|
} cleave
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ T{ participant-changed f "somedude" +part+ } } [
|
||||||
|
{ ":somedude!n=user@isp.net QUIT" } make-client
|
||||||
|
{ [ "factorbot" set-nick ]
|
||||||
|
[ listeners>>
|
||||||
|
[ "#factortest" [ <irc-channel-listener>
|
||||||
|
H{ { "somedude" +normal+ } } clone >>participants ] keep
|
||||||
|
] dip set-at ]
|
||||||
|
[ connect-irc ]
|
||||||
|
[ drop 0.1 seconds sleep ]
|
||||||
|
[ listeners>> [ "#factortest" ] dip at
|
||||||
|
[ read-message drop ] [ read-message drop ] [ read-message ] tri ]
|
||||||
|
[ terminate-irc ]
|
||||||
|
} cleave
|
||||||
] unit-test
|
] unit-test
|
|
@ -88,10 +88,11 @@ SYMBOL: current-irc-client
|
||||||
: irc-stream> ( -- stream ) irc> stream>> ;
|
: irc-stream> ( -- stream ) irc> stream>> ;
|
||||||
: irc-write ( s -- ) irc-stream> stream-write ;
|
: irc-write ( s -- ) irc-stream> stream-write ;
|
||||||
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
|
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
|
||||||
|
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
|
||||||
: listener> ( name -- listener/f ) irc> listeners>> at ;
|
: listener> ( name -- listener/f ) irc> listeners>> at ;
|
||||||
|
|
||||||
: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
|
: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
|
||||||
[ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline
|
[ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
|
||||||
|
|
||||||
GENERIC: to-listener ( message obj -- )
|
GENERIC: to-listener ( message obj -- )
|
||||||
|
|
||||||
|
@ -147,24 +148,6 @@ DEFER: me?
|
||||||
"JOIN " irc-write
|
"JOIN " irc-write
|
||||||
[ [ " :" ] dip 3append ] when* irc-print ;
|
[ [ " :" ] dip 3append ] when* irc-print ;
|
||||||
|
|
||||||
: /PART ( channel text -- )
|
|
||||||
[ "PART " irc-write irc-write ] dip
|
|
||||||
" :" irc-write irc-print ;
|
|
||||||
|
|
||||||
: /KICK ( channel who -- )
|
|
||||||
[ "KICK " irc-write irc-write ] dip
|
|
||||||
" " irc-write irc-print ;
|
|
||||||
|
|
||||||
: /PRIVMSG ( nick line -- )
|
|
||||||
[ "PRIVMSG " irc-write irc-write ] dip
|
|
||||||
" :" irc-write irc-print ;
|
|
||||||
|
|
||||||
: /ACTION ( nick line -- )
|
|
||||||
[ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
|
|
||||||
|
|
||||||
: /QUIT ( text -- )
|
|
||||||
"QUIT :" irc-write irc-print ;
|
|
||||||
|
|
||||||
: /PONG ( text -- )
|
: /PONG ( text -- )
|
||||||
"PONG " irc-write irc-print ;
|
"PONG " irc-write irc-print ;
|
||||||
|
|
||||||
|
@ -240,10 +223,14 @@ M: kick handle-incoming-irc ( kick -- )
|
||||||
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 ]
|
||||||
[ prefix>> parse-name remove-participant-from-all ]
|
|
||||||
[ handle-participant-change ]
|
[ handle-participant-change ]
|
||||||
|
[ prefix>> parse-name remove-participant-from-all ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
|
! FIXME: implement this
|
||||||
|
! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
|
||||||
|
! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
|
||||||
|
|
||||||
: >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 ;
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
|
||||||
USING: accessors kernel threads combinators concurrency.mailboxes
|
USING: accessors kernel threads combinators concurrency.mailboxes
|
||||||
sequences strings hashtables splitting fry assocs hashtables
|
sequences strings hashtables splitting fry assocs hashtables colors
|
||||||
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.packs ui.gadgets.labels
|
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
|
||||||
|
@ -24,14 +24,8 @@ TUPLE: irc-tab < frame listener client userlist ;
|
||||||
|
|
||||||
: write-color ( str color -- )
|
: write-color ( str color -- )
|
||||||
foreground associate format ;
|
foreground associate format ;
|
||||||
: red { 0.5 0 0 1 } ;
|
: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
|
||||||
: green { 0 0.5 0 1 } ;
|
: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;
|
||||||
: blue { 0 0 1 1 } ;
|
|
||||||
: black { 0 0 0 1 } ;
|
|
||||||
|
|
||||||
: colors H{ { +operator+ { 0 0.5 0 1 } }
|
|
||||||
{ +voice+ { 0 0 1 1 } }
|
|
||||||
{ +normal+ { 0 0 0 1 } } } ;
|
|
||||||
|
|
||||||
: dot-or-parens ( string -- string )
|
: dot-or-parens ( string -- string )
|
||||||
dup empty? [ drop "." ]
|
dup empty? [ drop "." ]
|
||||||
|
@ -65,21 +59,21 @@ M: own-message write-irc
|
||||||
message>> write ;
|
message>> write ;
|
||||||
|
|
||||||
M: join write-irc
|
M: join write-irc
|
||||||
"* " green write-color
|
"* " dark-green write-color
|
||||||
prefix>> parse-name write
|
prefix>> parse-name write
|
||||||
" has entered the channel." green write-color ;
|
" has entered the channel." dark-green write-color ;
|
||||||
|
|
||||||
M: part write-irc
|
M: part write-irc
|
||||||
"* " red write-color
|
"* " dark-red write-color
|
||||||
[ prefix>> parse-name write ] keep
|
[ prefix>> parse-name write ] keep
|
||||||
" has left the channel" red write-color
|
" has left the channel" dark-red write-color
|
||||||
trailing>> dot-or-parens red write-color ;
|
trailing>> dot-or-parens dark-red write-color ;
|
||||||
|
|
||||||
M: quit write-irc
|
M: quit write-irc
|
||||||
"* " red write-color
|
"* " dark-red write-color
|
||||||
[ prefix>> parse-name write ] keep
|
[ prefix>> parse-name write ] keep
|
||||||
" has left IRC" red write-color
|
" has left IRC" dark-red write-color
|
||||||
trailing>> dot-or-parens red write-color ;
|
trailing>> dot-or-parens dark-red write-color ;
|
||||||
|
|
||||||
: full-mode ( message -- mode )
|
: full-mode ( message -- mode )
|
||||||
parameters>> rest " " sjoin ;
|
parameters>> rest " " sjoin ;
|
||||||
|
@ -97,13 +91,13 @@ M: unhandled write-irc
|
||||||
line>> blue write-color ;
|
line>> blue write-color ;
|
||||||
|
|
||||||
M: irc-end write-irc
|
M: irc-end write-irc
|
||||||
drop "* You have left IRC" red write-color ;
|
drop "* You have left IRC" dark-red write-color ;
|
||||||
|
|
||||||
M: irc-disconnected write-irc
|
M: irc-disconnected write-irc
|
||||||
drop "* Disconnected" red write-color ;
|
drop "* Disconnected" dark-red write-color ;
|
||||||
|
|
||||||
M: irc-connected write-irc
|
M: irc-connected write-irc
|
||||||
drop "* Connected" green write-color ;
|
drop "* Connected" dark-green write-color ;
|
||||||
|
|
||||||
M: irc-listener-end write-irc
|
M: irc-listener-end write-irc
|
||||||
drop ;
|
drop ;
|
||||||
|
@ -130,7 +124,7 @@ GENERIC: handle-inbox ( tab message -- )
|
||||||
: update-participants ( tab -- )
|
: update-participants ( tab -- )
|
||||||
[ userlist>> [ clear-gadget ] keep ]
|
[ userlist>> [ clear-gadget ] keep ]
|
||||||
[ listener>> participants>> ] bi
|
[ listener>> participants>> ] bi
|
||||||
[ +operator+ green filter-participants ]
|
[ +operator+ dark-green filter-participants ]
|
||||||
[ +voice+ blue filter-participants ]
|
[ +voice+ blue filter-participants ]
|
||||||
[ +normal+ black filter-participants ] tri drop ;
|
[ +normal+ black filter-participants ] tri drop ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue