summaryrefslogtreecommitdiffstats
path: root/tests/basic.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/basic.test')
-rw-r--r--tests/basic.test98
1 files changed, 26 insertions, 72 deletions
diff --git a/tests/basic.test b/tests/basic.test
index c90d80e..91e4d6c 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -9,19 +9,14 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright (c) 1997 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.
-if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.5
- namespace import -force ::tcltest::*
-}
-
-::tcltest::loadTestedCommands
-catch [list package require -exact tcl::test [info patchlevel]]
+package require tcltest 2
+namespace import ::tcltest::*
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
@@ -226,21 +221,6 @@ test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified i
list [test_ns_basic::cmd] \
[namespace delete test_ns_basic]
} {::test_ns_basic {}}
-test basic-15.2 {Tcl_CreateObjCommand, Bug 0e4d88b650} -setup {
- proc deleter {ns args} {
- namespace delete $ns
- }
- namespace eval n {
- proc p {} {}
- }
- trace add command n::p delete [list [namespace which deleter] [namespace current]::n]
-} -body {
- proc n::p {} {}
-} -cleanup {
- namespace delete n
- rename deleter {}
-}
-
test basic-16.1 {TclInvokeStringCommand} {emptyTest} {
} {}
@@ -258,7 +238,7 @@ test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace quali
}
list [test_ns_basic::p] \
[rename test_ns_basic::p test_ns_basic::q] \
- [test_ns_basic::q]
+ [test_ns_basic::q]
} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
test basic-18.2 {TclRenameCommand, existing cmd must be found} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
@@ -348,7 +328,7 @@ test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespac
test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken {
catch {rename \# ""}
set x [testcmdtoken create \#]
- return [testcmdtoken name $x]
+ testcmdtoken name $x
} {{#} ::#}
test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
@@ -471,11 +451,11 @@ test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body {
# a - the pure-list internal rep is destroyed by shimmering
# b - the command returns an error
# As the error code in Tcl_EvalObjv accesses the list elements, this will
- # cause a segfault if [Bug 1119369] has not been fixed.
+ # cause a segfault if [Bug 1119369] has not been fixed.
# NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
#
- set SRC [list foo 1] ;# pure-list command
+ set SRC [list foo 1] ;# pure-list command
proc foo str {
# Shimmer pure-list to cmdName, cleanup and error
proc $::SRC {} {}; $::SRC
@@ -493,11 +473,11 @@ test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body {
# Follow the pure-list branch in a manner that
# a - the pure-list internal rep is destroyed by shimmering
# b - the command accesses its command line
- # This will cause a segfault if [Bug 1119369] has not been fixed.
+ # This will cause a segfault if [Bug 1119369] has not been fixed.
# NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
#
- set SRC [list foo 1] ;# pure-list command
+ set SRC [list foo 1] ;# pure-list command
proc foo str {
# Shimmer pure-list to cmdName, cleanup and error
proc $::SRC {} {}; $::SRC
@@ -609,7 +589,7 @@ test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup {
invoked "break" outside of a loop
while executing
"break"
- (file "*BREAKtest" line 3)}
+ (file "*BREAKtest" line 3)}
test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
@@ -626,7 +606,7 @@ test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
} -returnCodes error -match glob -result {invoked "break" outside of a loop
while executing
"break"
- (file "*BREAKtest" line 4)}
+ (file "*BREAKtest" line 4)}
test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
@@ -658,10 +638,8 @@ test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
"return -code return"
(file "*BREAKtest" line 2)}
-test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -constraints {
- testevalex
-} -body {
- testevalex {a[set b [format cd]}
+test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body {
+ subst {a[set b [format cd]}
} -returnCodes error -result {missing close-bracket}
# Some lists for expansion tests to work with
@@ -672,9 +650,9 @@ proc l3 {} {
}
# Do all tests once byte compiled and once with direct string evaluation
-foreach noComp {0 1} {
+for {set noComp 0} {$noComp <= 1} {incr noComp} {
-if {$noComp} {
+if $noComp {
interp alias {} run {} testevalex
set constraints testevalex
} else {
@@ -754,7 +732,7 @@ test basic-48.1.$noComp {expansion: parsing} $constraints {
# Another comment
list 1 2\
3 {*}$::l1
-
+
# Comment again
}
} {1 2 3 a {b b} c d}
@@ -827,7 +805,7 @@ test basic-48.13.$noComp {expansion: odd usage} $constraints {
test basic-48.14.$noComp {expansion: hash command} -setup {
catch {rename \# ""}
set cmd "#"
- } -constraints $constraints -body {
+ } -constraints $constraints -body {
run { {*}$cmd apa bepa }
} -cleanup {
unset cmd
@@ -887,7 +865,7 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup {
stress
set tmp $end
set end [getbytes]
- }
+ }
set leak [expr {$end - $tmp}]
} -cleanup {
unset end i tmp
@@ -895,17 +873,21 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup {
rename stress {}
} -result 0
-test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body {
+test basic-48.17.$noComp {expansion: object safety} -setup {
+ set old_precision $::tcl_precision
+ set ::tcl_precision 4
+ } -constraints $constraints -body {
set third [expr {1.0/3.0}]
set l [list $third $third]
set x [run {list $third {*}$l $third}]
- set res [list]
+ set res [list]
foreach t $x {
lappend res [expr {$t * 3.0}]
}
set res
} -cleanup {
- unset res t l x third
+ set ::tcl_precision $old_precision
+ unset old_precision res t l x third
} -result {1.0 1.0 1.0 1.0}
test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body {
@@ -960,24 +942,6 @@ test basic-48.23.$noComp {expansion: handle return codes} -constraints $constrai
unset res t
} -result {0 10 1 Hejsan}
-test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
- unset -nocomplain a
-} -body {
- run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
-} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
-
-test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -constraints $constraints -setup {
- unset -nocomplain ::CRLF
- set ::CRLF "\r\n"
-} -body {
- # Force variant that turned up in Bug 2c154a40be as that's externally
- # noticeable in an important downstream project.
- run {scan [list {*}$::CRLF]x %c%c%c}
-} -cleanup {
- unset -nocomplain ::CRLF
-} -result {120 {} {}}
-
-
} ;# End of noComp loop
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
@@ -1000,16 +964,6 @@ test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::context
} {global}
-test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup {
- interp create child
- interp alias {} foo child return
-} -body {
- list [catch foo m] $m
-} -cleanup {
- unset -nocomplain m
- interp delete child
-} -result {0 {}}
-
# Clean up after expand tests
unset noComp l1 l2 constraints
rename l3 {}
generated by cgit v0.12 at 2025-12-20 09:44:48 (GMT)