summaryrefslogtreecommitdiffstats
path: root/library/tm.tcl
blob: 24ddb8669ed588d51a37738a01a2985222013e0a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
# -*- tcl -*-
#
# Searching for Tcl Modules. Defines a procedure, declares it as the
# primary command for finding packages, however also uses the former
# 'package unknown' command as a fallback.
#
# Locates all possible packages in a directory via a less restricted
# glob. The targeted directory is derived from the name of the
# requested package. I.e. the TM scan will look only at directories
# which can contain the requested package. It will register all
# packages it found in the directory so that future requests have a
# higher chance of being fulfilled by the ifneeded database without
# having to come to us again.
#
# We do not remember where we have been and simply rescan targeted
# directories when invoked again. The reasoning is this:
#
# - The only way we get back to the same directory is if someone is
#   trying to [package require] something that wasn't there on the
#   first scan.
#
#   Either
#   1) It is there now:  If we rescan, you get it; if not you don't.
#
#      This covers the possibility that the application asked for a
#      package late, and the package was actually added to the
#      installation after the application was started. It shoukld
#      still be able to find it.
#
#   2) It still is not there: Either way, you don't get it, but the
#      rescan takes time. This is however an error case and we dont't
#      care that much about it
#
#   3) It was there the first time; but for some reason a "package
#      forget" has been run, and "package" doesn't know about it
#      anymore.
#
#      This can be an indication that the application wishes to reload
#      some functionality. And should work as well.
#
# Note that this also strikes a balance between doing a glob targeting
# a single package, and thus most likely requiring multiple globs of
# the same directory when the application is asking for many packages,
# and trying to glob for _everything_ in all subdirectories when
# looking for a package, which comes with a heavy startup cost.
#
# We scan for regular packages only if no satisfying module was found.

namespace eval ::tcl::tm {
    # Default paths. None yet.

    variable paths {}

    # The regex pattern a file name has to match to make it a Tcl Module.

    set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}

    # Export the public API

    namespace export path
    namespace ensemble create -command path -subcommand {add remove list}
}

# ::tcl::tm::path implementations --
#
#	Public API to the module path. See specification.
#
# Arguments
#	cmd -	The subcommand to execute
#	args -	The paths to add/remove. Must not appear querying the
#		path with 'list'.
#
# Results
#	No result for subcommands 'add' and 'remove'. A list of paths
#	for 'list'.
#
# Sideeffects
#	The subcommands 'add' and 'remove' manipulate the list of
#	paths to search for Tcl Modules. The subcommand 'list' has no
#	sideeffects.

