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