summaryrefslogtreecommitdiffstats
path: root/tests/pkgMkIndex.test
blob: f30c8ea2fd57be5497440eb9d8232a36762aeba2 (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
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.1 1998/10/17 00:21:39 escoffon Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# Add the pkg1 directory to auto_path, so that its packages can be found.
# packages in pkg1 are used to test indexing of packages in pkg.
# Make sure that the path to pkg1 is absolute.

set scriptDir [file dirname [info script]]
if {[string compare [file pathtype $scriptDir] relative] == 0} {
    set oldDir [pwd]
    catch {
	cd [file join [pwd] $scriptDir]
	set scriptDir [pwd]
    }
    cd $oldDir
}
lappend auto_path [file join $scriptDir pkg1]

# pkgproc --
#
#  Wraps around proc, saves the name of the procedure in procList, so that
#  the procedure can be undefined at the end.
#
# Arguments:
#  procName	procedure name
#  argList	arguments list
#  body		procedure body
#
# Results:
#  Returns the return value of proc

proc pkgproc { procName argList body } {
    set result [proc $procName $argList $body]

    lappend ::procList $procName

    return $result
}

set ::procList pkgproc

set ::pkgDriverCount 0

# parseArgs --
#
#  Parse an argument list.
#
# Arguments:
#  <flags>	(optional) arguments starting with a dash are collected
#		as options to pkg_mkIndex and passed to pkg_mkIndex.
#  dirPath	the directory to index
#  pattern0	pattern to index
#  ...		pattern to index
#  patternN	pattern to index
#
# Results:
#  Returns a three element list:
#    0: the options
#    1: the directory to index
#    2: the patterns list

pkgproc parseArgs { args } {
    set options ""

    set argc [llength $args]
    for {set iarg 0} {$iarg < $argc} {incr iarg} {
	set a [lindex $args $iarg]
	if {[regexp {^-} $a]} {
	    lappend options $a
	} else {
	    break
	}
    }

    set dirPath [lindex $args $iarg]
    incr iarg
    set patternList [lrange $args $iarg end]

    return [list $options $dirPath $patternList]
}

# parsePkgIndex --
#
#  Loads a pkgIndex.tcl file, records all the calls to "package ifneeded".
#
# Arguments:
#  filePath	path to the pkgIndex.tcl file.
#
# Results:
#  Returns a list, in "array set/get" format, where the keys are the package
#  name and version (in the form "$name:$version"), and the values the rest
#  of the command line.

pkgproc parsePkgIndex { filePath } {
    # create a slave interpreter, where we override "package ifneeded"

    set slave [interp create]
    if {[catch {
	$slave eval {
	    rename package package_original
	    proc package { args } {
		if {[string compare [lindex $args 0] ifneeded] == 0} {
		    set pkg [lindex $args 1]
		    set ver [lindex $args 2]
		    set ::PKGS($pkg:$ver) [lindex $args 3]
		} else {
		    return [eval package_original $args]
		}
	    }
	    array set ::PKGS {}
	}

	set dir [file dirname $filePath]
	$slave eval {set curdir [pwd]}
	$slave eval [list cd $dir]
	$slave eval [list set dir $dir]
	$slave eval [list source [file tail $filePath]]
	$slave eval {cd $curdir}

	# Create the list in sorted order, so that we don't get spurious
	# errors because the order has changed.

	array set P {}
	foreach {k v} [$slave eval {array get ::PKGS}] {
	    set P($k) $v
	}

	set PKGS ""
	foreach k [lsort [array names P]] {
	    lappend PKGS $k $P($k)
	}
    } err]} {
	set ei $::errorInfo
	set ec $::errorCode

	catch {interp delete $slave}

	error $ei $ec
    }

    interp delete $slave

    return $PKGS
}

# createIndex --
#
#  Runs pkg_mkIndex for the given directory and set of patterns.
#  This procedure deletes any pkgIndex.tcl file in the target directory,
#  then runs pkg_mkIndex.
#
# Arguments:
#  <flags>	(optional) arguments starting with a dash are collected
#		as options to pkg_mkIndex and passed to pkg_mkIndex.
#  dirPath	the directory to index
#  pattern0	pattern to index
#  ...		pattern to index
#  patternN	pattern to index
#
# Results:
#  Returns a two element list:
#    0: 1 if the procedure encountered an error, 0 otherwise.
#    1: the error result if element 0 was 1

pkgproc createIndex { args } {
    set parsed [eval parseArgs $args]
    set options [lindex $parsed 0]
    set dirPath [lindex $parsed 1]
    set patternList [lindex $parsed 2]

    if {[catch {
	file delete [file join $dirPath pkgIndex.tcl]
	eval pkg_mkIndex $options $dirPath $patternList
    } err]} {
	return [list 1 $err]
    }

    return [list 0 {}]
}

# makePkgList --
#
#  Takes the output of a parsePkgIndex call, filters it and returns a
#  cleaned up list of packages and their actions.
#
# Arguments:
#  inList	output from a parsePkgIndex.
#
# Results:
#  Returns a list of two element lists:
#    0: the name:version
#    1: a list describing the package.
#	For tclPkgSetup packages it consists of:
#	 0: the keyword tclPkgSetup
#	 1: the first file to source, with its exported procedures
#	 2: the second file ...
#	 N: the N-1st file ...

pkgproc makePkgList { inList } {
    set pkgList ""

    foreach {k v} $inList {
	switch [lindex $v 0] {
	    tclPkgSetup {
		set l tclPkgSetup
		foreach s [lindex $v 4] {
		    lappend l $s
		}
	    }

	    source {
		set l $v
	    }

	    default {
		error "can't handle $k $v"
	    }
	}

	lappend pkgList [list $k $l]
    }

    return $pkgList
}

# runIndex --
#
#  Runs pkg_mkIndex, parses the generated index file.
#
# Arguments:
#  <flags>	(optional) arguments starting with a dash are collected
#		as options to pkg_mkIndex and passed to pkg_mkIndex.
#  dirPath	the directory to index
#  pattern0	pattern to index
#  ...		pattern to index
#  patternN	pattern to index
#
# Results:
#  Returns a two element list:
#    0: 1 if the procedure encountered an error, 0 otherwise.
#    1: if no error, this is the parsed generated index file, in the format
#	returned by parsePkgIndex.
#	If error, this is the error result.

pkgproc runIndex { args } {
    set rv [eval createIndex $args]
    if {[lindex $rv 0] == 0} {
	set parsed [eval parseArgs $args]
	set dirPath [lindex $parsed 1]
	set idxFile [file join $dirPath pkgIndex.tcl]

	if {[catch {
	    set result [list 0 [makePkgList [parsePkgIndex $idxFile]]]
	} err]} {
	    set result [list 1 $err]
	}
	file delete $idxFile
    } else {
	set result $rv
    }

    return $result
}

# If there is no match to the patterns, make sure the directory hasn't
# changed on us

test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} {
    list [runIndex pkg nomatch.tcl] [pwd]
} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]]