proc ::tcl::tm::add {path args} {
    # PART OF THE ::tcl::tm::path ENSEMBLE
    #
    # The path is added at the head to the list of module paths.
    #
    # The command enforces the restriction that no path may be an
    # ancestor directory of any other path on the list. If the new
    # path violates this restriction an error wil be raised.
    #
    # If the path is already present as is no error will be raised and
    # no action will be taken.

    variable paths

    # We use a copy of the path as source during validation, and
    # extend it as well. Because we not only have to detect if the new
    # paths are bogus with respect to the existing paths, but also
    # between themselves. Otherwise we can still add bogus paths, by
    # specifying them in a single call. This makes the use of the new
    # paths simpler as well, a trivial assignment of the collected
    # paths to the official state var.

    set newpaths $paths
    foreach p [linsert $args 0 $path] {
	if {$p in $newpaths} {
	    # Ignore a path already on the list.
	    continue
	}

	# Search for paths which are subdirectories of the new one. If
	# there are any then the new path violates the restriction
	# about ancestors.

	set pos [lsearch -glob $newpaths ${p}/*]
	# Cannot use "in", we need the position for the message.
	if {$pos >= 0} {
	    return -code error \
		"$p is ancestor of existing module path [lindex $newpaths $pos]."
	}

	# Now look for existing paths which are ancestors of the new
	# one. This reverse question forces us to loop over the
	# existing paths, as each element is the pattern, not the new
	# path :(

	foreach ep $newpaths {
	    if {[string match ${ep}/* $p]} {
		return -code error \
		    "$p is subdirectory of existing module path $ep."
	    }
	}

	set newpaths [linsert $newpaths 0 $p]
    }

    # The validation of the input is complete and successful, and
    # everything in newpaths is either an old path, or added. We can
    # now extend the official list of paths, a simple assignment is
    # sufficient.

    set paths $newpaths
    return
}

proc ::tcl::tm::remove {path args} {
    # PART OF THE ::tcl::tm::path ENSEMBLE
    #
    # Removes the path from the list of module paths. The command is
    # silently ignored if the path is not on the list.

    variable paths

    foreach p [linsert $args 0 $path] {
	set pos [lsearch -exact $paths $p]
	if {$pos >= 0} {
	    set paths [lreplace $paths $pos $pos]
	}
    }
}

proc ::tcl::tm::list {} {
    # PART OF THE ::tcl::tm::path ENSEMBLE

    variable paths
    return  $paths
}

# ::tcl::tm::UnknownHandler --
#
#	Unknown handler for Tcl Modules, i.e. packages in module form.
#
# Arguments
#	original	- Original [package unknown] procedure.
#	name		- Name of desired package.
#	version		- Version of desired package. Can be the
#			  empty string.
#	exact		- Either -exact or ommitted.
#
#	Name, version, and exact are used to determine
#	satisfaction. The original is called iff no satisfaction was
#	achieved. The name is also used to compute the directory to
#	target in the search.
#
# Results
#	None.
#
# Sideeffects
#	May populate the package ifneeded database with additional
#	provide scripts.

proc ::tcl::tm::UnknownHandler {original name args} {
    # Import the list of paths to search for packages in module form.
    # Import the pattern used to check package names in detail.  

    variable paths
    variable pkgpattern

    # Without paths to search we can do nothing. (Except falling back
    # to the regular search).

    if {[llength $paths]} {
	set pkgpath [string map {:: /} $name]
	set pkgroot [file dirname $pkgpath]
	if {$pkgroot eq "."} {
	    set pkgroot ""
	}

	# We don't remember a copy of the paths while looping. Tcl
	# Modules are unable to change the list while we are searching
	# for them. This also simplifies the loop, as we cannot get
	# additional directories while iterating over the list. A
	# simple foreach is sufficient.

	set satisfied 0
	foreach path $paths {
	    if {![interp issafe] && ![file exists $path]} {
		continue
	    }
	    set currentsearchpath [file join $path $pkgroot]
	    if {![interp issafe] && ![file exists $currentsearchpath]} {
		continue
	    }
	    set strip [llength [file split $path]]

	    # We can't use glob in safe interps, so enclose the following
	    # in a catch statement, where we get the module files out
	    # of the subdirectories. In other words, Tcl Modules are
	    # not-functional in such an interpreter. This is the same
	    # as for the command "tclPkgUnknown", i.e. the search for
	    # regular packages.

	    catch {
		# We always look for _all_ possible modules in the current
		# path, to get the max result out of the glob.

		foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
		    set pkgfilename [join [lrange [file split $file] $strip end] ::]

		    if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
			# Ignore everything not matching our pattern
			# for package names.
			continue
		    }
		    if {[catch {package vcompare $pkgversion 0}]} {
			# Ignore everything where the version part is
			# not acceptable to "package vcompare".
			continue
		    }

		    # We have found a candidate, generate a "provide
		    # script" for it, and remember it.  Note that we
		    # are using ::list to do this; locally [list]
		    # means something else without the namespace
		    # specifier.

		    package ifneeded $pkgname $pkgversion \
			"[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"

		    # We abort in this unknown handler only if we got
		    # a satisfying candidate for the requested
		    # package. Otherwise we still have to fallback to
		    # the regular package search to complete the
		    # processing.

		    if {
			($pkgname eq $name) &&
			[package vsatisfies $pkgversion {*}$args]
		    } then {
			set satisfied 1
			# We do not abort the loop, and keep adding
			# provide scripts for every candidate in the
			# directory, just remember to not fall back to
			# the regular search anymore.
		    }
		}
	    }
	}

	if {$satisfied} {
	    return
	}
    }

    # Fallback to previous command, if existing.  See comment above
    # about ::list...

    if {[llength $original]} {
	uplevel 1 $original [::linsert $args 0 $name]
    }
}

# ::tcl::tm::Defaults --
#
#	Determines the default search paths.
#
# Arguments
#	None
#
# Results
#	None.
#
# Sideeffects
#	May add paths to the list of defaults.

proc ::tcl::tm::Defaults {} {
    global env tcl_platform

    lassign [split [info tclversion] .] major minor
    set exe [file normalize [info nameofexecutable]]

    # Note that we're using [::list], not [list] because [list] means
    # something other than [::list] in this namespace.
    roots [::list \
	    [file dirname [info library]] \
	    [file join [file dirname [file dirname $exe]] lib] \
	    ]

    if {$tcl_platform(platform) eq "windows"} {
	set sep ";"
    } else {
	set sep ":"
    }
    for {set n $minor} {$n >= 0} {incr n -1} {
	foreach ev [::list \
			TCL${major}.${n}_TM_PATH \
			TCL${major}_${n}_TM_PATH \
        ] {
	    if {![info exists env($ev)]} continue
	    foreach p [split $env($ev) $sep] {
		path add $p
	    }
	}
    }
    return
}

# ::tcl::tm::roots --
#
#	Public API to the module path. See specification.
#
# Arguments
#	paths -	List of 'root' paths to derive search paths from.
#
# Results
#	No result.
#
# Sideeffects
#	Calls 'path add' to paths to the list of module search paths.

proc ::tcl::tm::roots {paths} {
    foreach {major minor} [split [info tclversion] .] break
    foreach pa $paths {
	set p [file join $pa tcl$major]
	for {set n $minor} {$n >= 0} {incr n -1} {
	    set px [file join $p ${major}.${n}]
	    if {![interp issafe]} { set px [file normalize $px] }
	    path add $px
	}
	set px [file join $p site-tcl]
	if {![interp issafe]} { set px [file normalize $px] }
	path add $px
    }
    return
}

# Initialization. Set up the default paths, then insert the new
# handler into the chain.

if {![interp issafe]} { ::tcl::tm::Defaults }