home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 November / CPNL0711.ISO / beeld / teken / scribus-1.3.3.9-win32-install.exe / tcl / tix8.1 / Event.tcl < prev    next >
Text File  |  2001-11-03  |  6KB  |  245 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: Event.tcl,v 1.3.2.1 2001/11/03 06:43:50 idiscovery Exp $
  4. #
  5. # Event.tcl --
  6. #
  7. #    Handles the event bindings of the -command and -browsecmd options
  8. #    (and various of others such as -validatecmd).
  9. #
  10. # Copyright (c) 1993-1999 Ioi Kim Lam.
  11. # Copyright (c) 2000-2001 Tix Project Group.
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16.  
  17. #----------------------------------------------------------------------
  18. # Evaluate high-level bindings (-command, -browsecmd, etc):
  19. # with % subsitution or without (compatibility mode)
  20. #
  21. #
  22. # BUG : if a -command is intercepted by a hook, the hook must use
  23. #       the same record name as the issuer of the -command. For the time
  24. #    being, you must use the name "bind" as the record name!!!!!
  25. #
  26. #----------------------------------------------------------------------
  27. set _tix_event_flags ""
  28. append _tix_event_flags " %%"
  29. append _tix_event_flags " %#"
  30. #append _tix_event_flags " %a"
  31. append _tix_event_flags " %b"
  32. append _tix_event_flags " %c"
  33. append _tix_event_flags " %d"
  34. append _tix_event_flags " %f"
  35. append _tix_event_flags " %h"
  36. append _tix_event_flags " %k"
  37. append _tix_event_flags " %m"
  38. append _tix_event_flags " %o"
  39. append _tix_event_flags " %p"
  40. append _tix_event_flags " %s"
  41. append _tix_event_flags " %t"
  42. append _tix_event_flags " %w"
  43. append _tix_event_flags " %x"
  44. append _tix_event_flags " %y"
  45. append _tix_event_flags " %A"
  46. append _tix_event_flags " %B"
  47. append _tix_event_flags " %E"
  48. append _tix_event_flags " %K"
  49. append _tix_event_flags " %N"
  50. append _tix_event_flags " %R"
  51. #append _tix_event_flags " %S"
  52. append _tix_event_flags " %T"
  53. append _tix_event_flags " %W"
  54. append _tix_event_flags " %X"
  55. append _tix_event_flags " %Y"
  56.  
  57. proc tixBind {tag event action} {
  58.     global _tix_event_flags
  59.  
  60.     append cmd "_tixRecordFlags $event $_tix_event_flags;"
  61.     append cmd "$action; "
  62.     append cmd "_tixDeleteFlags"
  63.  
  64.     bind $tag $event $cmd
  65. }
  66.  
  67. # This is a "name stack" for storing the "bind" structures
  68. #
  69. # The bottom of the event stack is usually a raw event (generated by tixBind)
  70. # but it may also be a programatically triggered (caused by tixEvalCmdBinding)
  71. #
  72. #
  73.  
  74. set tixEvent(nameStack)        ""
  75. set tixEvent(stackLevel)        0
  76.  
  77. proc tixPushEventStack {} {
  78.     global tixEvent
  79.  
  80.     set lastEvent [lindex $tixEvent(nameStack) 0]
  81.     incr tixEvent(stackLevel)
  82.     set thisEvent _tix_event$tixEvent(stackLevel)
  83.  
  84.     set tixEvent(nameStack) \
  85.     [list $thisEvent $tixEvent(nameStack)]
  86.  
  87.     if {$lastEvent == ""} {
  88.     upvar #0 $thisEvent this
  89.     set this(type) <Application>
  90.     } else {
  91.     upvar #0 $lastEvent last
  92.     upvar #0 $thisEvent this
  93.  
  94.     foreach name [array names last] {
  95.         set this($name) $last($name)
  96.     }
  97.     }
  98.  
  99.     return $thisEvent
  100. }
  101.  
  102. proc tixPopEventStack {varName} {
  103.     global tixEvent
  104.  
  105.     if {$varName != [lindex $tixEvent(nameStack) 0]} {
  106.     error "unmatched tixPushEventStack and tixPopEventStack calls"
  107.     }
  108.     incr tixEvent(stackLevel) -1
  109.     set tixEvent(nameStack) [lindex $tixEvent(nameStack) 1]
  110.     global $varName
  111.     unset $varName
  112. }
  113.  
  114.  
  115. # Events triggered by tixBind
  116. #
  117. proc _tixRecordFlags [concat event $_tix_event_flags] {
  118.     global _tix_event_flags
  119.  
  120.     set thisName [tixPushEventStack]; upvar #0 $thisName this
  121.  
  122.     set this(type) $event
  123.     foreach f $_tix_event_flags {
  124.     set this($f) [set $f]
  125.     }
  126. }
  127.  
  128. proc _tixDeleteFlags {} {
  129.     global tixEvent
  130.  
  131.     tixPopEventStack [lindex $tixEvent(nameStack) 0]
  132. }
  133.  
  134. # programatically trigged events
  135. #
  136. proc tixEvalCmdBinding {w cmd {subst ""} args} {
  137.     global tixPriv tixEvent tix
  138.  
  139.     set thisName [tixPushEventStack]; upvar #0 $thisName this
  140.  
  141.     if {$subst != ""} {
  142.     upvar $subst bind
  143.  
  144.     if {[info exists bind(specs)]} {
  145.         foreach spec $bind(specs) {
  146.         set this($spec) $bind($spec)
  147.         }
  148.     }
  149.     if {[info exists bind(type)]} {
  150.         set this(type) $bind(type)
  151.     }
  152.     }
  153.  
  154.     if [catch {
  155.     if {[tixGetBoolean -nocomplain $tix(-extracmdargs)]} {
  156.         # Compatibility mode
  157.         #
  158.         set ret [uplevel #0 $cmd $args]
  159.     } else {
  160.         set ret [uplevel $cmd]
  161.     }
  162.     } error] {
  163.     if [catch {
  164.         tixCmdErrorHandler $error
  165.     } error] {
  166.         # double fault: just print out 
  167.         tixBuiltInCmdErrorHandler $error
  168.     }
  169.     tixPopEventStack $thisName
  170.     return ""
  171.     } else {
  172.     tixPopEventStack $thisName
  173.  
  174.     return $ret
  175.     }
  176. }
  177.  
  178. proc tixEvent {option args} {
  179.     global tixPriv  tixEvent
  180.     set varName [lindex $tixEvent(nameStack) 0]
  181.  
  182.     if {$varName == ""} {
  183.     error "tixEvent called when no event is being processed"
  184.     } else {
  185.     upvar #0 $varName event
  186.     }
  187.  
  188.     case $option {
  189.     type {
  190.         return $event(type)
  191.     }
  192.     value {
  193.         if {[info exists event(%V)]} {
  194.         return $event(%V)
  195.         } else {
  196.         return ""
  197.         }
  198.     }
  199.     flag {
  200.         set f %[lindex $args 0]
  201.         if {[info exists event($f)]} {
  202.         return $event($f)
  203.         }
  204.         error "The flag \"[lindex $args 0]\" does not exist"
  205.     }
  206.     match {
  207.         return [string match [lindex $args 0] $event(type)]
  208.     }
  209.     default {
  210.         error "unknown option \"$option\""
  211.     }
  212.     }
  213. }
  214.  
  215. # tixBuiltInCmdErrorHandler --
  216. #
  217. #    Default method to report command handler errors. This procedure is
  218. #    also called if double-fault happens (command handler causes error,
  219. #    then tixCmdErrorHandler causes error).
  220. #
  221. proc tixBuiltInCmdErrorHandler {errorMsg} {
  222.     global errorInfo tcl_platform
  223.     if {![info exists errorInfo]} {
  224.     set errorInfo "???"
  225.     }
  226.     if {$tcl_platform(platform) == "windows"} then {
  227.     bgerror "Tix Error: $errorMsg"
  228.     } else {
  229.     puts "Error:\n $errorMsg\n$errorInfo"
  230.     }
  231. }
  232.  
  233. # tixCmdErrorHandler --
  234. #
  235. #    You can redefine this command to handle the errors that occur
  236. #    in the command handlers. See the programmer's documentation
  237. #    for details
  238. #
  239. if {![string compare [info command tixCmdErrorHandler] ""]} {
  240.     proc tixCmdErrorHandler {errorMsg} {
  241.     tixBuiltInCmdErrorHandler $errorMsg
  242.     }
  243. }
  244.  
  245.