home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / CorePackages / hook.tcl < prev    next >
Encoding:
Text File  |  1998-12-16  |  4.4 KB  |  162 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "hook.tcl"
  6.  #                                    created: 18/7/97 {5:10:18 pm} 
  7.  #                                last update: 16/12/1998 {2:11:48 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1998  Vince Darley, all rights reserved
  15.  #  
  16.  # Description: 
  17.  #  
  18.  #  Allows procedures to be registered and called at a specific time,
  19.  #  according to the current mode.  This means it is no longer necessary
  20.  #  or desireable to rename the standard hook procedures.  Previously
  21.  #  you had to do this:
  22.  #  
  23.  #   if {[info commands blahSaveHook] == ""} {
  24.  #       rename saveHook blahSaveHook
  25.  #       proc saveHook {name} { ... ; blahSaveHook $name}
  26.  #   }
  27.  # 
  28.  #  But now you just need to add a line like this to your code:
  29.  #  
  30.  #      hook::register 'hook-name' 'your proc' 'mode' ?... 'mode'?
  31.  # 
  32.  #  Here are two examples:
  33.  #  
  34.  #      hook::register savePostHook codeWarrior_modified "C++" "C"
  35.  #      hook::register savePostHook ftpPostHook
  36.  #  
  37.  #  If you don't include a 'mode', then your proc will be called no
  38.  #  matter what the current mode is.   Avoid this unless absolutely
  39.  #  necessary.  
  40.  #  
  41.  #  Use of such lists as 'savePostHooks' is obsolete.
  42.  #  These lists are ignored, use hook::register instead.
  43.  #  
  44.  #  History
  45.  # 
  46.  #  modified by  rev reason
  47.  #  -------- --- --- -----------
  48.  #  18/7/97  VMD 1.0 original
  49.  #  22/7/97  VMD 1.1 fixed all bugs ;-) and added the above examples.
  50.  # ###################################################################
  51.  ##
  52.  
  53. namespace eval hook {}
  54. set hook::version 1.0
  55.  
  56. proc hook::register {hook procname args} {
  57.     if {![llength $args]} {set args "*"}
  58.     namesp ::hook::${hook}
  59.     global hook::${hook}
  60.     foreach mode $args {
  61.     if {![info exists hook::${hook}($mode)] || \
  62.       [lsearch -exact [set hook::${hook}($mode)] $procname] == -1} {
  63.         lappend hook::${hook}($mode) $procname
  64.     }
  65.     }
  66. }
  67.  
  68. proc hook::list {{hook ""} {_mode ""}} {
  69.     if {$hook == ""} {
  70.     # just list the names of hooks which exist
  71.     set l [uplevel #0 {info vars hook::*}]
  72.     foreach a $l {
  73.         if {![uplevel #0 "array exists $a"]} {
  74.         set i [lsearch $l $a]
  75.         set l [lreplace $l $i $i]
  76.         }
  77.     }
  78.     regsub -all "hook::" $l "" l
  79.     return $l
  80.     } else {
  81.     global hook::${hook}
  82.     if {${_mode} == ""} {
  83.         # return all the attached procs for given hook
  84.         if {[array exists hook::$hook]} {
  85.         return [array get hook::${hook}]
  86.         } else {
  87.         return ""
  88.         }
  89.     } else {
  90.         if {[info exists hook::${hook}($_mode)]} {
  91.         return [set hook::${hook}($_mode)]
  92.         } else {
  93.         return ""
  94.         }
  95.     }
  96.     }
  97. }
  98.  
  99. proc hook::deregister {hook {procname ""} args} {
  100.     if {![llength $args]} {set args "*"}
  101.     namesp hook::${hook}
  102.     global hook::${hook}
  103.     if {$procname == ""} { 
  104.     # clear all hooks
  105.     unset hook::${hook} 
  106.     } else {        
  107.     foreach mode $args {
  108.         if {[info exists hook::${hook}($mode)] && \
  109.           [set i [lsearch -exact [set hook::${hook}($mode)] $procname]] != -1} {
  110.         set new [lreplace hook::${hook}($mode) $i $i]
  111.         if {$new != ""} {
  112.             set hook::${hook}($mode) $new
  113.         } else {
  114.             unset hook::${hook}($mode)
  115.         }
  116.         }
  117.     }
  118.     }
  119. }
  120.    
  121. if {[info tclversion] < 8.0} {
  122. proc hook::callAll {hook {_mode ""} args} {
  123.    if {[catch "global hook::${hook}"]} {return 0}
  124.    if {$_mode == ""} { global mode ; set _mode $mode }
  125.    set err 0
  126.    if {[info exists hook::${hook}(*)]} {
  127.         foreach proc [set hook::${hook}(*)] {
  128.             incr err [catch {uplevel \#0 [list eval $proc $args]}]
  129.         }
  130.    }
  131.    if {$_mode != "*" && [info exists hook::${hook}($_mode)]} {  
  132.         foreach proc [set hook::${hook}($_mode)] {
  133.             incr err [catch {uplevel \#0 [list eval $proc $args]}]
  134.         }
  135.    }
  136.    return $err
  137. }  
  138. } else {
  139.     proc hook::callAll {hook {_mode ""} args} {
  140.     if {[catch "global hook::${hook}"]} {return 0}
  141.     if {$_mode == ""} { global mode ; set _mode $mode }
  142.     set err 0
  143.     if {[info exists hook::${hook}(*)]} {
  144.         foreach proc [set hook::${hook}(*)] {
  145.         incr err [catch {uplevel \#0 [::list eval $proc $args]}]
  146.         }
  147.     }
  148.     if {$_mode != "*" && [info exists hook::${hook}($_mode)]} {  
  149.         foreach proc [set hook::${hook}($_mode)] {
  150.         incr err [catch {uplevel \#0 [::list eval $proc $args]}]
  151.         }
  152.     }
  153.     return $err
  154.     }  
  155. }
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.