basis/io/monitors/recursive/recursive.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors sequences assocs arrays continuations
   4 destructors combinators kernel threads concurrency.messaging
   5 concurrency.mailboxes concurrency.promises io.files io.files.info
   6 io.directories io.pathnames io.monitors debugger fry ;
   7 IN: io.monitors.recursive
   8
   9 ! Simulate recursive monitors on platforms that don't have them
  10
  11 TUPLE: recursive-monitor < monitor children thread ready ;
  12
  13 : notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ;
  14
  15 DEFER: add-child-monitor
  16
  17 : qualify-path ( path -- path' )
  18     monitor tget path>> prepend-path ;
  19
  20 : add-child-monitors ( path -- )
  21     #! We yield since this directory scan might take a while.
  22     dup [
  23         [ append-path ] with map
  24         [ add-child-monitor ] each yield
  25     ] with-directory-files ;
  26
  27 : add-child-monitor ( path -- )
  28     notify? [ dup { +add-file+ } monitor tget queue-change ] when
  29     qualify-path dup link-info directory? [
  30         [ add-child-monitors ]
  31         [
  32             '[
  33                 _ [ f my-mailbox (monitor) ] keep
  34                 monitor tget children>> set-at
  35             ] ignore-errors
  36         ] bi
  37     ] [ drop ] if ;
  38
  39 : remove-child-monitor ( monitor -- )
  40     monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
  41
  42 M: recursive-monitor dispose*
  43     [ "stop" swap thread>> send-synchronous drop ]
  44     [ queue>> dispose ]
  45     bi ;
  46
  47 : stop-pump ( -- )
  48     monitor tget children>> values dispose-each ;
  49
  50 : pump-step ( msg -- )
  51     [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
  52     monitor tget queue-change ;
  53
  54 : child-added ( path monitor -- )
  55     path>> prepend-path add-child-monitor ;
  56
  57 : child-removed ( path monitor -- )
  58     path>> prepend-path remove-child-monitor ;
  59
  60 : update-hierarchy ( msg -- )
  61     [ path>> ] [ monitor>> ] [ changed>> ] tri [
  62         {
  63             { +add-file+ [ child-added ] }
  64             { +remove-file+ [ child-removed ] }
  65             { +rename-file-old+ [ child-removed ] }
  66             { +rename-file-new+ [ child-added ] }
  67             [ 3drop ]
  68         } case
  69     ] with with each ;
  70
  71 : pump-loop ( -- )
  72     receive dup synchronous? [
  73         [ stop-pump t ] dip reply-synchronous
  74     ] [
  75         [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
  76         pump-loop
  77     ] if ;
  78
  79 : monitor-ready ( error/t -- )
  80     monitor tget ready>> fulfill ;
  81
  82 : pump-thread ( monitor -- )
  83     monitor tset
  84     [ "" add-child-monitor t monitor-ready ]
  85     [ [ self <linked-error> monitor-ready ] keep rethrow ]
  86     recover
  87     pump-loop ;
  88
  89 : start-pump-thread ( monitor -- )
  90     dup '[ _ pump-thread ]
  91     "Recursive monitor pump" spawn
  92     >>thread drop ;
  93
  94 : wait-for-ready ( monitor -- )
  95     ready>> ?promise ?linked drop ;
  96
  97 : <recursive-monitor> ( path mailbox -- monitor )
  98     [ (normalize-path) ] dip
  99     recursive-monitor new-monitor
 100         H{ } clone >>children
 101         <promise> >>ready
 102     dup start-pump-thread
 103     dup wait-for-ready ;