[25] | 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 (c) 1997 by Sun Microsystems, Inc. |
---|
| 8 | # Copyright (c) 1998-1999 by 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 | # |
---|
| 13 | # SCCS: @(#) result.test 1.4 97/12/08 15:07:49 |
---|
| 14 | |
---|
| 15 | if {[lsearch [namespace children] ::tcltest] == -1} { |
---|
| 16 | package require tcltest 2 |
---|
| 17 | namespace import -force ::tcltest::* |
---|
| 18 | } |
---|
| 19 | |
---|
| 20 | # Some tests require the testsaveresult command |
---|
| 21 | |
---|
| 22 | testConstraint testsaveresult [llength [info commands testsaveresult]] |
---|
| 23 | testConstraint testsetobjerrorcode [llength [info commands testsetobjerrorcode]] |
---|
| 24 | testConstraint testseterrorcode [llength [info commands testseterrorcode]] |
---|
| 25 | testConstraint testreturn [llength [info commands testreturn]] |
---|
| 26 | |
---|
| 27 | test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} { |
---|
| 28 | testsaveresult small {set x 42} 0 |
---|
| 29 | } {small result} |
---|
| 30 | test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { |
---|
| 31 | testsaveresult append {set x 42} 0 |
---|
| 32 | } {append result} |
---|
| 33 | test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { |
---|
| 34 | testsaveresult dynamic {set x 42} 0 |
---|
| 35 | } {dynamic result notCalled present} |
---|
| 36 | test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { |
---|
| 37 | testsaveresult object {set x 42} 0 |
---|
| 38 | } {object result same} |
---|
| 39 | test result-1.5 {Tcl_SaveInterpResult} {testsaveresult} { |
---|
| 40 | testsaveresult small {set x 42} 1 |
---|
| 41 | } {42} |
---|
| 42 | test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { |
---|
| 43 | testsaveresult append {set x 42} 1 |
---|
| 44 | } {42} |
---|
| 45 | test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { |
---|
| 46 | testsaveresult dynamic {set x 42} 1 |
---|
| 47 | } {42 called missing} |
---|
| 48 | test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { |
---|
| 49 | testsaveresult object {set x 42} 1 |
---|
| 50 | } {42 different} |
---|
| 51 | |
---|
| 52 | |
---|
| 53 | # Tcl_RestoreInterpResult is mostly tested by the previous tests except |
---|
| 54 | # for the following case |
---|
| 55 | |
---|
| 56 | test 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 | |
---|
| 63 | test result-3.1 {Tcl_DiscardInterpResult} {testsaveresult} { |
---|
| 64 | list [catch {testsaveresult append {cd _foobar} 1} msg] $msg |
---|
| 65 | } {1 {couldn't change working directory to "_foobar": no such file or directory}} |
---|
| 66 | test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} { |
---|
| 67 | testsaveresult free {set x 42} 1 |
---|
| 68 | } {42} |
---|
| 69 | |
---|
| 70 | test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsetobjerrorcode} { |
---|
| 71 | catch {testsetobjerrorcode 1} |
---|
| 72 | list [set errorCode] |
---|
| 73 | } {1} |
---|
| 74 | test result-4.2 {Tcl_SetObjErrorCode - two args} {testsetobjerrorcode} { |
---|
| 75 | catch {testsetobjerrorcode 1 2} |
---|
| 76 | list [set errorCode] |
---|
| 77 | } {{1 2}} |
---|
| 78 | test result-4.3 {Tcl_SetObjErrorCode - three args} {testsetobjerrorcode} { |
---|
| 79 | catch {testsetobjerrorcode 1 2 3} |
---|
| 80 | list [set errorCode] |
---|
| 81 | } {{1 2 3}} |
---|
| 82 | test result-4.4 {Tcl_SetObjErrorCode - four args} {testsetobjerrorcode} { |
---|
| 83 | catch {testsetobjerrorcode 1 2 3 4} |
---|
| 84 | list [set errorCode] |
---|
| 85 | } {{1 2 3 4}} |
---|
| 86 | test 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 | |
---|
| 91 | test result-5.1 {Tcl_SetErrorCode - one arg} testseterrorcode { |
---|
| 92 | catch {testseterrorcode 1} |
---|
| 93 | set errorCode |
---|
| 94 | } 1 |
---|
| 95 | test result-5.2 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode { |
---|
| 96 | catch {testseterrorcode {a b}} |
---|
| 97 | set errorCode |
---|
| 98 | } {{a b}} |
---|
| 99 | test result-5.3 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode { |
---|
| 100 | catch {testseterrorcode \{} |
---|
| 101 | llength $errorCode |
---|
| 102 | } 1 |
---|
| 103 | test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode { |
---|
| 104 | catch {testseterrorcode {a b} c} |
---|
| 105 | set errorCode |
---|
| 106 | } {{a b} c} |
---|
| 107 | |
---|
| 108 | test 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 {} |
---|
| 113 | test 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 {} |
---|
| 120 | test 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 {} {}} |
---|
| 135 | |
---|
| 136 | |
---|
| 137 | # cleanup |
---|
| 138 | cleanupTests |
---|
| 139 | return |
---|