scripts/handlers.itcl

   1 # vim: foldmarker=<<<,>>>
   2
   3 class tlc::Handlers {
   4         constructor {} {}
   5         destructor {}
   6
   7         public {
   8                 method register_handler {type handler}
   9                 method deregister_handler {type handler}
  10                 method handlers_available {type}
  11                 method dump_handlers {}
  12         }
  13
  14         protected {
  15                 variable allow_unregistered             1
  16
  17                 method invoke_handlers {type args}
  18                 method _debug {msg}
  19                 method handlers_debug {lvl msg}
  20         }
  21
  22         private {
  23                 variable handlers
  24                 variable afterids
  25                 variable processing_handlers    0
  26                 variable processing_stack               {}
  27
  28                 method throw_hissy_handler {handler arglist}
  29         }
  30 }
  31
  32
  33 body tlc::Handlers::constructor {} { #<<<1
  34         array set handlers      {}
  35         array set afterids      {}
  36 }
  37
  38
  39 body tlc::Handlers::destructor {} { #<<<1
  40         foreach {key val} [array names afterids] {
  41                 after cancel $val
  42                 array unset afterids $key
  43         }
  44 }
  45
  46
  47 body tlc::Handlers::register_handler {type handler} { #<<<1
  48         if {
  49                 ![info exists handlers($type)]
  50                 || [lsearch $handlers($type) $handler] == -1
  51         } {
  52                 handlers_debug trivia "Registering handler ($type) ($handler)"
  53                 lappend handlers($type) $handler
  54         }
  55 }
  56
  57
  58 body tlc::Handlers::deregister_handler {type handler} { #<<<1
  59         if {![info exists handlers($type)]} return
  60         set idx [lsearch $handlers($type) $handler]
  61 #       log trivia "$this Deregistering handler ($type) ($handler)"
  62         set handlers($type)     [lreplace $handlers($type) $idx $idx]
  63 }
  64
  65
  66 body tlc::Handlers::invoke_handlers {type args} { #<<<1
  67         if {![info exists handlers($type)]} {
  68                 if {$allow_unregistered} {
  69                         return
  70                 } else {
  71                         error "$this: No handlers found for type: ($type)"
  72                 }
  73         }
  74
  75         set results     {}
  76         if {$processing_handlers} {
  77                 handlers_debug debug "detected reentrant handling for ($type) stack: ($processing_stack)\n[tlc::stackdump]"
  78         }
  79         incr processing_handlers        1
  80         lappend processing_stack        $type
  81         set last_handler        ""
  82         tlc::try {
  83                 handlers_debug debug "entering processing of $type"
  84                 foreach handler $handlers($type) {
  85                         # Check if a previous handler removed this one <<<
  86                         if {
  87                                 ![info exists handlers($type)]
  88                                 ||[lsearch $handlers($type) $handler] == -1
  89                         } {
  90                                 handlers_debug debug "Skipping handler ($handler) which has just been removed (presumably by a previous handler in the list"
  91                                 continue
  92                         }
  93                         # Check if a previous handler removed this one >>>
  94                         set pending_afterid     \
  95                                         [after 3000 [code $this throw_hissy_handler $handler $args]]
  96                         set last_handler        $handler
  97                         set afterids(invoke_handler_$handler)   $pending_afterid
  98                         handlers_debug debug "Invoking callback for ($type): ($handler)"
  99                         lappend results [uplevel #0 $handler $args]
 100                         after cancel $pending_afterid
 101                         array unset afterids    invoke_handler_$handler
 102                 }
 103         } onok {
 104                 incr processing_handlers        -1
 105                 set processing_stack            [lrange $processing_stack 0 end-1]
 106                 handlers_debug debug "leaving processing of $type"
 107                 return $results
 108         } onerr {
 109                 default {
 110                         incr processing_handlers        -1
 111                         set processing_stack            [lrange $processing_stack 0 end-1]
 112                         handlers_debug error "\nError processing handlers for ($type), in handler ($last_handler): $errmsg\n$::errorInfo"
 113                         error "$errmsg while processing handler for ($type): ($last_handler)" $::errorInfo $::errorCode
 114                 }
 115         }
 116 }
 117
 118
 119 body tlc::Handlers::handlers_available {type} { #<<<1
 120         return [expr {[info exists handlers($type)] && [llength $handlers($type)] >= 1}]
 121 }
 122
 123
 124 body tlc::Handlers::dump_handlers {} { #<<<1
 125         return [array get handlers]
 126 }
 127
 128
 129 body tlc::Handlers::throw_hissy_handler {handler arglist} { #<<<1
 130         puts stderr "\n\nHandlers::throw_hissy: obj: ($this) taking way too long to complete invoke_handlers for handler: ($handler)\n\targs: ($arglist)\n\n"
 131 }
 132
 133
 134 body tlc::Handlers::handlers_debug {lvl msg} { #<<<1
 135         # Override in derived class
 136         switch -- $lvl {
 137                 warning -
 138                 error {
 139                         puts stderr "tlc::Handlers::handlers_debug($this): $lvl $msg"
 140                 }
 141         }
 142 }
 143
 144
 145 body tlc::Handlers::_debug {msg} { #<<<1
 146         return [handlers_debug debug $msg]
 147 }
 148
 149