Tcl Source Code

Check-in [406483ed83]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:- added code to print the name of each test file that created files and did not clean them up (the list of files create follows the test file name).
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 406483ed8357165d7c52f69894be41756eae0d1d
User & Date: hershey 1999-03-24 23:53:44
Context
1999-03-25
00:31
Removed mention of Win32s. check-in: 248bb1b1f2 user: rjohnson tags: core-8-1-branch-old
1999-03-24
23:53
- added code to print the name of each test file that created files and did not clean them up (the... check-in: 406483ed83 user: hershey tags: core-8-1-branch-old
23:53
Make windows sockets implementation thread-safe by making the window used to handle socket events th... check-in: 74e05afb99 user: redman tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/defs.tcl.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
70
71
72
73
74
75
76




77
78
79
80
81
82
83
...
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
...
395
396
397
398
399
400
401


402





403
404
405
406
407
408



409
410












411
412
413
414
415
416
417
...
434
435
436
437
438
439
440
441
442
443

444
445
446
447

448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
...
879
880
881
882
883
884
885

886
887
888
889
890
891
892
893
#	of Sun Microsystems.
#
# Copyright (c) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: defs.tcl,v 1.1.2.5 1999/03/24 19:26:02 hershey Exp $

# Initialize wish shell
if {[info exists tk_version]} {
    tk appname tktest
    wm title . tktest
} else {
    # Ensure that we have a minimal auto_path so we don't pick up extra junk.
................................................................................
    # check the current working dir for files created by the tests.
    # ::tcltest::filesMade keeps track of such files created using the
    # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
    # ::tcltest::filesExisted stores the names of pre-existing files.

    variable filesMade {}
    variable filesExisted {}





    # initialize ::tcltest::numTests array to keep track fo the number of
    # tests that pass, fial, and are skipped.
    array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # initialize ::tcltest::skippedBecause array to keep track of
    # constraints that kept tests from running
................................................................................
    if {[catch {array set flag $flagArray}]} {
	puts stderr "Error:  odd number of command line args specified:"
	puts stderr "        $argv"
	exit
    }
    
    # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
    # Note that -verbose cannot be abbreviated to -v in wish because it conflicts
    # with the wish option -visual.
    foreach arg {-verbose -match -skip -constraints} {
	set abbrev [string range $arg 0 1]
	if {([info exists flag($abbrev)]) && \
		([lsearch -exact $flagArray $arg] < \
		[lsearch -exact $flagArray $abbrev])} {
	    set flag($arg) $flag($abbrev)
	}
................................................................................
# since the tests were invoked.
#
# Print the number tests (total, passed, failed, and skipped) since the
# tests were invoked.
#

proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {


    # remove files and directories created by the tests





    foreach file $::tcltest::filesMade {
	if {[file exists $file]} {
	    catch {file delete -force $file}
	    puts "removed $file"
	}
    }




    set tail [file tail [info script]]












    if {$calledFromAllFile || $::tcltest::testSingleFile} {
	# print stats
	puts -nonewline stdout "$tail:"
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
	}
	puts stdout ""
................................................................................
	    foreach constraint [lsort [array names ::tcltest::skippedBecause]] {
		puts stdout \
			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
		unset ::tcltest::skippedBecause($constraint)
	    }
	}

	# report the names of files in ::tcltest::workingDir that were not
	# pre-existing.


	set currentFiles {}
	foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
	    lappend currentFiles [file tail $file]
	}

	set filesNew {}
	foreach file $currentFiles {
	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
		lappend filesNew $file
		puts "new: $file"
	    }
	}
	if {[llength $filesNew] > 0} {
	    puts stdout "Warning: created files:\t$filesNew"
	}

	# reset filesMade, filesExisted, and numTests
	set ::tcltest::filesMade {}
	set ::tcltest::filesExisted $currentFiles
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set ::tcltest::numTests($index) 0
	}

	# exit only if running Tk in non-interactive mode
	global tk_version tcl_interactive
	if {[info exists tk_version] && !$tcl_interactive} {
................................................................................
    # process running in the background.
    
    # Locate the tktest executable

    set ::tcltest::tktest [info nameofexecutable]
    if {$::tcltest::tktest == "{}"} {
	set ::tcltest::tktest {}

	puts stdout "Unable to find tktest executable, skipping multiple process tests."
    }

    # Create background process
    
    proc ::tcltest::setupbg args {
	if {$::tcltest::tktest == ""} {
	    error "you're not running tktest so setupbg should not have been called"






|







 







>
>
>
>







 







|
|







 







>
>
|
>
>
>
>
>
|
|
|
<
|
|
>
>
>
|
<
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|
<
>
|
|
|
<
>
|
<
<
<
<


<
<
<



<







 







>
|







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
...
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
...
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416

417
418
419
420
421
422

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
...
458
459
460
461
462
463
464
465
466

467
468
469
470

471
472




473
474



475
476
477

478
479
480
481
482
483
484
...
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
#	of Sun Microsystems.
#
# Copyright (c) 1990-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: defs.tcl,v 1.1.2.6 1999/03/24 23:53:44 hershey Exp $

# Initialize wish shell
if {[info exists tk_version]} {
    tk appname tktest
    wm title . tktest
} else {
    # Ensure that we have a minimal auto_path so we don't pick up extra junk.
................................................................................
    # check the current working dir for files created by the tests.
    # ::tcltest::filesMade keeps track of such files created using the
    # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
    # ::tcltest::filesExisted stores the names of pre-existing files.

    variable filesMade {}
    variable filesExisted {}

    # ::tcltest::numTests will store test files as indices and the list
    # of files (that should not have been) left behind by the test files.
    array set ::tcltest::createdNewFiles {}

    # initialize ::tcltest::numTests array to keep track fo the number of
    # tests that pass, fial, and are skipped.
    array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # initialize ::tcltest::skippedBecause array to keep track of
    # constraints that kept tests from running
................................................................................
    if {[catch {array set flag $flagArray}]} {
	puts stderr "Error:  odd number of command line args specified:"
	puts stderr "        $argv"
	exit
    }
    
    # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
    # Note that -verbose cannot be abbreviated to -v in wish because it
    # conflicts with the wish option -visual.
    foreach arg {-verbose -match -skip -constraints} {
	set abbrev [string range $arg 0 1]
	if {([info exists flag($abbrev)]) && \
		([lsearch -exact $flagArray $arg] < \
		[lsearch -exact $flagArray $abbrev])} {
	    set flag($arg) $flag($abbrev)
	}
................................................................................
# since the tests were invoked.
#
# Print the number tests (total, passed, failed, and skipped) since the
# tests were invoked.
#

proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
    set tail [file tail [info script]]

    # Remove files and directories created by the :tcltest::makeFile and
    # ::tcltest::makeDirectory procedures.
    # Record the names of files in ::tcltest::workingDir that were not
    # pre-existing, and associate them with the test file that created them.
    if {!$calledFromAllFile} {

	foreach file $::tcltest::filesMade {
	    if {[file exists $file]} {
		#catch {file delete -force $file}

	    }
	}
	set currentFiles {}
	foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
	    lappend currentFiles [file tail $file]
	}

	set newFiles {}
	foreach file $currentFiles {
	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
		lappend newFiles $file
	    }
	}
	set ::tcltest::filesExisted $currentFiles
	if {[llength $newFiles] > 0} {
	    set ::tcltest::createdNewFiles($tail) $newFiles
	}
    }

    if {$calledFromAllFile || $::tcltest::testSingleFile} {
	# print stats
	puts -nonewline stdout "$tail:"
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
	}
	puts stdout ""
................................................................................
	    foreach constraint [lsort [array names ::tcltest::skippedBecause]] {
		puts stdout \
			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
		unset ::tcltest::skippedBecause($constraint)
	    }
	}

	# report the names of test files in ::tcltest::createdNewFiles, and
	# reset the array to be empty.

	set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
	if {[llength $testFilesThatTurded] > 0} {
	    puts stdout "Warning: test files left files behind:"
	    foreach testFile $testFilesThatTurded {

		puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
		unset ::tcltest::createdNewFiles($testFile)




	    }
	}




	# reset filesMade, filesExisted, and numTests
	set ::tcltest::filesMade {}

	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set ::tcltest::numTests($index) 0
	}

	# exit only if running Tk in non-interactive mode
	global tk_version tcl_interactive
	if {[info exists tk_version] && !$tcl_interactive} {
................................................................................
    # process running in the background.
    
    # Locate the tktest executable

    set ::tcltest::tktest [info nameofexecutable]
    if {$::tcltest::tktest == "{}"} {
	set ::tcltest::tktest {}
	puts stdout \
		"Unable to find tktest executable, skipping multiple process tests."
    }

    # Create background process
    
    proc ::tcltest::setupbg args {
	if {$::tcltest::tktest == ""} {
	    error "you're not running tktest so setupbg should not have been called"