Tcl Source Code

Check-in [043d97f05e]
Login

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

Overview
Comment:change tcltest namespace variables from matchingTests and skippingTests to match and skip.

removed nonexistent constraint from interp.test and renumbered tests to remove duplicates.

Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 043d97f05ec274044a71b33b32f114495a463d25
User & Date: hershey 1999-04-07 01:59:27.000
Context
1999-04-07
02:38
fixed bad pkga.so constraint check-in: ef1faecd65 user: hershey tags: core-8-1-branch-old
01:59
change tcltest namespace variables from matchingTests and skippingTests to match and skip.

removed ... check-in: 043d97f05e user: hershey tags: core-8-1-branch-old

01:29
Fixed hang in tests when built with thread support. check-in: acc054dca8 user: stanton tags: core-8-1-branch-old
Changes
Unified Diff Ignore Whitespace Patch
Changes to tests/README.
1
2
3
4
5
6
7
8
9
10
README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.7 1999/04/02 18:57:06 hershey Exp $

Contents:
---------

    1. Introduction
    2. Definitions file
    3. Writing a new test


|







1
2
3
4
5
6
7
8
9
10
README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.1.2.8 1999/04/07 01:59:27 hershey Exp $

Contents:
---------

    1. Introduction
    2. Definitions file
    3. Writing a new test
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
			     constraints.

    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".  To use the options in
	interactive mode, you can set their corresponding tcltest
	namespace variables after sourcing the defs.tcl file.
		  ::tcltest::matchingTests
		  ::tcltest::skippingTests
		  ::tcltest::testConfig(nonPortable)
		  ::tcltest::testConfig(knownBug)
		  ::tcltest::testConfig(userInteractive)

In all cases, no output will be generated if all goes well, except for
a listing of the test files and a statistical summary.  If there are
errors, then additional messages will appear in the format described







|
|







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
			     constraints.

    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".  To use the options in
	interactive mode, you can set their corresponding tcltest
	namespace variables after sourcing the defs.tcl file.
		  ::tcltest::match
		  ::tcltest::skip
		  ::tcltest::testConfig(nonPortable)
		  ::tcltest::testConfig(knownBug)
		  ::tcltest::testConfig(userInteractive)

In all cases, no output will be generated if all goes well, except for
a listing of the test files and a statistical summary.  If there are
errors, then additional messages will appear in the format described
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
-----------------------------------------------

Normally, all the tests in a file are run whenever the file is
sourced.  An individual test will be skipped if one of the following
conditions is met:

    1) the "name" of the tests does not match (using glob style
       matching) one or more elements in the ::tcltest::matchingTests
       variable

    2) the "name" of the tests matches (using glob style matching) one
       or more elements in the ::tcltest::skippingTests variable

    3) the "constraints" argument to the "test" call, if given,
       contains one or more false elements.

You can set ::tcltest::matchingTests and/or ::tcltest::skippingTests
either interactively (after the defs.tcl file has been sourced), or by
the command line arguments -match and -skip, for example:

       tcltest info.test -match '*-5.* *-7.*' -skip '*-7.1*'

Be sure to use the proper quoting convention so that your shell does
not perform the glob substitution on the match or skip patterns you







|



|




|







327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
-----------------------------------------------

Normally, all the tests in a file are run whenever the file is
sourced.  An individual test will be skipped if one of the following
conditions is met:

    1) the "name" of the tests does not match (using glob style
       matching) one or more elements in the ::tcltest::match
       variable

    2) the "name" of the tests matches (using glob style matching) one
       or more elements in the ::tcltest::skip variable

    3) the "constraints" argument to the "test" call, if given,
       contains one or more false elements.

You can set ::tcltest::match and/or ::tcltest::skip
either interactively (after the defs.tcl file has been sourced), or by
the command line arguments -match and -skip, for example:

       tcltest info.test -match '*-5.* *-7.*' -skip '*-7.1*'

Be sure to use the proper quoting convention so that your shell does
not perform the glob substitution on the match or skip patterns you
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "tcltest" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::tcltest::verbose
   TESTS      ::tcltest::matchingTests
   testConfig ::tcltest::testConfig

   The introduction of the "tcltest" namespace is a precursor to using
   a "tcltest" package.  This next step will be part of a future Tcl
   version.

2) VERBOSE values are no longer numeric.  Please see the section above







