Merge branch 'master' of git://factorforge.org/git/william42
commit
867459e4c7
|
@ -49,10 +49,10 @@ M: mb-writer stream-nl ( mb-writer -- )
|
||||||
{ "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"
|
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||||
parse-irc-line irc-message-origin ] unit-test
|
parse-irc-line forward-name ] unit-test
|
||||||
|
|
||||||
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
|
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
|
||||||
parse-irc-line irc-message-origin ] unit-test
|
parse-irc-line forward-name ] unit-test
|
||||||
] with-irc
|
] with-irc
|
||||||
|
|
||||||
! Test login and nickname set
|
! Test login and nickname set
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
|
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
|
||||||
accessors destructors namespaces io assocs arrays qualified fry
|
accessors destructors namespaces io assocs arrays qualified fry
|
||||||
continuations threads strings classes combinators splitting hashtables
|
continuations threads strings classes combinators splitting hashtables
|
||||||
ascii irc.messages irc.messages.private ;
|
ascii irc.messages ;
|
||||||
RENAME: join sequences => sjoin
|
RENAME: join sequences => sjoin
|
||||||
EXCLUDE: sequences => join ;
|
EXCLUDE: sequences => join ;
|
||||||
IN: irc.client
|
IN: irc.client
|
||||||
|
@ -67,7 +67,6 @@ SINGLETON: irc-listener-end ! send to a listener to stop its execution
|
||||||
SINGLETON: irc-end ! sent when the client isn't running anymore
|
SINGLETON: irc-end ! sent when the client isn't running anymore
|
||||||
SINGLETON: irc-disconnected ! sent when connection is lost
|
SINGLETON: irc-disconnected ! sent when connection is lost
|
||||||
SINGLETON: irc-connected ! sent when connection is established
|
SINGLETON: irc-connected ! sent when connection is established
|
||||||
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
|
||||||
|
|
||||||
: terminate-irc ( irc-client -- )
|
: terminate-irc ( irc-client -- )
|
||||||
[ is-running>> ] keep and [
|
[ is-running>> ] keep and [
|
||||||
|
@ -122,6 +121,9 @@ M: irc-listener to-listener ( message irc-listener -- )
|
||||||
[ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
|
[ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
|
||||||
with filter ;
|
with filter ;
|
||||||
|
|
||||||
|
: to-listeners-with-participant ( message nickname -- )
|
||||||
|
listeners-with-participant [ to-listener ] with each ;
|
||||||
|
|
||||||
: remove-participant-from-all ( nick -- )
|
: remove-participant-from-all ( nick -- )
|
||||||
dup listeners-with-participant [ (remove-participant) ] with each ;
|
dup listeners-with-participant [ (remove-participant) ] with each ;
|
||||||
|
|
||||||
|
@ -145,7 +147,7 @@ M: irc-listener to-listener ( message irc-listener -- )
|
||||||
DEFER: me?
|
DEFER: me?
|
||||||
|
|
||||||
: maybe-forward-join ( join -- )
|
: maybe-forward-join ( join -- )
|
||||||
[ prefix>> parse-name me? ] keep and
|
[ irc-message-sender me? ] keep and
|
||||||
[ irc> join-messages>> mailbox-put ] when* ;
|
[ irc> join-messages>> mailbox-put ] when* ;
|
||||||
|
|
||||||
! ======================================
|
! ======================================
|
||||||
|
@ -177,60 +179,64 @@ DEFER: me?
|
||||||
: me? ( string -- ? )
|
: me? ( string -- ? )
|
||||||
irc> profile>> nickname>> = ;
|
irc> profile>> nickname>> = ;
|
||||||
|
|
||||||
: irc-message-origin ( irc-message -- name )
|
GENERIC: forward-name ( irc-message -- name )
|
||||||
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
|
M: join forward-name ( join -- name ) trailing>> ;
|
||||||
|
M: part forward-name ( part -- name ) channel>> ;
|
||||||
|
M: kick forward-name ( kick -- name ) channel>> ;
|
||||||
|
M: mode forward-name ( mode -- name ) channel>> ;
|
||||||
|
M: privmsg forward-name ( privmsg -- name )
|
||||||
|
dup name>> me? [ irc-message-sender ] [ name>> ] if ;
|
||||||
|
|
||||||
: broadcast-message-to-listeners ( message -- )
|
UNION: single-forward join part kick mode privmsg ;
|
||||||
irc> listeners>> values [ to-listener ] with each ;
|
UNION: multiple-forward nick quit ;
|
||||||
|
UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
|
||||||
|
GENERIC: forward-message ( irc-message -- )
|
||||||
|
|
||||||
GENERIC: handle-incoming-irc ( irc-message -- )
|
M: irc-message forward-message ( irc-message -- )
|
||||||
|
|
||||||
M: irc-message handle-incoming-irc ( irc-message -- )
|
|
||||||
+server-listener+ listener> [ to-listener ] [ drop ] if* ;
|
+server-listener+ listener> [ to-listener ] [ drop ] if* ;
|
||||||
|
|
||||||
M: logged-in handle-incoming-irc ( logged-in -- )
|
M: single-forward forward-message ( forward-single -- )
|
||||||
|
dup forward-name to-listener ;
|
||||||
|
|
||||||
|
M: multiple-forward forward-message ( multiple-forward -- )
|
||||||
|
dup irc-message-sender to-listeners-with-participant ;
|
||||||
|
|
||||||
|
M: join forward-message ( join -- )
|
||||||
|
[ maybe-forward-join ] [ call-next-method ] bi ;
|
||||||
|
|
||||||
|
M: broadcast-forward forward-message ( irc-broadcasted-message -- )
|
||||||
|
irc> listeners>> values [ to-listener ] with each ;
|
||||||
|
|
||||||
|
GENERIC: process-message ( irc-message -- )
|
||||||
|
|
||||||
|
M: object process-message ( object -- )
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
M: logged-in process-message ( logged-in -- )
|
||||||
name>> irc> profile>> (>>nickname) ;
|
name>> irc> profile>> (>>nickname) ;
|
||||||
|
|
||||||
M: ping handle-incoming-irc ( ping -- )
|
M: ping process-message ( ping -- )
|
||||||
trailing>> /PONG ;
|
trailing>> /PONG ;
|
||||||
|
|
||||||
M: nick-in-use handle-incoming-irc ( nick-in-use -- )
|
M: nick-in-use process-message ( nick-in-use -- )
|
||||||
name>> "_" append /NICK ;
|
name>> "_" append /NICK ;
|
||||||
|
|
||||||
M: privmsg handle-incoming-irc ( privmsg -- )
|
M: join process-message ( join -- )
|
||||||
dup irc-message-origin to-listener ;
|
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
|
||||||
|
|
||||||
M: join handle-incoming-irc ( join -- )
|
M: part process-message ( part -- )
|
||||||
[ maybe-forward-join ]
|
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
|
||||||
[ dup trailing>> to-listener ]
|
|
||||||
[ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
|
|
||||||
tri ;
|
|
||||||
|
|
||||||
M: part handle-incoming-irc ( part -- )
|
M: kick process-message ( kick -- )
|
||||||
[ dup channel>> to-listener ]
|
|
||||||
[ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
|
|
||||||
bi ;
|
|
||||||
|
|
||||||
M: kick handle-incoming-irc ( kick -- )
|
|
||||||
[ dup channel>> to-listener ]
|
|
||||||
[ [ who>> ] [ channel>> ] bi remove-participant ]
|
[ [ who>> ] [ channel>> ] bi remove-participant ]
|
||||||
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
|
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
|
||||||
tri ;
|
|
||||||
|
|
||||||
M: quit handle-incoming-irc ( quit -- )
|
|
||||||
[ dup prefix>> parse-name listeners-with-participant
|
|
||||||
[ to-listener ] with each ]
|
|
||||||
[ prefix>> parse-name remove-participant-from-all ]
|
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list
|
M: quit process-message ( quit -- )
|
||||||
dup channel>> to-listener ;
|
irc-message-sender remove-participant-from-all ;
|
||||||
|
|
||||||
M: nick handle-incoming-irc ( nick -- )
|
M: nick process-message ( nick -- )
|
||||||
[ dup prefix>> parse-name listeners-with-participant
|
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
|
||||||
[ to-listener ] with each ]
|
|
||||||
[ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ]
|
|
||||||
bi ;
|
|
||||||
|
|
||||||
: >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 ;
|
||||||
|
@ -239,22 +245,20 @@ M: nick handle-incoming-irc ( nick -- )
|
||||||
trailing>> [ blank? ] trim " " split
|
trailing>> [ blank? ] trim " " split
|
||||||
[ >nick/mode 2array ] map >hashtable ;
|
[ >nick/mode 2array ] map >hashtable ;
|
||||||
|
|
||||||
M: names-reply handle-incoming-irc ( names-reply -- )
|
M: names-reply process-message ( names-reply -- )
|
||||||
[ names-reply>participants ] [ channel>> listener> ] bi [
|
[ names-reply>participants ] [ channel>> listener> ] bi [
|
||||||
[ (>>participants) ]
|
[ (>>participants) ]
|
||||||
[ [ f f f <participant-changed> ] dip name>> to-listener ] bi
|
[ [ f f f <participant-changed> ] dip name>> to-listener ] bi
|
||||||
] [ drop ] if* ;
|
] [ drop ] if* ;
|
||||||
|
|
||||||
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
|
: handle-incoming-irc ( irc-message -- )
|
||||||
broadcast-message-to-listeners ;
|
[ forward-message ] [ process-message ] bi ;
|
||||||
|
|
||||||
! ======================================
|
! ======================================
|
||||||
! Client message handling
|
! Client message handling
|
||||||
! ======================================
|
! ======================================
|
||||||
|
|
||||||
GENERIC: handle-outgoing-irc ( obj -- )
|
: handle-outgoing-irc ( irc-message -- )
|
||||||
|
|
||||||
M: irc-message handle-outgoing-irc ( irc-message -- )
|
|
||||||
irc-message>client-line irc-print ;
|
irc-message>client-line irc-print ;
|
||||||
|
|
||||||
! ======================================
|
! ======================================
|
||||||
|
|
|
@ -3,7 +3,9 @@ USING: kernel tools.test accessors arrays qualified
|
||||||
EXCLUDE: sequences => join ;
|
EXCLUDE: sequences => join ;
|
||||||
IN: irc.messages.tests
|
IN: irc.messages.tests
|
||||||
|
|
||||||
! Parsing tests
|
|
||||||
|
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
|
||||||
|
|
||||||
irc-message new
|
irc-message new
|
||||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||||
"someuser!n=user@some.where" >>prefix
|
"someuser!n=user@some.where" >>prefix
|
||||||
|
|
|
@ -98,6 +98,11 @@ M: irc-message irc-message>server-line ( irc-message -- string )
|
||||||
|
|
||||||
PRIVATE>
|
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 )
|
: string>irc-message ( string -- object )
|
||||||
dup split-prefix split-trailing
|
dup split-prefix split-trailing
|
||||||
[ [ blank? ] trim " " split unclip swap ] dip
|
[ [ blank? ] trim " " split unclip swap ] dip
|
||||||
|
|
|
@ -8,7 +8,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
|
||||||
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
|
||||||
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.ui.commandparser irc.ui.load ;
|
irc.ui.commandparser irc.ui.load ;
|
||||||
|
|
||||||
RENAME: join sequences => sjoin
|
RENAME: join sequences => sjoin
|
||||||
|
@ -21,7 +21,7 @@ SYMBOL: client
|
||||||
|
|
||||||
TUPLE: ui-window < tabbed client ;
|
TUPLE: ui-window < tabbed client ;
|
||||||
|
|
||||||
TUPLE: irc-tab < frame listener client window userlist ;
|
TUPLE: irc-tab < frame listener client window ;
|
||||||
|
|
||||||
: write-color ( str color -- )
|
: write-color ( str color -- )
|
||||||
foreground associate format ;
|
foreground associate format ;
|
||||||
|
@ -39,7 +39,7 @@ M: ping write-irc
|
||||||
|
|
||||||
M: privmsg write-irc
|
M: privmsg write-irc
|
||||||
"<" blue write-color
|
"<" blue write-color
|
||||||
[ prefix>> parse-name write ] keep
|
[ irc-message-sender write ] keep
|
||||||
"> " blue write-color
|
"> " blue write-color
|
||||||
trailing>> write ;
|
trailing>> write ;
|
||||||
|
|
||||||
|
@ -61,24 +61,24 @@ M: own-message write-irc
|
||||||
|
|
||||||
M: join write-irc
|
M: join write-irc
|
||||||
"* " dark-green write-color
|
"* " dark-green write-color
|
||||||
prefix>> parse-name write
|
irc-message-sender write
|
||||||
" has entered the channel." dark-green write-color ;
|
" has entered the channel." dark-green write-color ;
|
||||||
|
|
||||||
M: part write-irc
|
M: part write-irc
|
||||||
"* " dark-red write-color
|
"* " dark-red write-color
|
||||||
[ prefix>> parse-name write ] keep
|
[ irc-message-sender write ] keep
|
||||||
" has left the channel" dark-red write-color
|
" has left the channel" dark-red write-color
|
||||||
trailing>> dot-or-parens dark-red write-color ;
|
trailing>> dot-or-parens dark-red write-color ;
|
||||||
|
|
||||||
M: quit write-irc
|
M: quit write-irc
|
||||||
"* " dark-red write-color
|
"* " dark-red write-color
|
||||||
[ prefix>> parse-name write ] keep
|
[ irc-message-sender write ] keep
|
||||||
" has left IRC" dark-red write-color
|
" has left IRC" dark-red write-color
|
||||||
trailing>> dot-or-parens dark-red write-color ;
|
trailing>> dot-or-parens dark-red write-color ;
|
||||||
|
|
||||||
M: kick write-irc
|
M: kick write-irc
|
||||||
"* " dark-red write-color
|
"* " dark-red write-color
|
||||||
[ prefix>> parse-name write ] keep
|
[ irc-message-sender write ] keep
|
||||||
" has kicked " dark-red write-color
|
" has kicked " dark-red write-color
|
||||||
[ who>> write ] keep
|
[ who>> write ] keep
|
||||||
" from the channel" dark-red write-color
|
" from the channel" dark-red write-color
|
||||||
|
@ -89,7 +89,7 @@ M: kick write-irc
|
||||||
|
|
||||||
M: mode write-irc
|
M: mode write-irc
|
||||||
"* " blue write-color
|
"* " blue write-color
|
||||||
[ prefix>> parse-name write ] keep
|
[ irc-message-sender write ] keep
|
||||||
" has applied mode " blue write-color
|
" has applied mode " blue write-color
|
||||||
[ full-mode write ] keep
|
[ full-mode write ] keep
|
||||||
" to " blue write-color
|
" to " blue write-color
|
||||||
|
@ -97,7 +97,7 @@ M: mode write-irc
|
||||||
|
|
||||||
M: nick write-irc
|
M: nick write-irc
|
||||||
"* " blue write-color
|
"* " blue write-color
|
||||||
[ prefix>> parse-name write ] keep
|
[ irc-message-sender write ] keep
|
||||||
" is now known as " blue write-color
|
" is now known as " blue write-color
|
||||||
trailing>> write ;
|
trailing>> write ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue