home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / comanche.exe / lib / itcl3.0 / itcl.tcl
Text File  |  1999-02-24  |  5KB  |  141 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.2 1998/08/11 14:40:44 welch 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. # ----------------------------------------------------------------------
  20. #  USAGE:  local <className> <objName> ?<arg> <arg>...?
  21. #
  22. #  Creates a new object called <objName> in class <className>, passing
  23. #  the remaining <arg>'s to the constructor.  Unlike the usual
  24. #  [incr Tcl] objects, however, an object created by this procedure
  25. #  will be automatically deleted when the local call frame is destroyed.
  26. #  This command is useful for creating objects that should only remain
  27. #  alive until a procedure exits.
  28. # ----------------------------------------------------------------------
  29. proc ::itcl::local {class name args} {
  30.     set ptr [uplevel eval [list $class $name] $args]
  31.     uplevel [list set itcl-local-$ptr $ptr]
  32.     set cmd [uplevel namespace which -command $ptr]
  33.     uplevel [list trace variable itcl-local-$ptr u \
  34.         "itcl::delete object $cmd; list"]
  35.     return $ptr
  36. }
  37.  
  38. # ----------------------------------------------------------------------
  39. # auto_mkindex
  40. # ----------------------------------------------------------------------
  41. # Define Itcl commands that will be recognized by the auto_mkindex
  42. # parser in Tcl...
  43. #
  44.  
  45. #
  46. # USAGE:  itcl::class name body
  47. # Adds an entry for the given class declaration.
  48. #
  49. foreach cmd {itcl::class itcl_class} {
  50.     auto_mkindex_parser::command $cmd {name body} {
  51.         variable index
  52.         variable scriptFile
  53.         append index "set [list auto_index([fullname $name])]"
  54.         append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  55.  
  56.         variable parser
  57.         variable contextStack
  58.         set contextStack [linsert $contextStack 0 $name]
  59.         $parser eval $body
  60.         set contextStack [lrange $contextStack 1 end]
  61.     }
  62. }
  63.  
  64. #
  65. # USAGE:  itcl::body name arglist body
  66. # Adds an entry for the given method/proc body.
  67. #
  68. auto_mkindex_parser::command itcl::body {name arglist body} {
  69.     variable index
  70.     variable scriptFile
  71.     append index "set [list auto_index([fullname $name])]"
  72.     append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  73. }
  74.  
  75. #
  76. # USAGE:  itcl::configbody name arglist body
  77. # Adds an entry for the given method/proc body.
  78. #
  79. auto_mkindex_parser::command itcl::configbody {name body} {
  80.     variable index
  81.     variable scriptFile
  82.     append index "set [list auto_index([fullname $name])]"
  83.     append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  84. }
  85.  
  86. #
  87. # USAGE:  ensemble name ?body?
  88. # Adds an entry to the auto index list for the given ensemble name.
  89. #
  90. auto_mkindex_parser::command itcl::ensemble {name {body ""}} {
  91.     variable index
  92.     variable scriptFile
  93.     append index "set [list auto_index([fullname $name])]"
  94.     append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
  95. }
  96.  
  97. #
  98. # USAGE:  public arg ?arg arg...?
  99. #         protected arg ?arg arg...?
  100. #         private arg ?arg arg...?
  101. #
  102. # Evaluates the arguments as commands, so we can recognize proc
  103. # declarations within classes.
  104. #
  105. foreach cmd {public protected private} {
  106.     auto_mkindex_parser::command $cmd {args} {
  107.         variable parser
  108.         $parser eval $args
  109.     }
  110. }
  111.  
  112. # ----------------------------------------------------------------------
  113. # auto_import
  114. # ----------------------------------------------------------------------
  115. # This procedure overrides the usual "auto_import" function in the
  116. # Tcl library.  It is invoked during "namespace import" to make see
  117. # if the imported commands reside in an autoloaded library.  If so,
  118. # stubs are created to represent the commands.  Executing a stub
  119. # later on causes the real implementation to be autoloaded.
  120. #
  121. # Arguments -
  122. # pattern    The pattern of commands being imported (like "foo::*")
  123. #               a canonical namespace as returned by [namespace current]
  124.  
  125. proc auto_import {pattern} {
  126.     global auto_index
  127.  
  128.     set ns [uplevel namespace current]
  129.     set patternList [auto_qualify $pattern $ns]
  130.  
  131.     auto_load_index
  132.  
  133.     foreach pattern $patternList {
  134.         foreach name [array names auto_index $pattern] {
  135.             if {"" == [info commands $name]} {
  136.                 ::itcl::import::stub create $name
  137.             }
  138.         }
  139.     }
  140. }
  141.