irc.client: Improvments to thread management.
parent
62fdbfd671
commit
77e6f10ac3
|
@ -63,6 +63,7 @@ SYMBOL: +mode+
|
||||||
TUPLE: participant-changed nick action ;
|
TUPLE: participant-changed nick action ;
|
||||||
C: <participant-changed> participant-changed
|
C: <participant-changed> participant-changed
|
||||||
|
|
||||||
|
SINGLETON: irc-listener-end ! send to a listener to top 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
|
||||||
|
@ -85,7 +86,9 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
||||||
: 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 ;
|
||||||
: listener> ( name -- listener/f ) irc> listeners>> at ;
|
: listener> ( name -- listener/f ) irc> listeners>> at ;
|
||||||
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
|
|
||||||
|
: maybe-mailbox-get ( mailbox quot -- )
|
||||||
|
[ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline
|
||||||
|
|
||||||
GENERIC: to-listener ( message obj -- )
|
GENERIC: to-listener ( message obj -- )
|
||||||
|
|
||||||
|
@ -93,6 +96,12 @@ M: string to-listener ( message string -- )
|
||||||
listener> [ +server-listener+ listener> ] unless*
|
listener> [ +server-listener+ listener> ] unless*
|
||||||
[ to-listener ] [ drop ] if* ;
|
[ to-listener ] [ drop ] if* ;
|
||||||
|
|
||||||
|
: unregister-listener ( name -- )
|
||||||
|
irc> listeners>>
|
||||||
|
[ at [ irc-listener-end ] dip to-listener ]
|
||||||
|
[ delete-at ]
|
||||||
|
2bi ;
|
||||||
|
|
||||||
M: irc-listener to-listener ( message irc-listener -- )
|
M: irc-listener to-listener ( message irc-listener -- )
|
||||||
in-messages>> mailbox-put ;
|
in-messages>> mailbox-put ;
|
||||||
|
|
||||||
|
@ -291,18 +300,18 @@ DEFER: (connect-irc)
|
||||||
] if*
|
] if*
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: reader-loop ( -- )
|
: reader-loop ( -- ? )
|
||||||
[ (reader-loop) ] [ handle-disconnect ] recover ;
|
[ (reader-loop) ] [ handle-disconnect ] recover t ;
|
||||||
|
|
||||||
: writer-loop ( -- )
|
: writer-loop ( -- ? )
|
||||||
irc> out-messages>> mailbox-get handle-outgoing-irc ;
|
irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
|
||||||
|
|
||||||
! ======================================
|
! ======================================
|
||||||
! Processing loops
|
! Processing loops
|
||||||
! ======================================
|
! ======================================
|
||||||
|
|
||||||
: in-multiplexer-loop ( -- )
|
: in-multiplexer-loop ( -- ? )
|
||||||
irc> in-messages>> mailbox-get handle-incoming-irc ;
|
irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;
|
||||||
|
|
||||||
: strings>privmsg ( name string -- privmsg )
|
: strings>privmsg ( name string -- privmsg )
|
||||||
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
|
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
|
||||||
|
@ -314,12 +323,15 @@ DEFER: (connect-irc)
|
||||||
[ nip ]
|
[ nip ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: listener-loop ( name listener -- )
|
: listener-loop ( name -- ? )
|
||||||
out-messages>> mailbox-get maybe-annotate-with-name
|
dup listener> [
|
||||||
irc> out-messages>> mailbox-put ;
|
out-messages>> [ maybe-annotate-with-name
|
||||||
|
irc> out-messages>> mailbox-put ] with
|
||||||
|
maybe-mailbox-get t
|
||||||
|
] [ drop f ] if* ;
|
||||||
|
|
||||||
: spawn-irc-loop ( quot name -- )
|
: spawn-irc-loop ( quot name -- )
|
||||||
[ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip
|
[ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
|
||||||
spawn-server drop ;
|
spawn-server drop ;
|
||||||
|
|
||||||
: spawn-irc ( -- )
|
: spawn-irc ( -- )
|
||||||
|
@ -332,9 +344,8 @@ DEFER: (connect-irc)
|
||||||
! ======================================
|
! ======================================
|
||||||
|
|
||||||
: set+run-listener ( name irc-listener -- )
|
: set+run-listener ( name irc-listener -- )
|
||||||
[ '[ , , listener-loop ] "listener" spawn-irc-loop ]
|
over irc> listeners>> set-at
|
||||||
[ swap irc> listeners>> set-at ]
|
'[ , listener-loop ] "listener" spawn-irc-loop ;
|
||||||
2bi ;
|
|
||||||
|
|
||||||
GENERIC: (add-listener) ( irc-listener -- )
|
GENERIC: (add-listener) ( irc-listener -- )
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue