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