test pkgMkIndex-2.1 {simple package} {
    runIndex pkg simple.tcl
} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}}

test pkgMkIndex-2.2 {simple package - use -direct} {
    runIndex -direct pkg simple.tcl
} {0 {{simple:1.0 {source pkg/simple.tcl}}}}

test pkgMkIndex-3.1 {simple package with global symbols} {
    runIndex pkg global.tcl
} {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}}

test pkgMkIndex-4.1 {split package} {
    runIndex pkg pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}

test pkgMkIndex-4.2 {split package - direct loading} {
    runIndex -direct pkg pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {source pkg/pkg2_a.tcl
source pkg/pkg2_b.tcl}}}}

# This will fail, with "direct1" procedures in the list of procedures
# provided by std.
# It may also fail, if tclblend is in the auto_path, with an additional
# command "loadJava" which comes from the tclblend pkgIndex.tcl file.
# Both failures are caused by Tcl code executed in pkgIndex.tcl.

test pkgMkIndex-5.1 {requires -direct package} {
    runIndex pkg std.tcl
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}

test pkgMkIndex-5.2 {requires -direct package - use -nopkgrequire} {
    runIndex -nopkgrequire pkg std.tcl
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}

test pkgMkIndex-6.1 {pkg1 requires pkg3} {
    runIndex pkg pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}

