77 lines
2.0 KiB
Factor
Executable File
77 lines
2.0 KiB
Factor
Executable File
! Copyright (C) 2008 Slava Pestov, Doug Coleman
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: kernel math system dlists namespaces assocs init threads
|
|
io.streams.duplex ;
|
|
IN: io.timeouts
|
|
|
|
TUPLE: lapse entry timeout cutoff ;
|
|
|
|
: <lapse> f 0 0 \ lapse construct-boa ;
|
|
|
|
! Won't need this with new slot accessors
|
|
GENERIC: get-lapse ( obj -- lapse )
|
|
|
|
GENERIC: set-timeout ( ms obj -- )
|
|
|
|
M: object set-timeout get-lapse set-timeout ;
|
|
|
|
M: lapse set-timeout set-lapse-timeout ;
|
|
|
|
: timeout ( obj -- ms ) get-lapse lapse-timeout ;
|
|
: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
|
|
: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
|
|
: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
|
|
: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
|
|
|
|
! Won't need this with inheritance
|
|
TUPLE: duplex-stream-lapse stream ;
|
|
|
|
M: duplex-stream-lapse set-timeout
|
|
duplex-stream-lapse-stream 2dup
|
|
duplex-stream-in set-timeout
|
|
duplex-stream-out set-timeout ;
|
|
|
|
M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
|
|
|
|
SYMBOL: timeout-queue
|
|
|
|
: timeout? ( lapse -- ? )
|
|
cutoff dup zero? not swap millis < and ;
|
|
|
|
timeout-queue global [ [ <dlist> ] unless* ] change-at
|
|
|
|
: unqueue-timeout ( obj -- )
|
|
entry [
|
|
timeout-queue get-global swap delete-node
|
|
] when* ;
|
|
|
|
: queue-timeout ( obj -- )
|
|
dup timeout-queue get-global push-front*
|
|
swap set-entry ;
|
|
|
|
GENERIC: timed-out ( obj -- )
|
|
|
|
M: object timed-out drop ;
|
|
|
|
: expire-timeouts ( -- )
|
|
timeout-queue get-global dup dlist-empty? [ drop ] [
|
|
dup peek-back timeout?
|
|
[ pop-back timed-out expire-timeouts ] [ drop ] if
|
|
] if ;
|
|
|
|
: begin-timeout ( obj -- )
|
|
dup timeout dup zero? [
|
|
2drop
|
|
] [
|
|
millis + over set-cutoff
|
|
dup unqueue-timeout queue-timeout
|
|
] if ;
|
|
|
|
: with-timeout ( obj quot -- )
|
|
over begin-timeout keep unqueue-timeout ; inline
|
|
|
|
: expiry-thread ( -- )
|
|
expire-timeouts 5000 sleep expiry-thread ;
|
|
|
|
[ [ expiry-thread ] in-thread ] "io.timeouts" add-init-hook
|