summaryrefslogtreecommitdiffstats
path: root/tests/pkgMkIndex.test
blob: 5b1498905e73228628f56a002d7ddfb5ddf0fc27 (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
# 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.5 1999/03/31 22:37:17 welch 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]]
set oldDir [pwd]
lappend auto_path [file join [pwd] $scriptDir pkg1]

namespace eval pkgtest {
    # Namespace for procs we can discard
}

# pkgtest::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

proc pkgtest::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
	    if {[string compare -load $a] == 0} {
		incr iarg
		lappend options [lindex $args $iarg]
	    }
	} else {
	    break
	}
    }

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

    return [list $options $dirPath $patternList]
}

# pkgtest::parseIndex --
#
#  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.

proc pkgtest::parseIndex { 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
}

# pkgtest::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

proc pkgtest::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 pkgtest::parseIndex call, filters it and returns a
#  cleaned up list of packages and their actions.
#
# Arguments:
#  inList	output from a pkgtest::parseIndex.
#
# 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 ...

proc 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
}

# pkgtest::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 pkgtest::parseIndex.
#	If error, this is the error result.

proc pkgtest::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 [parseIndex $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 [pkgtest::runIndex pkg nomatch.tcl] [pwd]
} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]]
cd $oldDir	;# 'cause 8.0.3 is left in the wrong place
test pkgMkIndex-2.1 {simple package} {
    pkgtest::runIndex pkg simple.tcl
} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}}

test pkgMkIndex-2.2 {simple package - use -direct} {
    pkgtest::runIndex -direct pkg simple.tcl
} "0 {{simple:1.0 {source [file join pkg simple.tcl]}}}"

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

test pkgMkIndex-4.1 {split package} {
    pkgtest::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} {
    pkgtest::runIndex -direct pkg pkg2_a.tcl pkg2_b.tcl
} "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl]
source [file join 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} {
    pkgtest::runIndex pkg std.tcl
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}

test pkgMkIndex-6.1 {pkg1 requires pkg3} {
    pkgtest::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} {
    pkgtest::runIndex -direct pkg pkg1.tcl pkg3.tcl
} "0 {{pkg1:1.0 {source [file join pkg pkg1.tcl]}} {pkg3:1.0 {source [file join pkg pkg3.tcl]}}}"

test pkgMkIndex-7.1 {pkg4 uses pkg3} {
    pkgtest::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} {
    pkgtest::runIndex -direct pkg pkg4.tcl pkg3.tcl
} "0 {{pkg3:1.0 {source [file join pkg pkg3.tcl]}} {pkg4:1.0 {source [file join pkg pkg4.tcl]}}}"

test pkgMkIndex-8.1 {pkg5 uses pkg2} {
    pkgtest::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} {
    pkgtest::runIndex -direct pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl]
source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}"

test pkgMkIndex-9.1 {circular packages} {
    pkgtest::runIndex 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}}}}}

# Try to find one of the DLLs in the dltest directory
set x [file join [pwd] [file dirname [info script]]]
set x [file join $x ../unix/dltest/pkga[info sharedlibextension]]
if {[file exists $x]} {
    file copy -force $x pkg
    test pkgMkIndex-10.1 {package in DLL and script} {
	pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl
    } {0 {{Pkga:1.0 {tclPkgSetup {pkga.so load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}}
    test pkgMkIndex-10.2 {package in DLL hidden by -load} {
	pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension]
    } {0 {}}
} else {
    puts "Skipping pkgMkIndex-10.1 (index of DLL and script)"
}

# Tolerate "namespace import" at the global scope

test pkgMkIndex-11.1 {conflicting namespace imports} {
    pkgtest::runIndex pkg import.tcl
} {0 {{fubar:1.0 {tclPkgSetup {import.tcl source ::fubar::foo}}}}}


#
# cleanup
#
if {![info exist TESTS]} {
    file delete [file join pkg pkgIndex.tcl]
    namespace delete pkgtest
}