basis/io/monitors/recursive/recursive.factor

   1 ! Copyright (C) 2008, 2010 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 io.monitors.private
   7 debugger fry ;
   8 IN: io.monitors.recursive
   9
  10 ! Simulate recursive monitors on platforms that don't have them
  11
  12 TUPLE: recursive-monitor < monitor children thread ready ;
  13
  14 : notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ;
  15
  16 DEFER: add-child-monitor
  17
  18 : qualify-path ( path -- path' )
  19     monitor tget path>> prepend-path ;
  20
  21 : add-child-monitors ( path -- )
  22     ! We yield since this directory scan might take a while.
  23     [
  24         [ add-child-monitor ] each yield
  25     ] with-qualified-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 SYMBOL: +stop+
  43
  44 M: recursive-monitor dispose*
  45     [ [ +stop+ ] dip thread>> send ] [ call-next-method ] bi ;
  46
  47 : stop-pump ( -- )
  48     monitor tget children>> values dispose-each ;
  49
  50 : pump-step ( msg -- )
  51     monitor tget disposed>> [ drop ] [
  52         [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
  53         monitor tget queue-change
  54     ] if ;
  55
  56 : child-added ( path monitor -- )
  57     path>> prepend-path add-child-monitor ;
  58
  59 : child-removed ( path monitor -- )
  60     path>> prepend-path remove-child-monitor ;
  61
  62 : update-hierarchy ( msg -- )
  63     [ path>> ] [ monitor>> ] [ changed>> ] tri [
  64         {
  65             { +add-file+ [ child-added ] }
  66             { +remove-file+ [ child-removed ] }
  67             { +rename-file-old+ [ child-removed ] }
  68             { +rename-file-new+ [ child-added ] }
  69             [ 3drop ]
  70         } case
  71     ] 2with each ;
  72
  73 : pump-loop ( -- )
  74     receive {
  75         { [ dup +stop+ eq? ] [ drop stop-pump ] }
  76         { [ dup monitor-disposed eq? ] [ drop ] }
  77         [
  78             [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
  79             pump-loop
  80         ]
  81     } cond ;
  82
  83 : monitor-ready ( error/t -- )
  84     monitor tget ready>> fulfill ;
  85
  86 : pump-thread ( monitor -- )
  87     monitor tset
  88     [ "" add-child-monitor t monitor-ready ]
  89     [ [ self <linked-error> monitor-ready ] keep rethrow ]
  90     recover
  91     pump-loop ;
  92
  93 : start-pump-thread ( monitor -- )
  94     dup '[ _ pump-thread ]
  95     "Recursive monitor pump" spawn
  96     >>thread drop ;
  97
  98 : wait-for-ready ( monitor -- )
  99     ready>> ?promise ?linked drop ;
 100
 101 : <recursive-monitor> ( path mailbox -- monitor )
 102     [
 103         [ absolute-path ] dip
 104         recursive-monitor new-monitor |dispose
 105             H{ } clone >>children
 106             <promise> >>ready
 107         dup start-pump-thread
 108         dup wait-for-ready
 109     ] with-destructors ;