Tcl Source Code

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

................................................................................
    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
................................................................................
} {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"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }

#
# 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.14 1999/04/07 02:38:10 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:

................................................................................
    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--bug 1637} \
	{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--bug 1637} \
	{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--bug 1637} \
	{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
................................................................................
} {msg
    while executing
"MyError "some secret""
    (procedure "MyTestAlias" line 2)
    invoked from within
"test"}

test interp-26.8 {errorInfo transmission: safe interps--bug 1637} {knownBug} {
    # this test fails because the errorInfo is fully transmitted
    # whether the interp is safe or not.  The errorInfo should never
    # report data from the master interpreter because it could
    # contain sensitive information.
    set interp [interp create -safe];
    proc MyError {secret} {
	return -code error "msg"
    }
    proc MyTestAlias {interp args} {
	MyError "some secret"
    }

#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.8 1999/04/01 23:22:32 welch Exp $

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

# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir
if {"$::tcltest::testsDir" != "$::tcltest::workingDir"} {
................................................................................
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}}}}}

# Some tests require the existence of one of the DLLs in the dltest directory
set x [file join $::tcltest::testsDir \
	../unix/dltest/pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
set ::tcltest::testConfig($dll) [file exists $x]

test pkgMkIndex-10.1 {package in DLL and script} $dll {
    file copy -force $x pkg
    pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl
} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"

#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.9 1999/04/07 02:38:11 hershey Exp $

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

# temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir
if {"$::tcltest::testsDir" != "$::tcltest::workingDir"} {
................................................................................
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}}}}}

# Some tests require the existence of one of the DLLs in the dltest directory
set x [file join [file dirname [info nameofexecutable]] dltest \
	pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
set ::tcltest::testConfig($dll) [file exists $x]

test pkgMkIndex-10.1 {package in DLL and script} $dll {
    file copy -force $x pkg
    pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl
} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"