1# This file tests the routines in tclResult.c. 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright © 1997 Sun Microsystems, Inc. 8# Copyright © 1998-1999 Scriptics Corporation. 9# 10# See the file "license.terms" for information on usage and redistribution 11# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 13if {"::tcltest" ni [namespace children]} { 14 package require tcltest 2.5 15 namespace import -force ::tcltest::* 16} 17 18::tcltest::loadTestedCommands 19catch [list package require -exact tcl::test [info patchlevel]] 20 21# Some tests require the testsaveresult command 22 23testConstraint testsaveresult [llength [info commands testsaveresult]] 24testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]] 25testConstraint testseterrorcode [llength [info commands testseterrorcode]] 26testConstraint testreturn [llength [info commands testreturn]] 27 28test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} { 29 testsaveresult small {set x 42} 0 30} {small result} 31test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { 32 testsaveresult append {set x 42} 0 33} {append result} 34test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { 35 testsaveresult dynamic {set x 42} 0 36} {dynamic result presentOrFreed} 37test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { 38 testsaveresult object {set x 42} 0 39} {object result same} 40test result-1.5 {Tcl_SaveInterpResult} {testsaveresult} { 41 testsaveresult small {set x 42} 1 42} {42} 43test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { 44 testsaveresult append {set x 42} 1 45} {42} 46test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { 47 testsaveresult dynamic {set x 42} 1 48} {42 presentOrFreed} 49test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { 50 testsaveresult object {set x 42} 1 51} {42 different} 52 53# Tcl_RestoreInterpResult is mostly tested by the previous tests except 54# for the following case 55 56test result-2.1 {Tcl_RestoreInterpResult} {testsaveresult} { 57 testsaveresult append {cd _foobar} 0 58} {append result} 59 60# Tcl_DiscardInterpResult is mostly tested by the previous tests except 61# for the following cases 62 63test result-3.1 {Tcl_DiscardInterpResult} -constraints testsaveresult -body { 64 testsaveresult append {cd _foobar} 1 65} -returnCodes error -result {couldn't change working directory to "_foobar": no such file or directory} 66test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} { 67 testsaveresult free {set x 42} 1 68} {42} 69 70test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsetobjerrorcode} { 71 catch {testsetobjerrorcode 1} 72 list [set errorCode] 73} {1} 74test result-4.2 {Tcl_SetObjErrorCode - two args} {testsetobjerrorcode} { 75 catch {testsetobjerrorcode 1 2} 76 list [set errorCode] 77} {{1 2}} 78test result-4.3 {Tcl_SetObjErrorCode - three args} {testsetobjerrorcode} { 79 catch {testsetobjerrorcode 1 2 3} 80 list [set errorCode] 81} {{1 2 3}} 82test result-4.4 {Tcl_SetObjErrorCode - four args} {testsetobjerrorcode} { 83 catch {testsetobjerrorcode 1 2 3 4} 84 list [set errorCode] 85} {{1 2 3 4}} 86test result-4.5 {Tcl_SetObjErrorCode - five args} {testsetobjerrorcode} { 87 catch {testsetobjerrorcode 1 2 3 4 5} 88 list [set errorCode] 89} {{1 2 3 4 5}} 90 91test result-5.1 {Tcl_SetErrorCode - one arg} testseterrorcode { 92 catch {testseterrorcode 1} 93 set errorCode 94} 1 95test result-5.2 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode { 96 catch {testseterrorcode {a b}} 97 set errorCode 98} {{a b}} 99test result-5.3 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode { 100 catch {testseterrorcode \{} 101 llength $errorCode 102} 1 103test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode { 104 catch {testseterrorcode {a b} c} 105 set errorCode 106} {{a b} c} 107 108test result-6.0 {Bug 1209759} -constraints testreturn -body { 109 # Might panic if bug is not fixed. 110 proc foo {} {testreturn} 111 foo 112} -returnCodes ok -result {} 113test result-6.1 {Bug 1209759} -constraints testreturn -body { 114 # Might panic if bug is not fixed. 115 proc foo {} {catch {return -level 2}; testreturn} 116 foo 117} -cleanup { 118 rename foo {} 119} -returnCodes ok -result {} 120test result-6.2 {Bug 1649062} -setup { 121 proc foo {} { 122 if {[catch { 123 return -code error -errorinfo custom -errorcode CUSTOM foo 124 } err]} { 125 return [list $err $::errorCode $::errorInfo] 126 } 127 } 128 set ::errorInfo {} 129 set ::errorCode {} 130} -body { 131 foo 132} -cleanup { 133 rename foo {} 134} -result {foo {} {}} 135test result-6.3 {Bug 2383005} { 136 catch {return -code error -errorcode {{}a} eek} m 137 set m 138} {bad -errorcode value: expected a list but got "{}a"} 139test result-6.4 {non-list -errorstack} -body { 140 catch {return -code error -errorstack {{}a} eek} m o 141 list $m [dict get $o -errorcode] [dict get $o -errorstack] 142} -match glob -result {{bad -errorstack value: expected a list but got "{}a"} {TCL RESULT NONLIST_ERRORSTACK} {INNER * UP 1}} 143test result-6.5 {odd-sized-list -errorstack} -body { 144 catch {return -code error -errorstack a eek} m o 145 list $m [dict get $o -errorcode] [dict get $o -errorstack] 146} -match glob -result {{forbidden odd-sized list for -errorstack: "a"} {TCL RESULT ODDSIZEDLIST_ERRORSTACK} {INNER * UP 1}} 147# cleanup 148cleanupTests 149return 150