basis/io/monitors/recursive/recursive.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators concurrency.mailboxes
   4 concurrency.messaging concurrency.promises continuations
   5 destructors io.directories io.files.info io.monitors
   6 io.monitors.private io.pathnames kernel sequences threads ;
   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     qualified-directory-files [ add-child-monitor ] each yield ;
  23
  24 : add-child-monitor ( path -- )
  25     notify? [ dup { +add-file+ } monitor tget queue-change ] when
  26     qualify-path dup link-info directory? [
  27         [ add-child-monitors ]
  28         [
  29             '[
  30                 _ [ f my-mailbox (monitor) ] keep
  31                 monitor tget children>> set-at
  32             ] ignore-errors
  33         ] bi
  34     ] [ drop ] if ;
  35
  36 : remove-child-monitor ( monitor -- )
  37     monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
  38
  39 SYMBOL: +stop+
  40
  41 M: recursive-monitor dispose*
  42     [ [ +stop+ ] dip thread>> send ] [ call-next-method ] bi ;
  43
  44 : stop-pump ( -- )
  45     monitor tget children>> values dispose-each ;
  46
  47 : pump-step ( msg -- )
  48     monitor tget disposed>> [ drop ] [
  49         [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
  50         monitor tget queue-change
  51     ] if ;
  52
  53 : child-added ( path monitor -- )
  54     path>> prepend-path add-child-monitor ;
  55
  56 : child-removed ( path monitor -- )
  57     path>> prepend-path remove-child-monitor ;
  58
  59 : update-hierarchy ( msg -- )
  60     [ path>> ] [ monitor>> ] [ changed>> ] tri [
  61         {
  62             { +add-file+ [ child-added ] }
  63             { +remove-file+ [ child-removed ] }
  64             { +rename-file-old+ [ child-removed ] }
  65             { +rename-file-new+ [ child-added ] }
  66             [ 3drop ]
  67         } case
  68     ] 2with each ;
  69
  70 : pump-loop ( -- )
  71     receive {
  72         { [ dup +stop+ eq? ] [ drop stop-pump ] }
  73         { [ dup monitor-disposed eq? ] [ drop ] }
  74         [
  75             [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
  76             pump-loop
  77         ]
  78     } cond ;
  79
  80 : monitor-ready ( error/t -- )
  81     monitor tget ready>> fulfill ;
  82
  83 : pump-thread ( monitor -- )
  84     monitor tset
  85     [ "" add-child-monitor t monitor-ready ]
  86     [ [ self <linked-error> monitor-ready ] keep rethrow ]
  87     recover
  88     pump-loop ;
  89
  90 : start-pump-thread ( monitor -- )
  91     dup '[ _ pump-thread ]
  92     "Recursive monitor pump" spawn
  93     >>thread drop ;
  94
  95 : wait-for-ready ( monitor -- )
  96     ready>> ?promise ?linked drop ;
  97
  98 : <recursive-monitor> ( path mailbox -- monitor )
  99     [
 100         [ absolute-path ] dip
 101         recursive-monitor new-monitor |dispose
 102             H{ } clone >>children
 103             <promise> >>ready
 104         dup start-pump-thread
 105         dup wait-for-ready
 106     ] with-destructors ;