! 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 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 ; : ( path mailbox -- monitor ) [ absolute-path ] dip recursive-monitor new-monitor H{ } clone >>children >>ready dup start-pump-thread dup wait-for-ready ;