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