|







392
393
394
395
396
397
398
399
400
401
402
403
404
405
406

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "tcltest" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::tcltest::verbose
   TESTS      ::tcltest::match
   testConfig ::tcltest::testConfig

   The introduction of the "tcltest" namespace is a precursor to using
   a "tcltest" package.  This next step will be part of a future Tcl
   version.

2) VERBOSE values are no longer numeric.  Please see the section above
Changes to tests/all.tcl.
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
# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests.  Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: all.tcl,v 1.1.2.5 1999/03/24 02:48:54 hershey Exp $

if {[lsearch ::tcltest [namespace children]] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
set ::tcltest::testSingleFile false

puts stdout "Tcl $tcl_patchLevel tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::tcltest::workingDir"
if {[llength $::tcltest::skippingTests] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skippingTests"
}
if {[llength $::tcltest::matchingTests] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::matchingTests"
}

# Use command line specified glob pattern (specified by -file or -f)
# if one exists.  Otherwise use *.test.  If given, the file pattern
# should be specified relative to the dir containing this file.  If no
# files are found to match the pattern, print an error message and exit.
set fileIndex [expr {[lsearch $argv "-file"] + 1}]









|








|
|

|
|







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
# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests.  Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: all.tcl,v 1.1.2.6 1999/04/07 01:59:27 hershey Exp $

if {[lsearch ::tcltest [namespace children]] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}
set ::tcltest::testSingleFile false

puts stdout "Tcl $tcl_patchLevel tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::tcltest::workingDir"
if {[llength $::tcltest::skip] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skip"
}
if {[llength $::tcltest::match] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::match"
}

# Use command line specified glob pattern (specified by -file or -f)
# if one exists.  Otherwise use *.test.  If given, the file pattern
# should be specified relative to the dir containing this file.  If no
# files are found to match the pattern, print an error message and exit.
set fileIndex [expr {[lsearch $argv "-file"] + 1}]
Changes to tests/defs.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# defs.tcl --
#
#	This file contains support code for the Tcl/Tk test suite.It is
#	It is normally sourced by the individual files in the test suite
#	before they run their tests.  This improved approach to testing
#	was designed and initially implemented by Mary Ann May-Pumphrey
#	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.10 1999/04/03 03:02:47 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.













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# defs.tcl --
#
#	This file contains support code for the Tcl/Tk test suite.It is
#	It is normally sourced by the individual files in the test suite
#	before they run their tests.  This improved approach to testing
#	was designed and initially implemented by Mary Ann May-Pumphrey
#	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.11 1999/04/07 01:59:27 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.
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"
    variable verbose "b"

    # matchingTests defaults to the empty list
    variable matchingTests {}

    # skippingTests defaults to the empty list
    variable skippingTests {}

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative to
    # ::tcltest::testsDir.

    set originalDir [pwd]
    set tDir [file join $originalDir [file dirname [info script]]]







|
|

|
|







34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"
    variable verbose "b"

    # match defaults to the empty list
    variable match {}

    # skip defaults to the empty list
    variable skip {}

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative to
    # ::tcltest::testsDir.

    set originalDir [pwd]
    set tDir [file join $originalDir [file dirname [info script]]]
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
}

::tcltest::initConfig


# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the verbose, skippingTests, and
#	matchingTests variables.  This procedure must be run after
#	constraints are initialized, because some constraints can be
#	overridden.
#
# Arguments:
#	none
#
# Results:







|
|







316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
}

::tcltest::initConfig


# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the verbose, skip, and
#	match variables.  This procedure must be run after
#	constraints are initialized, because some constraints can be
#	overridden.
#
# Arguments:
#	none
#
# Results:
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
    }

    # Set ::tcltest::verbose to the arg of the -verbose flag, if given
    if {[info exists flag(-verbose)]} {
	set ::tcltest::verbose $flag(-verbose)
    }

    # Set ::tcltest::matchingTests to the arg of the -match flag, if given
    if {[info exists flag(-match)]} {
	set ::tcltest::matchingTests $flag(-match)
    }

    # Set ::tcltest::skippingTests to the arg of the -skip flag, if given
    if {[info exists flag(-skip)]} {
	set ::tcltest::skippingTests $flag(-skip)
    }

    # Use the -constraints flag, if given, to turn on constraints that are
    # turned off by default: userInteractive knownBug nonPortable.  This
    # code fragment must be run after constraints are initialized.
    if {[info exists flag(-constraints)]} {
	foreach elt $flag(-constraints) {







|

|


|

|







368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
    }

    # Set ::tcltest::verbose to the arg of the -verbose flag, if given
    if {[info exists flag(-verbose)]} {
	set ::tcltest::verbose $flag(-verbose)
    }

    # Set ::tcltest::match to the arg of the -match flag, if given
    if {[info exists flag(-match)]} {
	set ::tcltest::match $flag(-match)
    }

    # Set ::tcltest::skip to the arg of the -skip flag, if given
    if {[info exists flag(-skip)]} {
	set ::tcltest::skip $flag(-skip)
    }

    # Use the -constraints flag, if given, to turn on constraints that are
    # turned off by default: userInteractive knownBug nonPortable.  This
    # code fragment must be run after constraints are initialized.
    if {[info exists flag(-constraints)]} {
	foreach elt $flag(-constraints) {
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550


# test --
#
# This procedure runs a test and prints an error message if the test fails.
# If ::tcltest::verbose has been set, it also prints a message even if the
# test succeeds.  The test will be skipped if it doesn't match the
# ::tcltest::matchingTests variable, if it matches an element in
# ::tcltest::skippingTests, or if one of the elements of "constraints" turns
# out not to be true.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to
#			help humans understand what it does.
# constraints -		A list of one or more keywords, each of
#			which must be the name of an element in
#			the array "::tcltest::testConfig".  If any of these
#			elements is zero, the test is skipped.
#			This argument may be omitted.
# script -		Script to run to carry out the test.  It must
#			return a result that can be checked for
#			correctness.
# expectedAnswer -	Expected result from script.

proc ::tcltest::test {name description script expectedAnswer args} {
    incr ::tcltest::numTests(Total)

    # skip the test if it's name matches an element of skippingTests
    foreach pattern $::tcltest::skippingTests {
	if {[string match $pattern $name]} {
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    }
    # skip the test if it's name doesn't match any element of matchingTests
    if {[llength $::tcltest::matchingTests] > 0} {
	set ok 0
	foreach pattern $::tcltest::matchingTests {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    incr ::tcltest::numTests(Skipped)







|
|



















|
|





|
|

|







505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550


# test --
#
# This procedure runs a test and prints an error message if the test fails.
# If ::tcltest::verbose has been set, it also prints a message even if the
# test succeeds.  The test will be skipped if it doesn't match the
# ::tcltest::match variable, if it matches an element in
# ::tcltest::skip, or if one of the elements of "constraints" turns
# out not to be true.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to
#			help humans understand what it does.
# constraints -		A list of one or more keywords, each of
#			which must be the name of an element in
#			the array "::tcltest::testConfig".  If any of these
#			elements is zero, the test is skipped.
#			This argument may be omitted.
# script -		Script to run to carry out the test.  It must
#			return a result that can be checked for
#			correctness.
# expectedAnswer -	Expected result from script.

proc ::tcltest::test {name description script expectedAnswer args} {
    incr ::tcltest::numTests(Total)

    # skip the test if it's name matches an element of skip
    foreach pattern $::tcltest::skip {
	if {[string match $pattern $name]} {
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    }
    # skip the test if it's name doesn't match any element of match
    if {[llength $::tcltest::match] > 0} {
	set ok 0
	foreach pattern $::tcltest::match {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    incr ::tcltest::numTests(Skipped)
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
#	file    name of tests file to source
#	args    pattern selecting the tests you want to execute
#
# Results:
#	none

proc ::tcltest::dotests {file args} {
    set savedTests $::tcltest::matchingTests
    set ::tcltest::matchingTests $args
    source $file
    set ::tcltest::matchingTests $savedTests
}

proc ::tcltest::openfiles {} {
    if {[catch {testchannel open} result]} {
	return {}
    }
    return $result







|
|

|







657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
#	file    name of tests file to source
#	args    pattern selecting the tests you want to execute
#
# Results:
#	none

proc ::tcltest::dotests {file args} {
    set savedTests $::tcltest::match
    set ::tcltest::match $args
    source $file
    set ::tcltest::match $savedTests
}

proc ::tcltest::openfiles {} {
    if {[catch {testchannel open} result]} {
	return {}
    }
    return $result
Changes to tests/interp.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.12 1999/04/06 04:51:22 rjohnson Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The set of hidden commands is platform dependent:













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.1.2.13 1999/04/07 01:59:28 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

# The set of hidden commands is platform dependent:

1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
    for {set code -1} {$code<=5} {incr code} {
	lappend res [interp eval a [list catch [list Test $code] msg]]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.4 {result code transmission : invoke hidden direct} {knownBug} {
    # The known bug is that code 2 is returned, not the -code argument
    catch {interp delete a}
    interp create a
    set res {}
    interp hide a return
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp invokehidden a return -code $code ret$code}]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.5 {result code transmission : invoke hidden indirect} {knownBug} {
    # The known bug is that the break and continue should raise errors
    # that they are used outside a loop.
    catch {interp delete a}
    interp create a
    set res {}
    interp eval a {proc retcode {code} {return -code $code ret$code}}
    interp hide a retcode
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp invokehidden a retcode $code} msg] $msg
    }
    interp delete a
    set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}

test interp-26.6 {result code transmission : all combined} {knownBug} {
    # Test that all the possibles error codes from Tcl get passed
    # In both directions.  This doesn't work.
    set interp [interp create];
    proc MyTestAlias {interp args} {
	global aliasTrace;
	lappend aliasTrace $args;
	eval interp invokehidden [list $interp] $args







|












|














|







1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
    for {set code -1} {$code<=5} {incr code} {
	lappend res [interp eval a [list catch [list Test $code] msg]]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.4 {result code transmission: invoke hidden direct} {knownBug} {
    # The known bug is that code 2 is returned, not the -code argument
    catch {interp delete a}
    interp create a
    set res {}
    interp hide a return
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp invokehidden a return -code $code ret$code}]
    }
    interp delete a
    set res
} {-1 0 1 2 3 4 5}

test interp-26.5 {result code transmission: invoke hidden indirect} {knownBug} {
    # The known bug is that the break and continue should raise errors
    # that they are used outside a loop.
    catch {interp delete a}
    interp create a
    set res {}
    interp eval a {proc retcode {code} {return -code $code ret$code}}
    interp hide a retcode
    for {set code -1} {$code<=5} {incr code} {
	lappend res [catch {interp invokehidden a retcode $code} msg] $msg
    }
    interp delete a
    set res
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}

test interp-26.6 {result code transmission: all combined} {knownBug} {
    # Test that all the possibles error codes from Tcl get passed
    # In both directions.  This doesn't work.
    set interp [interp create];
    proc MyTestAlias {interp args} {
	global aliasTrace;
	lappend aliasTrace $args;
	eval interp invokehidden [list $interp] $args
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}

# Some tests might need to be added to check for difference between
# toplevel and non toplevel evals.

# End of return code transmission section

test interp-26.5 {errorInfo transmission : regular interps} {
    set interp [interp create];
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
    interp alias $interp test {} MyTestAlias $interp;
    set res [interp eval $interp {catch test;set errorInfo}]
    interp delete $interp;
    set res
} {msg
    while executing
"MyError "some secret""
    (procedure "MyTestAlias" line 2)
    invoked from within
"test"}

test interp-26.6 {errorInfo transmission : safe interps} {knownBug tasteIssue} {
    # this test fails because the errorInfo is fully transmitted
    # whether the interp is safe or not. this is maybe a feature
    # and not a bug.
    set interp [interp create -safe];
    proc MyError {secret} {
	return -code error "msg"
    }







|


















|







2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}

# Some tests might need to be added to check for difference between
# toplevel and non toplevel evals.

# End of return code transmission section

test interp-26.7 {errorInfo transmission: regular interps} {
    set interp [interp create];
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }
    interp alias $interp test {} MyTestAlias $interp;
    set res [interp eval $interp {catch test;set errorInfo}]
    interp delete $interp;
    set res
} {msg
    while executing
"MyError "some secret""
    (procedure "MyTestAlias" line 2)
    invoked from within
"test"}

test interp-26.8 {errorInfo transmission: safe interps} {knownBug} {
    # this test fails because the errorInfo is fully transmitted
    # whether the interp is safe or not. this is maybe a feature
    # and not a bug.
    set interp [interp create -safe];
    proc MyError {secret} {
	return -code error "msg"
    }