1# 2# tcllib.tcl -- 3# 4# Various command dealing with tlib package libraries. 5#------------------------------------------------------------------------------ 6# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. 7# 8# Permission to use, copy, modify, and distribute this software and its 9# documentation for any purpose and without fee is hereby granted, provided 10# that the above copyright notice appear in all copies. Karl Lehenbauer and 11# Mark Diekhans make no representations about the suitability of this 12# software for any purpose. It is provided "as is" without express or 13# implied warranty. 14#------------------------------------------------------------------------------ 15# Copyright (c) 1991-1994 The Regents of the University of California. 16# All rights reserved. 17# 18# Permission is hereby granted, without written agreement and without 19# license or royalty fees, to use, copy, modify, and distribute this 20# software and its documentation for any purpose, provided that the 21# above copyright notice and the following two paragraphs appear in 22# all copies of this software. 23# 24# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR 25# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT 26# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF 27# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28# 29# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, 30# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY 31# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS 32# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO 33# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. 34#------------------------------------------------------------------------------ 35# $Id: tcllib.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ 36#------------------------------------------------------------------------------ 37# 38 39#@package: TclX-libraries searchpath auto_load_file 40 41#------------------------------------------------------------------------------ 42# searchpath: 43# Search a path list for a file. (catch is for bad ~user) 44# 45proc searchpath {pathlist file} { 46 foreach dir $pathlist { 47 if {$dir == ""} {set dir .} 48 if {[catch {file exists $dir/$file} result] == 0 && $result} { 49 return $dir/$file 50 } 51 } 52 return {} 53} 54 55#------------------------------------------------------------------------------ 56# auto_load_file: 57# Search auto_path for a file and source it. 58# 59proc auto_load_file {name} { 60 global auto_path errorCode 61 if {[string first / $name] >= 0} { 62 return [uplevel 1 source $name] 63 } 64 set where [searchpath $auto_path $name] 65 if [lempty $where] { 66 error "couldn't find $name in any directory in auto_path" 67 } 68 uplevel 1 source $where 69} 70 71#@package: TclX-lib-list auto_packages auto_commands 72 73#------------------------------------------------------------------------------ 74# auto_packages: 75# List all of the loadable packages. If -files is specified, the file paths 76# of the packages is also returned. 77 78proc auto_packages {{option {}}} { 79 global auto_pkg_index 80 81 auto_load ;# Make sure all indexes are loaded. 82 if ![info exists auto_pkg_index] { 83 return {} 84 } 85 86 set packList [array names auto_pkg_index] 87 if [lempty $option] { 88 return $packList 89 } 90 91 if {$option != "-files"} { 92 error "Unknow option \"$option\", expected \"-files\"" 93 } 94 set locList {} 95 foreach pack $packList { 96 lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]] 97 } 98 return $locList 99} 100 101#------------------------------------------------------------------------------ 102# auto_commands: 103# List all of the loadable commands. If -loaders is specified, the commands 104# that will be involked to load the commands is also returned. 105 106proc auto_commands {{option {}}} { 107 global auto_index 108 109 auto_load ;# Make sure all indexes are loaded. 110 if ![info exists auto_index] { 111 return {} 112 } 113 114 set cmdList [array names auto_index] 115 if [lempty $option] { 116 return $cmdList 117 } 118 119 if {$option != "-loaders"} { 120 error "Unknow option \"$option\", expected \"-loaders\"" 121 } 122 set loadList {} 123 foreach cmd $cmdList { 124 lappend loadList [list $cmd $auto_index($cmd)] 125 } 126 return $loadList 127} 128 129 130 131