test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} {
    runIndex -direct pkg pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {source pkg/pkg1.tcl}} {pkg3:1.0 {source pkg/pkg3.tcl}}}}

test pkgMkIndex-6.3 {pkg1 requires pkg3 - use -nopkgrequire} {
    runIndex -nopkgrequire pkg pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}

test pkgMkIndex-6.4 {pkg1 requires pkg3 - use -direct -nopkgrequire} {
    runIndex -direct -nopkgrequire pkg pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {source pkg/pkg1.tcl}} {pkg3:1.0 {source pkg/pkg3.tcl}}}}

test pkgMkIndex-7.1 {pkg4 uses pkg3} {
    runIndex pkg pkg4.tcl pkg3.tcl
} {0 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}} {pkg4:1.0 {tclPkgSetup {pkg4.tcl source {::pkg4::p4-1 ::pkg4::p4-2}}}}}}

test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} {
    runIndex -direct pkg pkg4.tcl pkg3.tcl
} {0 {{pkg3:1.0 {source pkg/pkg3.tcl}} {pkg4:1.0 {source pkg/pkg4.tcl}}}}

# Should pkg_mkIndex throw an error if not all packages are indexed?
# Currently it doesn't, and that's why there is a "success".
# The error marker was set at 1 so that the fail tests as a reminder to
# look at pkg_mkIndex behaviour on errors like these

test pkgMkIndex-7.3 {pkg4 uses pkg3 - use -nopkgrequire} {
    runIndex -nopkgrequire pkg pkg4.tcl pkg3.tcl
} {1 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}

test pkgMkIndex-7.4 {pkg4 uses pkg3 - use -direct -nopkgrequire} {
    runIndex -direct -nopkgrequire pkg pkg4.tcl pkg3.tcl
} {1 {{pkg3:1.0 {source pkg/pkg3.tcl}}}}

test pkgMkIndex-8.1 {pkg5 uses pkg2} {
    runIndex pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}} {pkg5:1.0 {tclPkgSetup {pkg5.tcl source {::pkg5::p5-1 ::pkg5::p5-2}}}}}}

test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} {
    runIndex -direct pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {source pkg/pkg2_a.tcl
source pkg/pkg2_b.tcl}} {pkg5:1.0 {source pkg/pkg5.tcl}}}}

# Should pkg_mkIndex throw an error if not all packages are indexed?
# Currently it doesn't, and that's why there is a "success".
# The error marker was set at 1 so that the fail tests as a reminder to
# look at pkg_mkIndex behaviour on errors like these

test pkgMkIndex-8.3 {pkg5 uses pkg2 - use -nopkgrequire} {
    runIndex -nopkgrequire pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} {1 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}

test pkgMkIndex-8.4 {pkg5 uses pkg2 - use -direct -nopkgrequire} {
    runIndex -direct -nopkgrequire pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} {1 {{pkg2:1.0 {source pkg/pkg2_a.tcl
source pkg/pkg2_b.tcl}}}}

# Should pkg_mkIndex throw an error if not all packages are indexed?
# Currently it doesn't, and that's why there is a "success".
# The error marker was set at 1 so that the fail tests as a reminder to
# look at pkg_mkIndex behaviour on errors like these

test pkgMkIndex-9.1 {circular packages} {
    runIndex pkg circ1.tcl circ2.tcl circ3.tcl
} {1 {}}

test pkgMkIndex-9.2 {circular packages - use -nopkgrequire} {
    runIndex -nopkgrequire pkg circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}

#
# cleanup
#

file delete [file join pkg pkgIndex.tcl]

foreach p $::procList {
    rename $p {}
}

unset ::procList
unset ::pkgDriverCount