109 lines
3.0 KiB
Factor
Executable File
109 lines
3.0 KiB
Factor
Executable File
! Copyright (C) 2008, 2010 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors sequences assocs arrays continuations
|
|
destructors combinators kernel threads concurrency.messaging
|
|
concurrency.mailboxes concurrency.promises io.files io.files.info
|
|
io.directories io.pathnames io.monitors io.monitors.private
|
|
debugger fry ;
|
|
IN: io.monitors.recursive
|
|
|
|
! Simulate recursive monitors on platforms that don't have them
|
|
|
|
TUPLE: recursive-monitor < monitor children thread ready ;
|
|
|
|
: notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ;
|
|
|
|
DEFER: add-child-monitor
|
|
|
|
: qualify-path ( path -- path' )
|
|
monitor tget path>> prepend-path ;
|
|
|
|
: add-child-monitors ( path -- )
|
|
#! We yield since this directory scan might take a while.
|
|
dup [
|
|
[ append-path ] with map
|
|
[ add-child-monitor ] each yield
|
|
] with-directory-files ;
|
|
|
|
: add-child-monitor ( path -- )
|
|
notify? [ dup { +add-file+ } monitor tget queue-change ] when
|
|
qualify-path dup link-info directory? [
|
|
[ add-child-monitors ]
|
|
[
|
|
'[
|
|
_ [ f my-mailbox (monitor) ] keep
|
|
monitor tget children>> set-at
|
|
] ignore-errors
|
|
] bi
|
|
] [ drop ] if ;
|
|
|
|
: remove-child-monitor ( monitor -- )
|
|
monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
|
|
|
|
SYMBOL: +stop+
|
|
|
|
M: recursive-monitor dispose*
|
|
[ [ +stop+ ] dip thread>> send ] [ call-next-method ] bi ;
|
|
|
|
: stop-pump ( -- )
|
|
monitor tget children>> values dispose-each ;
|
|
|
|
: pump-step ( msg -- )
|
|
monitor tget disposed>> [ drop ] [
|
|
[ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
|
|
monitor tget queue-change
|
|
] if ;
|
|
|
|
: child-added ( path monitor -- )
|
|
path>> prepend-path add-child-monitor ;
|
|
|
|
: child-removed ( path monitor -- )
|
|
path>> prepend-path remove-child-monitor ;
|
|
|
|
: update-hierarchy ( msg -- )
|
|
[ path>> ] [ monitor>> ] [ changed>> ] tri [
|
|
{
|
|
{ +add-file+ [ child-added ] }
|
|
{ +remove-file+ [ child-removed ] }
|
|
{ +rename-file-old+ [ child-removed ] }
|
|
{ +rename-file-new+ [ child-added ] }
|
|
[ 3drop ]
|
|
} case
|
|
] with with each ;
|
|
|
|
: pump-loop ( -- )
|
|
receive {
|
|
{ [ dup +stop+ eq? ] [ drop stop-pump ] }
|
|
{ [ dup monitor-disposed eq? ] [ drop ] }
|
|
[
|
|
[ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
|
|
pump-loop
|
|
]
|
|
} cond ;
|
|
|
|
: monitor-ready ( error/t -- )
|
|
monitor tget ready>> fulfill ;
|
|
|
|
: pump-thread ( monitor -- )
|
|
monitor tset
|
|
[ "" add-child-monitor t monitor-ready ]
|
|
[ [ self <linked-error> monitor-ready ] keep rethrow ]
|
|
recover
|
|
pump-loop ;
|
|
|
|
: start-pump-thread ( monitor -- )
|
|
dup '[ _ pump-thread ]
|
|
"Recursive monitor pump" spawn
|
|
>>thread drop ;
|
|
|
|
: wait-for-ready ( monitor -- )
|
|
ready>> ?promise ?linked drop ;
|
|
|
|
: <recursive-monitor> ( path mailbox -- monitor )
|
|
[ absolute-path ] dip
|
|
recursive-monitor new-monitor
|
|
H{ } clone >>children
|
|
<promise> >>ready
|
|
dup start-pump-thread
|
|
dup wait-for-ready ;
|