︙ | | |
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
-
|
-pkgInit.tcl TEAISH_PKGINIT_TCL
-pkgInit.tcl.in TEAISH_PKGINIT_TCL_IN
-url TEAISH_URL
-tm.tcl TEAISH_TM_TCL
-tm.tcl.in TEAISH_TM_TCL_IN
-options {}
-pragmas {}
-src {}
}
#
# Queues for use with teaish-checks-queue and teaish-checks-run.
#
queued-checks-pre {}
queued-checks-post {}
|
︙ | | |
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
|
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
|
-
-
-
+
-
-
-
-
+
+
+
+
+
-
-
+
-
-
+
-
|
}
-vsatisfies - -v {{Tcl 8.5-}}
-pkgInit.tcl - -v ""
-pkgInit.tcl.in - -v ""
-url - -v ""
-tm.tcl - -v ""
-tm.tcl.in - -v ""
-src - -v ""
} {
#proj-assert 0 {Just testing}
set isPIFlag [expr {"-" ne $pflag}]
if {$isPIFlag} {
if {[info exists ::teaish__PkgInfo($pflag)]} {
# Was already set - skip it.
continue;
}
proj-assert {{-} eq $key};# "Unexpected pflag=$pflag key=$key type=$type val=$val"
proj-assert {{-} eq $key}
set key $f2d($pflag)
}
if {"" ne $key} {
if {"<nope>" ne [get-define $key "<nope>"]} {
# Was already set - skip it.
continue
proj-assert {"" ne $key}
set got [get-define $key "<nope>"]
if {"<nope>" ne $got} {
# Was already set - skip it.
continue
}
}
switch -exact -- $type {
-v {}
-e { set val [eval $val] }
default { proj-error "Invalid type flag: $type" }
}
#puts "***** defining default $pflag $key {$val} isPIFlag=$isPIFlag"
#puts "***** defining default $pflag $key {$val} isPIFlag=$isPIFlag got=$got"
if {$key ne ""} {
define $key $val
define $key $val
}
if {$isPIFlag} {
set ::teaish__PkgInfo($pflag) $val
}
}
unset isPIFlag pflag key type val
array unset f2d
}; # sourcing extension's teaish.tcl
|
︙ | | |
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
|
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
|
-
+
-
-
-
-
-
+
+
+
+
-
+
-
+
-
-
-
-
+
+
-
-
+
|
#
# Ensure we clean up TEAISH_PKGINIT_TCL if needed and @-process
# TEAISH_PKGINIT_TCL_IN if needed.
#
if {0x0f & $::teaish__Config(pkginit-policy)} {
file delete -force -- [get-define TEAISH_PKGINIT_TCL]
proj-dot-ins-append [get-define TEAISH_PKGINIT_TCL_IN] \
proj-dot-ins-append [get-define TEAISH_PKGINIT_TCL_IN]
[get-define TEAISH_PKGINIT_TCL]
}
if {0x0f & $::teaish__Config(tm-policy)} {
file delete -force -- [get-define TEAISH_TM_TCL]
proj-dot-ins-append [get-define TEAISH_TM_TCL_IN]
}
apply {{} {
# Queue up any remaining dot-in files
set dotIns [list]
foreach {dIn => dOut} {
TEAISH_TESTER_TCL_IN => TEAISH_TESTER_TCL
TEAISH_TEST_TCL_IN => TEAISH_TEST_TCL
TEAISH_MAKEFILE_IN => TEAISH_MAKEFILE
foreach d {
TEAISH_TESTER_TCL_IN
TEAISH_TEST_TCL_IN
TEAISH_MAKEFILE_IN
} {
lappend dotIns [get-define $dIn ""] [get-define $dOut ""]
lappend dotIns [get-define $d ""]
}
lappend dotIns $::autosetup(srcdir)/Makefile.in Makefile; # must be after TEAISH_MAKEFILE_IN.
lappend dotIns $::autosetup(srcdir)/Makefile.in; # must be after TEAISH_MAKEFILE_IN
# Much later: probably because of timestamps for deps purposes :-?
#puts "dotIns=$dotIns"
foreach {i o} $dotIns {
if {"" ne $i && "" ne $o} {
foreach f $dotIns {
if {"" ne $f} {
#puts " pre-dot-ins-append: \[$i\] -> \[$o\]"
proj-dot-ins-append $i $o
proj-dot-ins-append $f
}
}
}}
define TEAISH_DIST_FULL \
[expr {
$::teaish__Config(dist-enabled)
|
︙ | | |
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
|
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
|
+
-
|
proj-remap-autoconf-dir-vars
set tdefs [teaish__defines_to_list]
define TEAISH__DEFINES_MAP $tdefs; # injected into _teaish.tester.tcl
#
# NO [define]s after this point!
#
proj-dot-ins-process -validate
proj-if-opt-truthy teaish-dump-defines {
proj-file-write config.defines.txt $tdefs
}
proj-dot-ins-process -validate
}; # teaish__configure_phase1
#
# Run checks for required binaries.
#
proc teaish__check_common_bins {} {
|
︙ | | |
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
|
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
|
-
+
-
-
|
set tcllibdir [get-env TCLLIBDIR ""]
set extDirName [teaish-pkginfo-get -libDir]
if {"" eq $tcllibdir} {
# Attempt to extract TCLLIBDIR from TCL's $auto_path
if {"" ne $withSh &&
[catch {exec echo "puts stdout \$auto_path" | "$withSh"} result] == 0} {
foreach i $result {
if {![string match //zip* $i] && [file isdirectory $i]} {
if {[file isdirectory $i]} {
# isdirectory actually passes on //zipfs:/..., but those are
# useless for our purposes
set tcllibdir $i/$extDirName
break
}
}
} else {
proj-error "Cannot determine TCLLIBDIR."
}
|
︙ | | |
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
|
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
|
-
+
|
if {[proj-first-file-found extM \
[list \
$dirExt/teaish.make.in \
$dirExt/teaish.make \
]]} {
if {[string match *.in $extM]} {
define TEAISH_MAKEFILE_IN $extM
define TEAISH_MAKEFILE _[file rootname [file tail $extM]]
define TEAISH_MAKEFILE [file rootname [file tail $extM]]
} else {
define TEAISH_MAKEFILE_IN ""
define TEAISH_MAKEFILE $extM
}
apply $addDist $extM
teaish__verbose 1 msg-result "Extension makefile = $extM"
} else {
|
︙ | | |
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
|
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
|
-
-
+
+
|
set ::teaish__Config(pkgindex-policy) $piPolicy
# Look for teaish.test.tcl[.in]
proj-assert {"" ne $dirExt}
set flist [list $dirExt/teaish.test.tcl.in $dirExt/teaish.test.tcl]
if {[proj-first-file-found ttt $flist]} {
if {[string match *.in $ttt]} {
# Generate _teaish.test.tcl from $ttt
set xt _[file rootname [file tail $ttt]]
# Generate teaish.test.tcl from $ttt
set xt [file rootname [file tail $ttt]]
file delete -force -- $xt; # ensure no stale copy is used
define TEAISH_TEST_TCL $xt
define TEAISH_TEST_TCL_IN $ttt
} else {
define TEAISH_TEST_TCL $ttt
define TEAISH_TEST_TCL_IN ""
}
|
︙ | | |
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
|
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
|
+
|
# it before they're added to the list. As often as not, that will be
# the desired behavior so that out-of-tree builds can find the
# sources, but there are cases where it's not desired (e.g. when using
# a source file from outside of the extension's dir, or when adding
# object files (which are typically in the build tree)).
#
proc teaish-src-add {args} {
set i 0
proj-parse-simple-flags args flags {
-dist 0 {expr 1}
-dir 0 {expr 1}
}
if {$flags(-dist)} {
teaish-dist-add {*}$args
}
|
︙ | | |
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
|
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
|
-
+
-
-
-
-
-
+
+
-
+
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
-
-
-
+
-
-
-
-
-
-
+
+
-
+
-
+
-
+
|
# Internal helper to generate a clean/distclean rule name
proc teaish__cleanup_rule {{tgt clean}} {
set x [incr ::teaish__Config(teaish__cleanup_rule-counter-${tgt})]
return ${tgt}-_${x}_
}
# @teaish-make-obj ?flags? ?...args?
# @teaish-make-obj objfile srcfile ?...args?
#
# Uses teaish-make-add to inject makefile rules for $objfile from
# $srcfile, which is assumed to be C code which uses libtcl. Unless
# -recipe is used (see below) it invokes the compiler using the
# makefile-defined $(CC.tcl) which, in the default Makefile.in
# template, includes any flags needed for building against the
# configured Tcl.
#
# This always terminates the resulting code with a newline.
#
# Any arguments after the 2nd may be flags described below or, if no
# -recipe is provided, flags for the compiler call.
#
# -obj obj-filename.o
#
# -src src-filename.c
#
# -recipe {...}
# Uses the trimmed value of {...} as the recipe, prefixing it with
# a single hard-tab character.
#
# -deps {...}
# List of extra files to list as dependencies of $o.
# List of extra files to list as dependencies of $o. Good luck
# escaping non-trivial cases properly.
#
# -clean
# Generate cleanup rules as well.
proc teaish-make-obj {args} {
proc teaish-make-obj {o src args} {
proj-parse-simple-flags args flags {
-clean 0 {expr 1}
-recipe => {}
-deps => {}
-obj => {}
-src => {}
}
#parray flags
if {"" eq $flags(-obj)} {
set args [lassign $args flags(-obj)]
set consume 0
set clean 0
set flag ""
array set flags {}
set xargs {}
foreach arg $args {
if {$consume} {
set consume 0
set flags($flag) $arg
continue
}
switch -exact -- $arg {
-clean {incr clean}
-recipe -
-deps {
set flag $arg
if {"" eq $flags(-obj)} {
proj-error "Missing -obj flag."
}
}
incr consume
}
default {
lappend xargs $arg
}
foreach f {-deps -src} {
set flags($f) [string trim [string map {\n " "} $flags($f)]]
}
}
foreach f {-deps -src} {
set flags($f) [string trim $flags($f)]
}
#parray flags
#puts "-- args=$args"
teaish-make-add \
"# [proj-scope 1] -> [proj-scope] $flags(-obj) $flags(-src)" -nl \
"$flags(-obj): $flags(-src) $::teaish__Config(teaish.tcl)"
"# [proj-scope 1] -> [proj-scope] $o $src" -nl \
"$o: $src $::teaish__Config(teaish.tcl)"
if {[info exists flags(-deps)]} {
teaish-make-add " " [join $flags(-deps)]
}
teaish-make-add -nltab
if {[info exists flags(-recipe)]} {
teaish-make-add [string trim $flags(-recipe)] -nl
} else {
teaish-make-add [join [list \$(CC.tcl) -c $flags(-src) {*}$args]] -nl
teaish-make-add [join [list \$(CC.tcl) -c $src {*}$xargs]] -nl
}
if {$flags(-clean)} {
if {$clean} {
set rule [teaish__cleanup_rule]
teaish-make-add \
"clean: $rule\n$rule:\n\trm -f \"$flags(-obj)\"\n"
"clean: $rule\n$rule:\n\trm -f \"$o\"\n"
}
}
#
# @teaish-make-clean ?-r? ?-dist? ...files|{...files}
#
# Adds makefile rules for cleaning up the given files via the "make
|
︙ | | |
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
|
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
|
-
-
-
-
-
-
-
-
-
-
-
|
define TEAISH_PKGINIT_TCL_IN $tIn
define TEAISH_PKGINIT_TCL $tOut
define TEAISH_PKGINIT_TCL_TAIL $tTail
teaish-dist-add $v
set v $x
}
-src {
set d $::teaish__Config(extension-dir)
foreach f $v {
lappend ::teaish__Config(dist-files) $f
lappend ::teaish__Config(extension-src) $d/$f
lappend ::teaish__PkgInfo(-src) $f
# ^^^ so that default-value initialization in
# teaish-configure-core recognizes that it's been set.
}
}
-tm.tcl -
-tm.tcl.in {
if {0x30 & $::teaish__Config(pkgindex-policy)} {
proj-fatal "Cannot use $f together with a pkgIndex.tcl."
} elseif {$::teaish__Config(tm-policy)} {
proj-fatal "Cannot use -tm.tcl(.in) more than once."
}
|
︙ | | |
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
|
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
|
-
+
|
foreach {srcDir destDir} [list \
$dAS $ddAS \
$dAST $ddAST \
$dASTF $ddASTF \
] {
teaish__verbose 1 msg-result "Copying files to $destDir..."
file mkdir $destDir
foreach f [glob -nocomplain -directory $srcDir *] {
foreach f [glob -directory $srcDir *] {
if {[string match {*~} $f] || [string match "#*#" [file tail $f]]} {
# Editor-generated backups and emacs lock files
continue
}
teaish__verbose 2 msg-result "\t$f"
teaish__install_file $f $destDir $force
}
|
︙ | | |
︙ | | |
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
-
+
|
return
}
incr verbose
} else {
lassign $args script msg
}
incr ::test__Counters($what)
if {![uplevel 1 expr [list $script]]} {
if {![uplevel 1 [concat expr [list $script]]]} {
if {"" eq $msg} {
set msg $script
}
set txt [join [list $what # $::test__Counters($what) "failed:" $msg]]
if {$failMode} {
puts stderr $txt
exit 1
|
︙ | | |
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
|
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
#
# Works like [affirm] but exits on error.
#
proc assert {args} {
tailcall test__affert 1 {*}$args
}
#
# @assert-matches ?-e? pattern ?-e? rhs ?msg?
#
# Equivalent to assert {[string match $pattern $rhs]} except that
# if either of those are prefixed with an -e flag, they are eval'd
# and their results are used.
#
proc assert-matches {args} {
set evalLhs 0
set evalRhs 0
if {"-e" eq [lindex $args 0]} {
incr evalLhs
set args [lassign $args -]
}
set args [lassign $args pattern]
if {"-e" eq [lindex $args 0]} {
incr evalRhs
set args [lassign $args -]
}
set args [lassign $args rhs msg]
if {$evalLhs} {
set pattern [uplevel 1 $pattern]
}
if {$evalRhs} {
set rhs [uplevel 1 $rhs]
}
#puts "***pattern=$pattern\n***rhs=$rhs"
tailcall test__affert 1 \
[join [list \[ string match [list $pattern] [list $rhs] \]]] $msg
# why does this not work? [list \[ string match [list $pattern] [list $rhs] \]] $msg
# "\[string match [list $pattern] [list $rhs]\]"
}
#
# @test-assert testId script ?msg?
#
# Works like [assert] but emits $testId to stdout first.
#
proc test-assert {testId script {msg ""}} {
puts "test $testId"
|
︙ | | |
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
|
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
|
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
# $result, minus any leading or trailing whitespace. If they differ,
# it triggers an [assert].
#
proc test-expect {testId script result} {
puts "test $testId"
set x [string trim [uplevel 1 $script]]
set result [string trim $result]
tailcall test__affert 0 [list "{$x}" eq "{$result}"] \
tailcall test__affert 0 [list $x eq $result] \
"\nEXPECTED: <<$result>>\nGOT: <<$x>>"
}
#
# @test-catch cmd ?...args?
#
# Runs [cmd ...args], repressing any exception except to possibly log
# the failure. Returns 1 if it caught anything, 0 if it didn't.
#
proc test-catch {cmd args} {
if {[catch {
uplevel 1 $cmd {*}$args
$cmd {*}$args
} rc xopts]} {
puts "[test-current-scope] ignoring failure of: $cmd [lindex $args 0]: $rc"
return 1
}
return 0
}
#
# @test-catch-matching pattern (script|cmd args...)
#
# Works like test-catch, but it expects its argument(s) to to throw an
# error matching the given string (checked with [string match]). If
# they do not throw, or the error does not match $pattern, this
# function throws, else it returns 1.
#
# If there is no second argument, the $cmd is assumed to be a script,
# and will be eval'd in the caller's scope.
#
# TODO: add -glob and -regex flags to control matching flavor.
#
proc test-catch-matching {pattern cmd args} {
if {[catch {
#puts "**** catch-matching cmd=$cmd args=$args"
if {0 == [llength $args]} {
uplevel 1 $cmd {*}$args
} else {
$cmd {*}$args
}
} rc xopts]} {
if {[string match $pattern $rc]} {
return 1
} else {
error "[test-current-scope] exception does not match {$pattern}: {$rc}"
}
}
error "[test-current-scope] expecting to see an error matching {$pattern}"
}
if {![array exists ::teaish__BuildFlags]} {
array set ::teaish__BuildFlags {}
}
#
# @teaish-build-flag3 flag tgtVar ?dflt?
#
|
︙ | | |