Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: data/media/tcl8.5/tm.tcl @ 5288

Last change on this file since 5288 was 5167, checked in by rgrieder, 16 years ago

added svn property svn:eol-style native to all tcl files

  • Property svn:eol-style set to native
File size: 10.5 KB
Line 
1# -*- tcl -*-
2#
3# Searching for Tcl Modules. Defines a procedure, declares it as the
4# primary command for finding packages, however also uses the former
5# 'package unknown' command as a fallback.
6#
7# Locates all possible packages in a directory via a less restricted
8# glob. The targeted directory is derived from the name of the
9# requested package. I.e. the TM scan will look only at directories
10# which can contain the requested package. It will register all
11# packages it found in the directory so that future requests have a
12# higher chance of being fulfilled by the ifneeded database without
13# having to come to us again.
14#
15# We do not remember where we have been and simply rescan targeted
16# directories when invoked again. The reasoning is this:
17#
18# - The only way we get back to the same directory is if someone is
19#   trying to [package require] something that wasn't there on the
20#   first scan.
21#
22#   Either
23#   1) It is there now:  If we rescan, you get it; if not you don't.
24#
25#      This covers the possibility that the application asked for a
26#      package late, and the package was actually added to the
27#      installation after the application was started. It shoukld
28#      still be able to find it.
29#
30#   2) It still is not there: Either way, you don't get it, but the
31#      rescan takes time. This is however an error case and we dont't
32#      care that much about it
33#
34#   3) It was there the first time; but for some reason a "package
35#      forget" has been run, and "package" doesn't know about it
36#      anymore.
37#
38#      This can be an indication that the application wishes to reload
39#      some functionality. And should work as well.
40#
41# Note that this also strikes a balance between doing a glob targeting
42# a single package, and thus most likely requiring multiple globs of
43# the same directory when the application is asking for many packages,
44# and trying to glob for _everything_ in all subdirectories when
45# looking for a package, which comes with a heavy startup cost.
46#
47# We scan for regular packages only if no satisfying module was found.
48
49namespace eval ::tcl::tm {
50    # Default paths. None yet.
51
52    variable paths {}
53
54    # The regex pattern a file name has to match to make it a Tcl Module.
55
56    set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}
57
58    # Export the public API
59
60    namespace export path
61    namespace ensemble create -command path -subcommand {add remove list}
62}
63
64# ::tcl::tm::path implementations --
65#
66#       Public API to the module path. See specification.
67#
68# Arguments
69#       cmd -   The subcommand to execute
70#       args -  The paths to add/remove. Must not appear querying the
71#               path with 'list'.
72#
73# Results
74#       No result for subcommands 'add' and 'remove'. A list of paths
75#       for 'list'.
76#
77# Sideeffects
78#       The subcommands 'add' and 'remove' manipulate the list of
79#       paths to search for Tcl Modules. The subcommand 'list' has no
80#       sideeffects.
81
82proc ::tcl::tm::add {path args} {
83    # PART OF THE ::tcl::tm::path ENSEMBLE
84    #
85    # The path is added at the head to the list of module paths.
86    #
87    # The command enforces the restriction that no path may be an
88    # ancestor directory of any other path on the list. If the new
89    # path violates this restriction an error wil be raised.
90    #
91    # If the path is already present as is no error will be raised and
92    # no action will be taken.
93
94    variable paths
95
96    # We use a copy of the path as source during validation, and
97    # extend it as well. Because we not only have to detect if the new
98    # paths are bogus with respect to the existing paths, but also
99    # between themselves. Otherwise we can still add bogus paths, by
100    # specifying them in a single call. This makes the use of the new
101    # paths simpler as well, a trivial assignment of the collected
102    # paths to the official state var.
103
104    set newpaths $paths
105    foreach p [linsert $args 0 $path] {
106        if {$p in $newpaths} {
107            # Ignore a path already on the list.
108            continue
109        }
110
111        # Search for paths which are subdirectories of the new one. If
112        # there are any then the new path violates the restriction
113        # about ancestors.
114
115        set pos [lsearch -glob $newpaths ${p}/*]
116        # Cannot use "in", we need the position for the message.
117        if {$pos >= 0} {
118            return -code error \
119                "$p is ancestor of existing module path [lindex $newpaths $pos]."
120        }
121
122        # Now look for existing paths which are ancestors of the new
123        # one. This reverse question forces us to loop over the
124        # existing paths, as each element is the pattern, not the new
125        # path :(
126
127        foreach ep $newpaths {
128            if {[string match ${ep}/* $p]} {
129                return -code error \
130                    "$p is subdirectory of existing module path $ep."
131            }
132        }
133
134        set newpaths [linsert $newpaths 0 $p]
135    }
136
137    # The validation of the input is complete and successful, and
138    # everything in newpaths is either an old path, or added. We can
139    # now extend the official list of paths, a simple assignment is
140    # sufficient.
141
142    set paths $newpaths
143    return
144}
145
146proc ::tcl::tm::remove {path args} {
147    # PART OF THE ::tcl::tm::path ENSEMBLE
148    #
149    # Removes the path from the list of module paths. The command is
150    # silently ignored if the path is not on the list.
151
152    variable paths
153
154    foreach p [linsert $args 0 $path] {
155        set pos [lsearch -exact $paths $p]
156        if {$pos >= 0} {
157            set paths [lreplace $paths $pos $pos]
158        }
159    }
160}
161
162proc ::tcl::tm::list {} {
163    # PART OF THE ::tcl::tm::path ENSEMBLE
164
165    variable paths
166    return  $paths
167}
168
169# ::tcl::tm::UnknownHandler --
170#
171#       Unknown handler for Tcl Modules, i.e. packages in module form.
172#
173# Arguments
174#       original        - Original [package unknown] procedure.
175#       name            - Name of desired package.
176#       version         - Version of desired package. Can be the
177#                         empty string.
178#       exact           - Either -exact or ommitted.
179#
180#       Name, version, and exact are used to determine
181#       satisfaction. The original is called iff no satisfaction was
182#       achieved. The name is also used to compute the directory to
183#       target in the search.
184#
185# Results
186#       None.
187#
188# Sideeffects
189#       May populate the package ifneeded database with additional
190#       provide scripts.
191
192proc ::tcl::tm::UnknownHandler {original name args} {
193    # Import the list of paths to search for packages in module form.
194    # Import the pattern used to check package names in detail. 
195
196    variable paths
197    variable pkgpattern
198
199    # Without paths to search we can do nothing. (Except falling back
200    # to the regular search).
201
202    if {[llength $paths]} {
203        set pkgpath [string map {:: /} $name]
204        set pkgroot [file dirname $pkgpath]
205        if {$pkgroot eq "."} {
206            set pkgroot ""
207        }
208
209        # We don't remember a copy of the paths while looping. Tcl
210        # Modules are unable to change the list while we are searching
211        # for them. This also simplifies the loop, as we cannot get
212        # additional directories while iterating over the list. A
213        # simple foreach is sufficient.
214
215        set satisfied 0
216        foreach path $paths {
217            if {![file exists $path]} {
218                continue
219            }
220            set currentsearchpath [file join $path $pkgroot]
221            if {![file exists $currentsearchpath]} {
222                continue
223            }
224            set strip [llength [file split $path]]
225
226            # We can't use glob in safe interps, so enclose the following
227            # in a catch statement, where we get the module files out
228            # of the subdirectories. In other words, Tcl Modules are
229            # not-functional in such an interpreter. This is the same
230            # as for the command "tclPkgUnknown", i.e. the search for
231            # regular packages.
232
233            catch {
234                # We always look for _all_ possible modules in the current
235                # path, to get the max result out of the glob.
236
237                foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
238                    set pkgfilename [join [lrange [file split $file] $strip end] ::]
239
240                    if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
241                        # Ignore everything not matching our pattern
242                        # for package names.
243                        continue
244                    }
245                    if {[catch {package vcompare $pkgversion 0}]} {
246                        # Ignore everything where the version part is
247                        # not acceptable to "package vcompare".
248                        continue
249                    }
250
251                    # We have found a candidate, generate a "provide
252                    # script" for it, and remember it.  Note that we
253                    # are using ::list to do this; locally [list]
254                    # means something else without the namespace
255                    # specifier.
256
257                    package ifneeded $pkgname $pkgversion [::list source -encoding utf-8 $file]
258
259                    # We abort in this unknown handler only if we got
260                    # a satisfying candidate for the requested
261                    # package. Otherwise we still have to fallback to
262                    # the regular package search to complete the
263                    # processing.
264
265                    if {
266                        ($pkgname eq $name) &&
267                        [package vsatisfies $pkgversion {*}$args]
268                    } then {
269                        set satisfied 1
270                        # We do not abort the loop, and keep adding
271                        # provide scripts for every candidate in the
272                        # directory, just remember to not fall back to
273                        # the regular search anymore.
274                    }
275                }
276            }
277        }
278
279        if {$satisfied} {
280            return
281        }
282    }
283
284    # Fallback to previous command, if existing.  See comment above
285    # about ::list...
286
287    if {[llength $original]} {
288        uplevel 1 $original [::linsert $args 0 $name]
289    }
290}
291
292# ::tcl::tm::Defaults --
293#
294#       Determines the default search paths.
295#
296# Arguments
297#       None
298#
299# Results
300#       None.
301#
302# Sideeffects
303#       May add paths to the list of defaults.
304
305proc ::tcl::tm::Defaults {} {
306    global env tcl_platform
307
308    lassign [split [info tclversion] .] major minor
309    set exe [file normalize [info nameofexecutable]]
310
311    # Note that we're using [::list], not [list] because [list] means
312    # something other than [::list] in this namespace.
313    roots [::list \
314            [file dirname [info library]] \
315            [file join [file dirname [file dirname $exe]] lib] \
316            ]
317
318    if {$tcl_platform(platform) eq "windows"} {
319        set sep ";"
320    } else {
321        set sep ":"
322    }
323    for {set n $minor} {$n >= 0} {incr n -1} {
324        foreach ev [::list \
325                        TCL${major}.${n}_TM_PATH \
326                        TCL${major}_${n}_TM_PATH \
327        ] {
328            if {![info exists env($ev)]} continue
329            foreach p [split $env($ev) $sep] {
330                path add $p
331            }
332        }
333    }
334    return
335}
336
337# ::tcl::tm::roots --
338#
339#       Public API to the module path. See specification.
340#
341# Arguments
342#       paths - List of 'root' paths to derive search paths from.
343#
344# Results
345#       No result.
346#
347# Sideeffects
348#       Calls 'path add' to paths to the list of module search paths.
349
350proc ::tcl::tm::roots {paths} {
351    foreach {major minor} [split [info tclversion] .] break
352    foreach pa $paths {
353        set p [file join $pa tcl$major]
354        for {set n $minor} {$n >= 0} {incr n -1} {
355            path add [file normalize [file join $p ${major}.${n}]]
356        }
357        path add [file normalize [file join $p site-tcl]]
358    }
359    return
360}
361
362# Initialization. Set up the default paths, then insert the new
363# handler into the chain.
364
365::tcl::tm::Defaults
Note: See TracBrowser for help on using the repository browser.