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

db4
Doug Coleman 2008-08-13 23:40:37 -05:00
commit 867459e4c7
5 changed files with 69 additions and 58 deletions

View File

@ -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

View File

@ -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 ;
! ====================================== ! ======================================

View File

@ -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

View File

@ -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

View File

@ -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 ;