home *** CD-ROM | disk | FTP | other *** search
/ Practical Programming in Tcl & Tk (4th Edition) / TCLBOOK4.BIN / pc / exsource / 19_11.tcl < prev    next >
Text File  |  2003-04-16  |  2KB  |  85 lines
  1. #
  2. # Example 19-11
  3. # A safe after command.
  4. #
  5.  
  6. # SafeAfter_PolicyInit creates a child with 
  7. # a safe after command
  8.  
  9. proc SafeAfter_PolicyInit {slave max} {
  10.     # max limits the number of outstanding after events
  11.     global after
  12.     interp alias $slave after {} SafeAfterAlias $slave $max
  13.     interp alias $slave exit {} SafeAfterExitAlias $slave
  14.     # This is used to generate after IDs for the slave.
  15.     set after(id,$slave) 0
  16. }
  17.  
  18. # SafeAfterAlias is an alias for after. It disallows after
  19. # with only a time argument and no command.
  20.  
  21. proc SafeAfterAlias {slave max args} {
  22.     global after
  23.     set argc [llength $args]
  24.     if {$argc == 0} {
  25.         error "Usage: after option args"
  26.     }
  27.     switch -- [lindex $args 0] {
  28.         cancel {
  29.             # A naive implementation would just
  30.             # eval after cancel $args
  31.             # but something dangerous could be hiding in args.
  32.             set myid [lindex $args 1]
  33.             if {[info exists after(id,$slave,$myid)]} {
  34.                 set id $after(id,$slave,$myid)
  35.                 unset after(id,$slave,$myid)
  36.                 after cancel $id
  37.             }
  38.             return ""
  39.         }
  40.         default {
  41.             if {$argc == 1} {
  42.                 error "Usage: after time command args..."
  43.             }
  44.             if {[llength [array names after id,$slave,*]]\
  45.                     >= $max} {
  46.                 error "Too many after events"
  47.             }
  48.             # Maintain concat semantics
  49.             set command [concat [lrange $args 1 end]]
  50.             # Compute our own id to pass the callback.
  51.             set myid after#[incr after(id,$slave)]
  52.             set id [after [lindex $args 0] \
  53.                 [list SafeAfterCallback $slave $myid $command]]
  54.             set after(id,$slave,$myid) $id
  55.             return $myid
  56.         }
  57.     }
  58. }
  59.  
  60. # SafeAfterCallback is the after callback in the master.
  61. # It evaluates its command in the safe interpreter.
  62.  
  63. proc SafeAfterCallback {slave myid cmd} {
  64.     global after
  65.     unset after(id,$slave,$myid)
  66.     if [catch {
  67.         interp eval $slave $cmd
  68.     } err] {
  69.         catch {interp eval $slave bgerror $error}
  70.     }
  71. }
  72.  
  73. # SafeAfterExitAlias is an alias for exit that does cleanup.
  74.  
  75. proc SafeAfterExitAlias {slave} {
  76.     global after
  77.     foreach id [array names after id,$slave,*] {
  78.         after cancel $after($id)
  79.         unset after($id)
  80.     }
  81.     interp delete $slave
  82. }
  83.  
  84.  
  85.