home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / itcl.tcl < prev    next >
Text File  |  2003-09-01  |  5KB  |  145 lines
  1. #
  2. # itcl.tcl
  3. # ----------------------------------------------------------------------
  4. # Invoked automatically upon startup to customize the interpreter
  5. # for [incr Tcl].
  6. # ----------------------------------------------------------------------
  7. #   AUTHOR:  Michael J. McLennan
  8. #            Bell Labs Innovations for Lucent Technologies
  9. #            mmclennan@lucent.com
  10. #            http://www.tcltk.com/itcl
  11. #
  12. #      RCS:  $Id: itcl.tcl,v 1.4 2001/04/14 21:35:54 davygrvy Exp $
  13. # ----------------------------------------------------------------------
  14. #            Copyright (c) 1993-1998  Lucent Technologies, Inc.
  15. # ======================================================================
  16. # See the file "license.terms" for information on usage and
  17. # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  18.  
  19. proc ::itcl::delete_helper { name args } {
  20.     ::itcl::delete object $name
  21. }
  22.  
  23. # ----------------------------------------------------------------------
  24. #  USAGE:  local <className> <objName> ?<arg> <arg>...?
  25. #
  26. #  Creates a new object called <objName> in class <className>, passing
  27. #  the remaining <arg>'s to the constructor.  Unlike the usual
  28. #  [incr Tcl] objects, however, an object created by this procedure
  29. #  will be automatically deleted when the local call frame is destroyed.
  30. #  This command is useful for creating objects that should only remain
  31. #  alive until a procedure exits.
  32. # ----------------------------------------------------------------------
  33. proc ::itcl::local {class name args} {
  34.     set ptr [uplevel [list $class $name] $args]
  35.     uplevel [list set itcl-local-$ptr $ptr]
  36.     set cmd [uplevel namespace which -command $ptr]
  37.     uplevel [list trace variable itcl-local-$ptr u \
  38.         "::itcl::delete_helper $cmd"]
  39.     return $ptr
  40. }
  41.  
  42. # ----------------------------------------------------------------------
  43. # auto_mkindex
  44. # ----------------------------------------------------------------------
  45. # Define Itcl commands that will be recognized by the auto_mkindex
  46. # parser in Tcl...
  47. #
  48.  
  49. #
  50. # USAGE:  itcl::class name body
  51. # Adds an entry for the given class declaration.
  52. #
  53. foreach cmd {itcl::class itcl_class} {
  54.     auto_mkindex_parser::command $cmd {name body} {
  55.         variable index
  56.         variable scriptFile
  57.         append index "set [list auto_index([fullname $name])]"
  58.         append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  59.  
  60.         variable parser
  61.         variable contextStack
  62.         set contextStack [linsert $contextStack 0 $name]
  63.         $parser eval $body
  64.         set contextStack [lrange $contextStack 1 end]
  65.     }
  66. }
  67.  
  68. #
  69. # USAGE:  itcl::body name arglist body
  70. # Adds an entry for the given method/proc body.
  71. #
  72. auto_mkindex_parser::command itcl::body {name arglist body} {
  73.     variable index
  74.     variable scriptFile
  75.     append index "set [list auto_index([fullname $name])]"
  76.     append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  77. }
  78.  
  79. #
  80. # USAGE:  itcl::configbody name arglist body
  81. # Adds an entry for the given method/proc body.
  82. #
  83. auto_mkindex_parser::command itcl::configbody {name body} {
  84.     variable index
  85.     variable scriptFile
  86.     append index "set [list auto_index([fullname $name])]"
  87.     append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  88. }
  89.  
  90. #
  91. # USAGE:  ensemble name ?body?
  92. # Adds an entry to the auto index list for the given ensemble name.
  93. #
  94. auto_mkindex_parser::command itcl::ensemble {name {body ""}} {
  95.     variable index
  96.     variable scriptFile
  97.     append index "set [list auto_index([fullname $name])]"
  98.     append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  99. }
  100.  
  101. #
  102. # USAGE:  public arg ?arg arg...?
  103. #         protected arg ?arg arg...?
  104. #         private arg ?arg arg...?
  105. #
  106. # Evaluates the arguments as commands, so we can recognize proc
  107. # declarations within classes.
  108. #
  109. foreach cmd {public protected private} {
  110.     auto_mkindex_parser::command $cmd {args} {
  111.         variable parser
  112.         $parser eval $args
  113.     }
  114. }
  115.  
  116. # ----------------------------------------------------------------------
  117. # auto_import
  118. # ----------------------------------------------------------------------
  119. # This procedure overrides the usual "auto_import" function in the
  120. # Tcl library.  It is invoked during "namespace import" to make see
  121. # if the imported commands reside in an autoloaded library.  If so,
  122. # stubs are created to represent the commands.  Executing a stub
  123. # later on causes the real implementation to be autoloaded.
  124. #
  125. # Arguments -
  126. # pattern    The pattern of commands being imported (like "foo::*")
  127. #               a canonical namespace as returned by [namespace current]
  128.  
  129. proc auto_import {pattern} {
  130.     global auto_index
  131.  
  132.     set ns [uplevel namespace current]
  133.     set patternList [auto_qualify $pattern $ns]
  134.  
  135.     auto_load_index
  136.  
  137.     foreach pattern $patternList {
  138.         foreach name [array names auto_index $pattern] {
  139.             if {"" == [info commands $name]} {
  140.                 ::itcl::import::stub create $name
  141.             }
  142.         }
  143.     }
  144. }
  145.