scripts/domino.itcl

   1 # vim: foldmarker=<<<,>>>
   2
   3 class tlc::Domino {
   4         inherit tlc::Baselog
   5 #       inherit tlc::Handlers
   6
   7         constructor {accessvar args} {}
   8         destructor {}
   9
  10         public {
  11                 variable name   ""
  12
  13                 method tip {args}
  14                 method tip_now {args}
  15                 method attach_output {handler}
  16                 method detach_output {handler}
  17                 method attach_input {dom_obj}
  18                 method detach_input {dom_obj}
  19                 method pending {}
  20                 method force_if_pending {}
  21                 method lock {}
  22                 method unlock {}
  23         }
  24
  25         protected {
  26                 method debug {level msg}
  27                 method tip_outputs {}
  28         }
  29
  30         private {
  31                 variable after_id       ""
  32                 variable outputs {}
  33                 variable inputs
  34                 variable lock           0
  35
  36                 method scopevar_unset {args}
  37         }
  38 }
  39
  40
  41 configbody tlc::Domino::name { #<<<1
  42         set baselog_instancename        $name
  43 }
  44
  45
  46 body tlc::Domino::constructor {accessvar args} { #<<<1
  47         array set inputs {}
  48
  49         eval configure $args
  50
  51         if {$name == ""} {
  52                 set name        $accessvar
  53         }
  54
  55         upvar $accessvar scopevar
  56         set scopevar $this
  57         trace variable scopevar u [code $this scopevar_unset]
  58 }
  59
  60
  61 body tlc::Domino::destructor {} { #<<<1
  62         after cancel $after_id
  63         foreach dom_obj [array names inputs] {
  64                 detach_input $dom_obj
  65         }
  66 }
  67
  68
  69 body tlc::Domino::tip {args} { #<<<1
  70         if {$lock > 0} return
  71
  72         if {$after_id != ""} return
  73         debug debug "tlc::Domino::tip: ($this) ($name)"
  74         set after_id    [after idle [code $this tip_outputs]]
  75 }
  76
  77
  78 body tlc::Domino::tip_now {args} { #<<<1
  79         tip_outputs
  80 }
  81
  82
  83 body tlc::Domino::attach_output {handler} { #<<<1
  84         set idx         [lsearch $outputs $handler]
  85         if {$idx == -1} {
  86                 lappend outputs $handler
  87                 return 1
  88         } else {
  89                 return 0
  90         }
  91 }
  92
  93
  94 body tlc::Domino::detach_output {handler} { #<<<1
  95         set idx         [lsearch $outputs $handler]
  96         set outputs     [lreplace $outputs $idx $idx]
  97 }
  98
  99
 100 body tlc::Domino::tip_outputs {} { #<<<1
 101         after cancel $after_id
 102         set after_id    ""
 103         foreach output $outputs {
 104                 if {[catch {
 105                         uplevel #0 $output
 106                 } errmsg]} {
 107                         log error "\nerror updating output ($output):\n\t$errmsg\n$::errorInfo"
 108                 }
 109         }
 110 }
 111
 112
 113 body tlc::Domino::attach_input {dom_obj} { #<<<1
 114         if {![$dom_obj isa tlc::Domino]} {
 115                 error "$dom_obj isn't a Domino"
 116         }
 117
 118         set inputs($dom_obj)    1
 119
 120         return [$dom_obj attach_output [code $this tip]]
 121 }
 122
 123
 124 body tlc::Domino::detach_input {dom_obj} { #<<<1
 125         if {![$dom_obj isa tlc::Domino]} {
 126                 error "$dom_obj isn't a Domino"
 127         }
 128
 129         catch {unset inputs($dom_obj)}
 130
 131         return [$dom_obj detach_output [code $this tip]]
 132 }
 133
 134
 135 body tlc::Domino::debug {level msg} { #<<<1
 136 #       invoke_handlers debug $level $msg
 137 }
 138
 139
 140 body tlc::Domino::pending {} { #<<<1
 141         return [expr {$after_id != ""}]
 142 }
 143
 144
 145 body tlc::Domino::force_if_pending {} { #<<<1
 146         if {$after_id != ""} tip_now
 147 }
 148
 149
 150 body tlc::Domino::lock {} { #<<<1
 151         incr lock
 152 }
 153
 154
 155 body tlc::Domino::unlock {} { #<<<1
 156         incr lock -1
 157         if {$lock < 0} {
 158                 puts stderr "$this lock went below zero!: $lock\n[tlc::stackdump]"
 159         }
 160 }
 161
 162
 163 body tlc::Domino::scopevar_unset {args} { #<<<1
 164         log debug
 165         delete object $this
 166 }
 167
 168