Return to init.tcl CVS log

Up to [Micropolis - Activity] / micropolis / src / tcl / library

Annotation of micropolis/src/tcl/library/init.tcl, revision 1.1

1.1     ! root        1: # init.tcl --
        !             2: #
        !             3: # Default system startup file for Tcl-based applications.  Defines
        !             4: # "unknown" procedure and auto-load facilities.
        !             5: #
        !             6: # $Header: /user6/ouster/tcl/scripts/RCS/init.tcl,v 1.7 92/07/25 16:29:36 ouster Exp $ SPRITE (Berkeley)
        !             7: #
        !             8: # Copyright 1991-1992 Regents of the University of California
        !             9: # Permission to use, copy, modify, and distribute this
        !            10: # software and its documentation for any purpose and without
        !            11: # fee is hereby granted, provided that this copyright
        !            12: # notice appears in all copies.  The University of California
        !            13: # makes no representations about the suitability of this
        !            14: # software for any purpose.  It is provided "as is" without
        !            15: # express or implied warranty.
        !            16: #
        !            17: 
        !            18: # unknown:
        !            19: # Invoked when a Tcl command is invoked that doesn't exist in the
        !            20: # interpreter:
        !            21: #
        !            22: #      1. See if the autoload facility can locate the command in a
        !            23: #         Tcl script file.  If so, load it and execute it.
        !            24: #      2. See if the command exists as an executable UNIX program.
        !            25: #         If so, "exec" the command.
        !            26: #      3. See if the command is a valid abbreviation for another command.
        !            27: #         if so, invoke the command.  However, only permit abbreviations
        !            28: #         at top-level.
        !            29: 
        !            30: proc unknown args {
        !            31:     global auto_noexec auto_noload env unknown_active
        !            32: 
        !            33:     if [info exists unknown_active] {
        !            34:        unset unknown_active
        !            35:        error "unexpected recursion in \"unknown\" command"
        !            36:     }
        !            37:     set unknown_active 1
        !            38:     set name [lindex $args 0]
        !            39:     if ![info exists auto_noload] {
        !            40:        if [auto_load $name] {
        !            41:            unset unknown_active
        !            42:            return [uplevel $args]
        !            43:        }
        !            44:     }
        !            45:     if ![info exists auto_noexec] {
        !            46:        if [auto_execok $name] {
        !            47:            unset unknown_active
        !            48:            return [uplevel exec $args]
        !            49:        }
        !            50:     }
        !            51:     if {([info level] == 1) && ([info script] == "")} {
        !            52:        set cmds [info commands $name*]
        !            53:        if {[llength $cmds] == 1} {
        !            54:            unset unknown_active
        !            55:            return [uplevel [lreplace $args 0 0 $cmds]]
        !            56:        }
        !            57:        if {[llength $cmds] != 0} {
        !            58:            unset unknown_active
        !            59:            if {$name == ""} {
        !            60:                error "empty command name \"\""
        !            61:            } else {
        !            62:                error "ambiguous command name \"$name\": [lsort $cmds]"
        !            63:            }
        !            64:        }
        !            65:     }
        !            66:     unset unknown_active
        !            67:     error "invalid command name \"$name\""
        !            68: }
        !            69: 
        !            70: # auto_load:
        !            71: # Checks a collection of library directories to see if a procedure
        !            72: # is defined in one of them.  If so, it sources the appropriate
        !            73: # library file to create the procedure.  Returns 1 if it successfully
        !            74: # loaded the procedure, 0 otherwise.
        !            75: 
        !            76: proc auto_load cmd {
        !            77:     global auto_index auto_oldpath auto_path env
        !            78: 
        !            79:     if [info exists auto_index($cmd)] {
        !            80:        uplevel #0 source $auto_index($cmd)
        !            81:        return 1
        !            82:     }
        !            83:     if [catch {set path $auto_path}] {
        !            84:        if [catch {set path $env(TCLLIBPATH)}] {
        !            85:            if [catch {set path [info library]}] {
        !            86:                return 0
        !            87:            }
        !            88:        }
        !            89:     }
        !            90:     if [info exists auto_oldpath] {
        !            91:        if {$auto_oldpath == $path} {
        !            92:            return 0
        !            93:        }
        !            94:     }
        !            95:     set auto_oldpath $path
        !            96:     catch {unset auto_index}
        !            97:     foreach dir $path {
        !            98:        set f ""
        !            99:        catch {
        !           100:            set f [open $dir/tclindex]
        !           101:            if {[gets $f] != "# Tcl autoload index file: each line identifies a Tcl"} {
        !           102:                puts stdout "Bad id line in file $dir/tclindex"
        !           103:                error done
        !           104:            }
        !           105:            while {[gets $f line] >= 0} {
        !           106:                if {([string index $line 0] == "#") || ([llength $line] != 2)} {
        !           107:                    continue
        !           108:                }
        !           109:                set name [lindex $line 0]
        !           110:                if {![info exists auto_index($name)]} {
        !           111:                    set auto_index($name) $dir/[lindex $line 1]
        !           112:                }
        !           113:            }
        !           114:        }
        !           115:        if {$f != ""} {
        !           116:            close $f
        !           117:        }
        !           118:     }
        !           119:     if [info exists auto_index($cmd)] {
        !           120:        uplevel #0 source $auto_index($cmd)
        !           121:        return 1
        !           122:     }
        !           123:     return 0
        !           124: }
        !           125: 
        !           126: # auto_execok:
        !           127: # Returns 1 if there's an executable in the current path for the
        !           128: # given name, 0 otherwise.  Builds an associative array auto_execs
        !           129: # that caches information about previous checks, for speed.
        !           130: 
        !           131: proc auto_execok name {
        !           132:     global auto_execs env
        !           133: 
        !           134:     if [info exists auto_execs($name)] {
        !           135:        return $auto_execs($name)
        !           136:     }
        !           137:     set auto_execs($name) 0
        !           138:     foreach dir [split $env(PATH) :] {
        !           139:        if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
        !           140:            set auto_execs($name) 1
        !           141:            return 1
        !           142:        }
        !           143:     }
        !           144:     return 0
        !           145: }
        !           146: 
        !           147: # auto_reset:
        !           148: # Destroy all cached information for auto-loading and auto-execution,
        !           149: # so that the information gets recomputed the next time it's needed.
        !           150: 
        !           151: proc auto_reset {} {
        !           152:     global auto_execs auto_index
        !           153:     unset auto_execs auto_index
        !           154: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.