scripts/signal.itcl

   1 # vim: foldmarker=<<<,>>>
   2
   3 class tlc::Signal {
   4         inherit tlc::Handlers tlc::Baselog
   5
   6         constructor {accessvar args} {}
   7         destructor {}
   8
   9         public {
  10                 variable name           ""
  11                 variable debugmode      0
  12                 variable output_handler_warntime        3000
  13
  14                 method state {}
  15                 method set_state {newstate}
  16                 method toggle_state {}
  17
  18                 method attach_output {handler {cleanup {}}}
  19                 method detach_output {handler}
  20
  21                 method name {}
  22                 method explain_txt {{depth 0}}
  23
  24                 method waitfor {sense {timeout 0}}
  25         }
  26
  27         protected {
  28                 variable outputs        {}
  29                 variable cleanups
  30                 variable o_state        0
  31                 variable afterids
  32                 variable changewait
  33                 variable seq            0
  34
  35                 method update_output {handler}
  36                 method update_outputs {}
  37                 method debug {level msg}
  38                 method _on_set_state {pending}
  39                 method throw_hissy {handler}
  40                 method scopevar_unset {args}
  41         }
  42 }
  43
  44
  45 configbody tlc::Signal::name { #<<<1
  46         set baselog_instancename        $name
  47 }
  48
  49
  50 body tlc::Signal::constructor {accessvar args} { #<<<1
  51         array set afterids              {}
  52         array set changewait    {}
  53
  54         eval configure $args
  55         upvar $accessvar scopevar
  56         set scopevar    $this
  57         #trace variable scopevar u [list delete object $this]
  58         trace variable scopevar u [code $this scopevar_unset]
  59 }
  60
  61
  62 body tlc::Signal::destructor {} { #<<<1
  63         debug debug "tlc::Signal::destructor: $this $name dieing"
  64         if {$debugmode} {
  65                 debug debug "tlc::Signal::destructor: $this dieing from:\n[tlc::stackdump]"
  66         }
  67         #trace vdelete scopevar u [code $this scopevar_unset]
  68         if {$debugmode} {
  69                 foreach {tag afterid} [array get afterids] {
  70                         after cancel $afterid
  71                         array unset afterids $tag
  72                 }
  73         }
  74         foreach output $outputs {
  75                 debug debug "tlc::Signal::destructor: ------ twitch: ($output)"
  76                 detach_output $output
  77         }
  78
  79         foreach key [array names changewait] {
  80                 debug debug "notifying waiting changewait($key) of our death"
  81                 set changewait($key)    "source_died"
  82         }
  83         debug debug "tlc::Signal::destructor: $this truely dead"
  84 }
  85
  86
  87 body tlc::Signal::state {} { #<<<1
  88         return $o_state
  89 }
  90
  91
  92 body tlc::Signal::set_state {newstate} { #<<<1
  93         if {![string is boolean -strict $newstate]} {
  94                 error "newstate must be a valid boolean" "" \
  95                                 [list not_a_boolean $newstate]
  96         }
  97         if {$newstate} {
  98                 set normstate   1
  99         } else {
 100                 set normstate   0
 101         }
 102         _on_set_state $normstate
 103         if {$o_state == $normstate} return
 104         set o_state     $normstate
 105         update_outputs
 106 }
 107
 108
 109 body tlc::Signal::toggle_state {} { #<<<1
 110         set_state [expr {!$o_state}]
 111 }
 112
 113
 114 body tlc::Signal::attach_output {handler {cleanup {}}} { #<<<1
 115         if {$handler in $outputs} {
 116                 return 0
 117         }
 118
 119         lappend outputs $handler
 120
 121         if {$cleanup != {}} {
 122                 set cleanups($handler)  $cleanup
 123         }
 124         update_output $handler
 125
 126         return 1
 127 }
 128
 129
 130 body tlc::Signal::detach_output {handler} { #<<<1
 131         debug debug "tlc::Signal::detach_output: ($handler)"
 132         if {$handler in $outputs} {
 133                 set idx                 [lsearch $outputs $handler]
 134                 set outputs             [lreplace $outputs $idx $idx]
 135
 136                 if {[info exists cleanups($handler)]} {
 137                         debug debug "tlc::Signal::detach_output: cleaning up ($handler)"
 138                         debug debug "tlc::Signal::detach_output: foo"
 139                         uplevel #0 $cleanups($handler)
 140                         debug debug "tlc::Signal::detach_output: bar"
 141                         unset cleanups($handler)
 142                 }
 143
 144                 return 1
 145         } else {
 146                 debug debug "tlc::Signal:detach_output: output not found!!\n($handler)\n[join $outputs \n]]\n============================="
 147                 return 0
 148         }
 149 }
 150
 151
 152 body tlc::Signal::update_output {handler} { #<<<1
 153         #puts stderr "Signal::update_output($o_state): $name ($this) update output ($handler)"
 154         if {$debugmode} {
 155                 set pending_afterid     [after $output_handler_warntime \
 156                                 [code $this throw_hissy $handler]]
 157                 set afterids(update_output_$handler)    $pending_afterid
 158         }
 159         if {[catch {
 160                 uplevel #0 $handler [list $o_state]
 161         } errmsg]} {
 162                 log error "\n\"$name\" error updating output ($o_state) handler: ($handler) $name ($this): $errmsg\n$::errorInfo"
 163         }
 164         if {$debugmode} {
 165                 after cancel $pending_afterid
 166                 array unset afterids    update_output_$handler
 167         }
 168         #puts stderr "Signal::update_output: $name ($this) done"
 169 }
 170
 171
 172 body tlc::Signal::update_outputs {} { #<<<1
 173         foreach output $outputs {
 174                 update_output $output
 175         }
 176         debug debug "tlc::Signal::update_outputs: Flagging changewaits: ([array names changewait])"
 177         foreach key [array names changewait] {
 178                 debug debug "tlc::Signal::update_outputs: flagging state change for waiting vwait: changewait($key) to ($o_state)"
 179                 set changewait($key)    $o_state
 180         }
 181 }
 182
 183
 184 body tlc::Signal::name {} { #<<<1
 185         return $name
 186 }
 187
 188
 189 body tlc::Signal::explain_txt {{depth 0}} { #<<<1
 190         return "[string repeat {  } $depth]$this \"[$this name]\": [$this state]\n"
 191 }
 192
 193
 194 body tlc::Signal::debug {level msg} { #<<<1
 195         invoke_handlers debug $level $msg
 196 }
 197
 198
 199 body tlc::Signal::_on_set_state {pending} { #<<<1
 200 }
 201
 202
 203 body tlc::Signal::throw_hissy {handler} { #<<<1
 204         log warning "name: ($name) obj: ($this) taking way too long to update output for handler: ($handler)"
 205 }
 206
 207
 208 body tlc::Signal::scopevar_unset {args} { #<<<1
 209         #puts stderr "Signal::scopevar_unset: $name ($this) scopevar unset"
 210         if {$debugmode} {
 211                 debug debug "tlc::Signal::scopevar_unset:\n[tlc::stackdump]"
 212         }
 213         log debug
 214         delete object $this
 215 }
 216
 217
 218 body tlc::Signal::waitfor {sense {timeout 0}} { #<<<1
 219         if {$sense} {
 220                 if {[state]} return
 221                 set normsense   1
 222         } else {
 223                 if {![state]} return
 224                 set normsense   0
 225         }
 226
 227         set signame     [name]
 228         set myseq       [incr seq]
 229
 230         if {$timeout != 0} {
 231                 set afterid \
 232                                 [after $timeout [list set [scope changewait($myseq)] "timeout"]]
 233                 set afterids(waitfor_$myseq)    $afterid
 234         }
 235
 236         debug debug "tlc::Signal::waitfor: Waiting for [scope changewait($myseq)]"
 237         set resolved    0
 238         while {!($resolved)} {
 239                 set changewait($myseq)  "waiting"
 240                 vwait [scope changewait($myseq)]
 241                 set res $changewait($myseq)
 242                 if {[string is boolean $res] && [state] != $normsense} {
 243                         log warning "Woken up by transient spike while waiting for state $sense, waiting for more permanent change"
 244                         set resolved    0
 245                 } else {
 246                         set resolved    1
 247                 }
 248         }
 249
 250         if {[info exists afterid]} {
 251                 after cancel $afterid
 252                 unset afterid
 253         }
 254
 255         if {$res != "source_died"} {
 256                 # in the case where we have died, these data members have disappeared,
 257                 # and to try to access them (like unsetting them) causes a segfault
 258
 259                 array unset afterids waitfor_$myseq
 260                 array unset changewait $myseq
 261         }
 262
 263         switch -- $res {
 264                 1 -
 265                 0 {
 266                         return
 267                 }
 268
 269                 "timeout" {
 270                         error "Timeout waiting for signal \"$signame\"" "" \
 271                                         [list timeout $signame]
 272                 }
 273
 274                 "source_died" {
 275                         error "Source died while waiting for signal \"$signame\"" "" \
 276                                         [list source_died $signame]
 277                 }
 278
 279                 default {
 280                         error "Unexpected result waiting for signal \"$signame\": ($res)"
 281                 }
 282         }
 283 }
 284
 285