Tcl Source Code

#
# Copyright (c) 1996-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.
#
# RCS: @(#) $Id: expr.test,v 1.1.2.5 1999/03/24 02:49:08 hershey Exp $

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

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
................................................................................
        set x  [expr $x+$f+$center]
        set x  [expr $x+$f+$center]
        set y  [expr round($x)]
    }
    p
} 3

# cleanup
unset a
::tcltest::cleanupTests
return

#
# Copyright (c) 1996-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.
#
# RCS: @(#) $Id: expr.test,v 1.1.2.6 1999/04/02 23:44:37 stanton Exp $

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

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
................................................................................
        set x  [expr $x+$f+$center]
        set x  [expr $x+$f+$center]
        set y  [expr round($x)]
    }
    p
} 3

# Test for incorrect "double evaluation" semantics




test expr-20.1 {wrong brace matching} {
    catch {unset l}
    catch {unset r}
    catch {unset q}
    catch {unset cmd}
    catch {unset a}
    set l "\{"; set r "\}"; set q "\""
    set cmd "expr $l$q|$q == $q$r$q$r"
    list [catch $cmd a] $a
} {1 {extra characters after close-brace}}
test expr-20.2 {double invocation of variable traces} {knownBug} {
    set exprtracecounter 0
    proc exprtraceproc {args} {
       upvar #0 exprtracecounter counter
       set argc [llength $args]
       set extraargs [lrange $args 0 [expr {$argc - 4}]]
       set name [lindex $args [expr {$argc - 3}]]
       upvar 1 $name var
       if {[incr counter] % 2 == 1} {
           set var "$counter oops [concat $extraargs]"
       } else {
           set var "$counter + [concat $extraargs]"
       }
    }
    trace variable exprtracevar r [list exprtraceproc 10]
    list [catch {expr "$exprtracevar + 20"} a] $a \
        [catch {expr "$exprtracevar + 20"} b] $b \
        [unset exprtracevar exprtracecounter]
} {1 {syntax error in expression "1 oops 10 + 20"} 0 32 {}}
test expr-20.3 {broken substitution of integer digits} {
    # fails with 8.0.x, but not 8.1b2
    list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]
} {4096 1000}









# cleanup
unset a
::tcltest::cleanupTests
return

#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for-old.test,v 1.1.2.5 1999/03/24 02:49:09 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}



# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} {

#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for-old.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $

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

# Check "for" and its use of continue and break.

