home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / tclsrc / tclshell.tcl < prev   
Encoding:
Text File  |  1993-12-16  |  4.8 KB  |  127 lines
  1. #
  2. # tclshell.tcl --
  3. #
  4. # Commands that are used to support an interactive Tcl shell.  These are
  5. # not called directly, but from the "unknown" command.  Much of this code
  6. # is taken directly from the UCB Tcl library/init.tcl file.
  7. #------------------------------------------------------------------------------
  8. # Copyright 1992-1993 Karl Lehenbauer and Mark Diekhans.
  9. #
  10. # Permission to use, copy, modify, and distribute this software and its
  11. # documentation for any purpose and without fee is hereby granted, provided
  12. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  13. # Mark Diekhans make no representations about the suitability of this
  14. # software for any purpose.  It is provided "as is" without express or
  15. # implied warranty.
  16. #------------------------------------------------------------------------------
  17. # Copyright (c) 1991-1993 The Regents of the University of California.
  18. # All rights reserved.
  19. #
  20. # Permission is hereby granted, without written agreement and without
  21. # license or royalty fees, to use, copy, modify, and distribute this
  22. # software and its documentation for any purpose, provided that the
  23. # above copyright notice and the following two paragraphs appear in
  24. # all copies of this software.
  25. #
  26. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  27. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  28. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  29. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  30. #
  31. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  32. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  33. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  34. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  35. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  36. #------------------------------------------------------------------------------
  37. # $Id: tclshell.tcl,v 3.0 1993/11/19 07:00:36 markd Rel $
  38. #------------------------------------------------------------------------------
  39. #
  40.  
  41. #@package: TclX-shell tclx_unknown2 auto_execok
  42.  
  43. #------------------------------------------------------------------------------
  44. # tclx_unknown:
  45. # This implements the slow path of the TclX unknown command.  It must be called
  46. # directly from the unknown command.  This handles exec-ing of Unix programs
  47. # and interactive csh style redo.  Returns the result of the executed command.
  48. #
  49.  
  50. proc tclx_unknown2 cmd {
  51.     global tcl_interactive auto_noexec
  52.  
  53.     set name [lindex $cmd 0]
  54.  
  55.     if ![info exists auto_noexec] {
  56.         if [auto_execok $name] {
  57.             if {!$tcl_interactive || ([info level] > 2) ||
  58.                 [info script] != ""} {
  59.                 error "Auto execution of Unix commands only supported as interactive commands.\nUse \"exec\" to execute \"$name\""
  60.             }
  61.             uplevel 2 system [list $cmd]
  62.             return
  63.         }
  64.     }
  65.  
  66.     if {!$tcl_interactive || ([info level] > 2) || [info script] != ""} {
  67.         error "invalid command name \"$name\""
  68.     }
  69.  
  70.     # csh-style redo.
  71.  
  72.     if {([info level] == 2) && ([info script] == "")} {
  73.         if {$name == "!!"} {
  74.             return [uplevel 2 {history redo}]
  75.         }
  76.         if [regexp {^!(.+)$} $name dummy event] {
  77.             return [uplevel 2 [list history redo $event]]
  78.         }
  79.         if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  80.             return [uplevel 2 [list history substitute $old $new]]
  81.         }
  82.         set cmds [info commands $name*]
  83.         if {[llength $cmds] == 1} {
  84.             return [uplevel 2 [lreplace $cmd 0 0 $cmds]]
  85.         }
  86.         if {[llength $cmds] != 0} {
  87.             if {$name == ""} {
  88.                 return -code error "empty command name \"\""
  89.             } else {
  90.                 return -code error \
  91.                         "ambiguous command name \"$name\": [lsort $cmds]"
  92.             }
  93.         }
  94.     }
  95.     error "invalid command name \"$name\""
  96. }
  97.  
  98.  
  99. #------------------------------------------------------------------------------
  100. # auto_execok:
  101. # Returns 1 if there's an executable in the current path for the
  102. # given name, 0 otherwise.  Builds an associative array auto_execs
  103. # that caches information about previous checks, for speed.
  104.  
  105. proc auto_execok name {
  106.     global auto_execs env
  107.  
  108.     if [info exists auto_execs($name)] {
  109.         return $auto_execs($name)
  110.     }
  111.     set auto_execs($name) 0
  112.     if {[string first / $name] >= 0} {
  113.     if {[file executable $name] && ![file isdirectory $name]} {
  114.         puts "special, ok!"
  115.         set auto_execs($name) 1
  116.     }
  117.     return $auto_execs($name)
  118.     }
  119.     foreach dir [split $env(PATH) :] {
  120.         if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  121.             set auto_execs($name) 1
  122.             return 1
  123.         }
  124.     }
  125.     return 0
  126. }
  127.