catch {unset a i}
test for-old-1.1 {for tests} {
    set a {}
    for {set i 1} {$i<6} {set i [expr $i+1]} {

# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.1.2.5 1999/03/24 02:49:10 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}



# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
} {1 {wrong # args: should be "for start test next command"}}
test for-1.2 {TclCompileForCmd: error in initial command} {
................................................................................
    set a
} {}
test for-5.15 {for cmd with computed command names: for command result} {
    set z for
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}





















# cleanup
::tcltest::cleanupTests
return

# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $

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

# Basic "for" operation.

test for-1.1 {TclCompileForCmd: missing initial command} {
    list [catch {for} msg] $msg
} {1 {wrong # args: should be "for start test next command"}}
test for-1.2 {TclCompileForCmd: error in initial command} {
................................................................................
    set a
} {}
test for-5.15 {for cmd with computed command names: for command result} {
    set z for
    set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
    set a
} {}

# Test for incorrect "double evaluation" semantics

test for-6.1 {possible delayed substitution of increment command} {knownBug} {
    # Increment should be 5, and lappend should always append 5
    catch {unset a}
    catch {unset i}
    set a 5
    set i {}
    for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
    set i
} {1 6 11}

test for-6.2 {possible delayed substitution of body command} {knownBug} {
    # Increment should be 5, and lappend should always append 5
    set a 5
    set i {}
    for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
    set i
} {5 5 5 5}

# cleanup
::tcltest::cleanupTests
return

#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: foreach.test,v 1.1.2.5 1999/03/24 02:49:11 hershey Exp $

if {[string compare test [info procs test]] == 1} then {source defs}



catch {unset a}
catch {unset x}

# Basic "foreach" operation.

test foreach-1.1 {basic foreach tests} {
................................................................................
    set a
} {a b}
test foreach-5.3 {break tests} {catch {break foo} msg} 1
test foreach-5.4 {break tests} {
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}














# cleanup
catch {unset a}
catch {unset x}
::tcltest::cleanupTests
return

#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: foreach.test,v 1.1.2.6 1999/04/02 23:44:38 stanton Exp $

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

catch {unset a}
catch {unset x}

# Basic "foreach" operation.

test foreach-1.1 {basic foreach tests} {
................................................................................
    set a
} {a b}
test foreach-5.3 {break tests} {catch {break foo} msg} 1
test foreach-5.4 {break tests} {
    catch {break foo} msg
    set msg
} {wrong # args: should be "break"}

# Test for incorrect "double evaluation" semantics

test foreach-6.1 {delayed substitution of body} {knownBug} {
    proc foo {} {
       set a 0
       foreach a [list 1 2 3] "
           set x $a
       "
       set x
    }
    foo
} {0}

# cleanup
catch {unset a}
catch {unset x}
::tcltest::cleanupTests
return

#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.1.2.6 1999/03/24 02:49:11 hershey Exp $

if {[info commands test] != "test"} {
    source defs
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail.  Someday I hope this code shouldn't be necessary (code added
# 9/9/91).

#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $

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

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail.  Someday I hope this code shouldn't be necessary (code added
# 9/9/91).

# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-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: httpold.test,v 1.1.2.6 1999/03/26 19:14:01 hershey Exp $

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

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
................................................................................
test http-4.11 {httpEvent} {
    set token [http_get $url -timeout 1 -command {#}]
    http_reset $token
    http_status $token
} {reset}
test http-4.12 {httpEvent} {
    update

    set token [http_get $url -timeout 1 -command {#}]
    update

    http_status $token
} {timeout}

test http-5.1 {http_formatQuery} {
    http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}

# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-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: httpold.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $

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

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
................................................................................
test http-4.11 {httpEvent} {
    set token [http_get $url -timeout 1 -command {#}]
    http_reset $token
    http_status $token
} {reset}
test http-4.12 {httpEvent} {
    update
    after 1000 {set x 1}
    set token [http_get $url -timeout 1 -command {#}]

    vwait x
    http_status $token
} {timeout}

test http-5.1 {http_formatQuery} {
    http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}

#
# Copyright (c) 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: if.test,v 1.1.2.6 1999/03/24 02:49:14 hershey Exp $

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

# Basic "if" operation.

................................................................................
# Check "if" and computed command names.

catch {unset a}
test if-5.1 {if cmd with computed command names: missing if/elseif test} {
    set z if
    list [catch {$z} msg] $msg
} {1 {wrong # args: no expression after "if" argument}}

test if-5.2 {if cmd with computed command names: error in if/elseif test} {
    set z if
    list [catch {$z {[error "error in condition"]} foo} msg] $msg
} {1 {error in condition}}
test if-5.3 {if cmd with computed command names: error in if/elseif test} {
    set z if
    list [catch {$z {1+}} msg] $msg $errorInfo
................................................................................
    $z 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
} def

test if-9.1 {if cmd with namespace qualifiers} {
    ::if {1} {set x 4}
} 4

































































# cleanup
::tcltest::cleanupTests
return

#
# Copyright (c) 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: if.test,v 1.1.2.7 1999/04/02 23:44:38 stanton Exp $

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

# Basic "if" operation.

................................................................................
# Check "if" and computed command names.

catch {unset a}
test if-5.1 {if cmd with computed command names: missing if/elseif test} {
    set z if
    list [catch {$z} msg] $msg
} {1 {wrong # args: no expression after "if" argument}}

test if-5.2 {if cmd with computed command names: error in if/elseif test} {
    set z if
    list [catch {$z {[error "error in condition"]} foo} msg] $msg
} {1 {error in condition}}
test if-5.3 {if cmd with computed command names: error in if/elseif test} {
    set z if
    list [catch {$z {1+}} msg] $msg $errorInfo
................................................................................
    $z 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi}
} def

test if-9.1 {if cmd with namespace qualifiers} {
    ::if {1} {set x 4}
} 4

# Test for incorrect "double evaluation semantics"

test if-10.1 {delayed substitution of then body} {knownBug} {
    set j 0
    if {[incr j] == 1} "
       set result $j
    "
    set result
} {0}
test if-10.2 {delayed substitution of elseif expression} {knownBug} {
    set j 0
    if {[incr j] == 0} {
       set result badthen
    } elseif "$j == 1" {
       set result badelseif
    } else {
       set result ok
    }
    set result
} {ok}
test if-10.3 {delayed substitution of elseif body} {knownBug} {
    set j 0
    if {[incr j] == 0} {
       set result badthen
    } elseif {1} "
       set result $j
    "
    set result
} {0}
test if-10.4 {delayed substitution of else body} {knownBug} {
    set j 0
    if {[incr j] == 0} {
       set result badthen
    } else "
       set result $j
    "
    set result
} {0}
test if-10.5 {substituted control words} {knownBug} {
    set then then; proc then {} {return badthen}
    set else else; proc else {} {return badelse}
    set elseif elseif; proc elseif {} {return badelseif}
    list [catch {if 1 $then {if 0 {} $elseif 1 {if 0 {} $else {list ok}}}} a] $a
} {0 ok}
test if-10.6 {double invocation of variable traces} {knownBug} {
    set iftracecounter 0
    proc iftraceproc {args} {
       upvar #0 iftracecounter counter
       set argc [llength $args]
       set extraargs [lrange $args 0 [expr {$argc - 4}]]
       set name [lindex $args [expr {$argc - 3}]]
       upvar 1 $name var
       if {[incr counter] % 2 == 1} {
           set var "$counter oops [concat $extraargs]"
       } else {
           set var "$counter + [concat $extraargs]"
       }
    }
    trace variable iftracevar r [list iftraceproc 10]
    list [catch {if "$iftracevar + 20" {}} a] $a \
        [catch {if "$iftracevar + 20" {}} b] $b \
        [unset iftracevar iftracecounter]
} {1 {syntax error in expression "1 oops 10 + 20"} 0 {} {}}

# cleanup
::tcltest::cleanupTests
return

#
# 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.
#
# RCS: @(#) $Id: init.test,v 1.1.2.5 1999/03/24 02:49:17 hershey Exp $

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

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
................................................................................

set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list source [file join $::tcltest::testsDir defs.tcl]]

interp eval $testInterp {

if {[string compare test [info procs test]] == 1} then {source defs}



auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    set ret [catch {namespace eval ::tcltest {parray}} error]
    rename parray {} ; # remove it, for the next test - that should not fail.

#
# 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.
#
# RCS: @(#) $Id: init.test,v 1.1.2.6 1999/04/02 23:44:39 stanton Exp $

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

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
................................................................................

set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list source [file join $::tcltest::testsDir defs.tcl]]

interp eval $testInterp {

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

auto_reset
catch {rename parray {}}

test init-2.0 {load parray - stage 1} {
    set ret [catch {namespace eval ::tcltest {parray}} error]
    rename parray {} ; # remove it, for the next test - that should not fail.

#
# 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.9 1999/03/26 02:24:46 stanton 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:

................................................................................
	myNewSet a $value
	return $a
    }
    catch {unset a}
    set result [testMyNewSet "ok"]
    rename testMyNewSet {}
    rename mySet {}

    set result
} ok

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::tcltest::cleanupTests
return

#
# 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.10 1999/04/02 23:44:39 stanton 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:

................................................................................
	myNewSet a $value
	return $a
    }
    catch {unset a}
    set result [testMyNewSet "ok"]
    rename testMyNewSet {}
    rename mySet {}
    rename myNewSet {}
    set result
} ok

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::tcltest::cleanupTests
return

#
# Copyright (c) 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: while.test,v 1.1.2.5 1999/03/24 02:49:51 hershey Exp $

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

# Basic "while" operation.

................................................................................

test while-1.1 {TclCompileWhileCmd: missing test expression} {
    catch {while } msg
    set msg
} {wrong # args: should be "while test command"}
test while-1.2 {TclCompileWhileCmd: error in test expression} {
    set i 0
    catch {while {$i<}} msg
    set errorInfo
} {wrong # args: should be "while test command"

    while compiling
"while {$i<}"}
test while-1.3 {TclCompileWhileCmd: error in test expression} {
    set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
    list $err $msg
} {1 {can't use non-numeric string as operand of "+"}}
test while-1.4 {TclCompileWhileCmd: multiline test expr} {
    set value 1
    while {($tcl_platform(platform) != "foobar1") && \
................................................................................
	    catch {incr i -5} msg
	}
	set a [concat $a $i]
        incr i
    }
    set a
} {1 3}











# cleanup
::tcltest::cleanupTests
return

#
# Copyright (c) 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: while.test,v 1.1.2.6 1999/04/02 23:44:39 stanton Exp $

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

# Basic "while" operation.

................................................................................

test while-1.1 {TclCompileWhileCmd: missing test expression} {
    catch {while } msg
    set msg
} {wrong # args: should be "while test command"}
test while-1.2 {TclCompileWhileCmd: error in test expression} {
    set i 0
    catch {while {$i<} break} msg
    set errorInfo
} {syntax error in expression "$i<"
    ("while" test expression)
    while compiling
"while {$i<} break"}
test while-1.3 {TclCompileWhileCmd: error in test expression} {
    set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
    list $err $msg
} {1 {can't use non-numeric string as operand of "+"}}
test while-1.4 {TclCompileWhileCmd: multiline test expr} {
    set value 1
    while {($tcl_platform(platform) != "foobar1") && \
................................................................................
	    catch {incr i -5} msg
	}
	set a [concat $a $i]
        incr i
    }
    set a
} {1 3}

# Test for incorrect "double evaluation" semantics

test while-7.1 {delayed substitution of body} {knownBug} {
    set i 0
    while {[incr i] < 10} "
       set result $i
    "
    set result
} {0}

# cleanup
::tcltest::cleanupTests
return