path: root/tests/cmdMZ.test

# The tests in this file cover the procedures in tclCmdMZ.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 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 {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
    return
}

namespace eval ::tcl::test::cmdMZ {
    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::customMatch
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::temporaryDirectory
    namespace import ::tcltest::test

    if {[namespace which -command ::tcl::unsupported::timerate] ne ""} {
	namespace import ::tcl::unsupported::timerate
    }

# Tcl_PwdObjCmd

test cmdMZ-1.1 {Tcl_PwdObjCmd} {
    list [catch {pwd a} msg] $msg
} {1 {wrong # args: should be "pwd"}}
test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
    catch pwd
} 0
test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} {
    expr [string length pwd]>0
} 1
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unix nonPortable} {
    # This test fails on various unix platforms (eg Linux) where
    # permissions caching causes this to fail.  The caching is strictly
    # incorrect, but we have no control over that.
    set foodir [file join [temporaryDirectory] foo]
    file delete -force $foodir
    file mkdir $foodir
    set cwd [pwd]
    cd $foodir
    file attr . -permissions 000
    set result [list [catch {pwd} msg] $msg]
    cd $cwd
    file delete -force $foodir
    set result
} {1 {error getting working directory name: permission denied}}

# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test

# Tcl_RenameObjCmd

test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} {
    list [catch {rename r1} msg] $msg $::errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} {
    list [catch {rename r1 r2 r3} msg] $msg $::errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test cmdMZ-2.3 {Tcl_RenameObjCmd: success} {
    catch {rename r2 {}}
    proc r1 {} {return "r1"}
    rename r1 r2
    r2
} {r1}
test cmdMZ-2.4 {Tcl_RenameObjCmd: success} {
    proc r1 {} {return "r1"}
    rename r1 {}
    list [catch {r1} msg] $msg
} {1 {invalid command name "r1"}}

# Some tests for Tcl_ReturnObjCmd are in proc-old.test

test cmdMZ-return-1.0 {return checks for bad option values} -body {
    return -options foo
} -returnCodes error -match glob -result {bad -options value:*}
test cmdMZ-return-1.1 {return checks for bad option values} -body {
    return -code foo
} -returnCodes error -match glob -result {bad completion code*}
test cmdMZ-return-1.2 {return checks for bad option values} -body {
    return -code 0x100000000
} -returnCodes error -match glob -result {bad completion code*}
test cmdMZ-return-1.3 {return checks for bad option values} -body {
    return -level foo
} -returnCodes error -match glob -result {bad -level value:*}
test cmdMZ-return-1.4 {return checks for bad option values} -body {
    return -level -1
} -returnCodes error -match glob -result {bad -level value:*}
test cmdMZ-return-1.5 {return checks for bad option values} -body {
    return -level 3.1415926
} -returnCodes error -match glob -result {bad -level value:*}

proc dictSort {d} {
    foreach k [lsort [dict keys $d]] {
	lappend result $k [dict get $d $k]
    }
    return $result
}

test cmdMZ-return-2.0 {return option handling} {
    list [catch return -> foo] [dictSort $foo]
} {2 {-code 0 -level 1}}
test cmdMZ-return-2.1 {return option handling} {
    list [catch {return -bar soom} -> foo] [dictSort $foo]
} {2 {-bar soom -code 0 -level 1}}
test cmdMZ-return-2.2 {return option handling} {
    list [catch {return -code return} -> foo] [dictSort $foo]
} {2 {-code 0 -level 2}}
test cmdMZ-return-2.3 {return option handling} {
    list [catch {return -code return -level 10} -> foo] [dictSort $foo]
} {2 {-code 0 -level 11}}
test cmdMZ-return-2.4 {return option handling} -body {
    return -level 0 -code error
} -returnCodes error -result {}
test cmdMZ-return-2.5 {return option handling} -body {
    return -level 0 -code return
} -returnCodes return -result {}
test cmdMZ-return-2.6 {return option handling} -body {
    return -level 0 -code break
} -returnCodes break -result {}
test cmdMZ-return-2.7 {return option handling} -body {
    return -level 0 -code continue
} -returnCodes continue -result {}
test cmdMZ-return-2.8 {return option handling} -body {
    return -level 0 -code -1
} -returnCodes -1 -result {}
test cmdMZ-return-2.9 {return option handling} -body {
    return -level 0 -code 10
} -returnCodes 10 -result {}
test cmdMZ-return-2.10 {return option handling} {
    list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
} {1 {-code 1 -errorcode NONE -errorinfo {
    while executing
"return -level 0 -code error"} -errorline 1 -level 0}}
test cmdMZ-return-2.11 {return option handling} {
    list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
} {3 {-code 3 -level 0}}
test cmdMZ-return-2.12 {return option handling} -body {
    return -level 0 -code error -options {-code ok}
} -returnCodes ok -result {}
test cmdMZ-return-2.13 {return option handling} -body {
    return -level 0 -code error -options {-code foo}
} -returnCodes error -match glob -result {bad completion code*}
test cmdMZ-return-2.14 {return option handling} -body {
    return -level 0 -code error -options {-code foo -options {-code break}}
} -returnCodes break -result {}

test cmdMZ-return-2.15 {return opton handling} -setup {
        proc p {} {
            return -code error -errorcode {a b} c
        }
    } -body {
        list [catch p result] $result $::errorCode
    } -cleanup {
        rename p {}
    } -result {1 c {a b}}
   
test cmdMZ-return-2.16 {return opton handling} -setup {
        proc p {} {
            return -code error -errorcode [list a b] c
        }
    } -body {
        list [catch p result] $result $::errorCode
    } -cleanup {
        rename p {}
    } -result {1 c {a b}}
   
test cmdMZ-return-2.17 {return opton handling} -setup {
        proc p {} {
            return -code error -errorcode a\ b c
        }
    } -body {
        list [catch p result] $result $::errorCode
    } -cleanup {
        rename p {}
    } -result {1 c {a b}}
   

# Check that the result of a [return -options $opts $result] is
# indistinguishable from that of the originally caught script, no
# matter what the script is/does.  (TIP 90)
set i 0
foreach script {
	{}
	{format x}
	{set}
	{set a 1}
	{error}
	{error foo}
	{error foo bar}
	{error foo bar baz}
	{return -level 0}
	{return -code error}
	{return -code error -errorinfo foo}
	{return -code error -errorinfo foo -errorcode bar}
	{return -code error -errorinfo foo -errorcode bar -errorline 10}
	{return -options {x y z 2}}
	{return -level 3 -code break sdf}
} {
    test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" {
	set one [list [catch $script foo bar] $foo [dictSort $bar] \
		$::errorCode $::errorInfo]
	set two [list [catch {return -options $bar $foo} foo2 bar2] \
		$foo2 [dictSort $bar2] $::errorCode $::errorInfo]
	string equal $one $two
    } 1
    incr i
}

# The tests for Tcl_ScanObjCmd are in scan.test

# Tcl_SourceObjCmd
# More tests of Tcl_SourceObjCmd are in source.test

test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
    unixOrPc
} -body {
    list [catch {source} msg] $msg
} -match glob -result {1 {wrong # args: should be "source*fileName"}}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
    unixOrPc
} -body {
    list [catch {source a b} msg] $msg
} -match glob -result {1 {wrong # args: should be "source*fileName"}}

proc ListGlobMatch {expected actual} {
    if {[llength $expected] != [llength $actual]} {
        return 0
    }
    foreach e $expected a $actual {
        if {![string match $e $a]} {
            return 0
        }
    }
    return 1
}
customMatch listGlob [namespace which ListGlobMatch]

test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
    set file [makeFile {
	set x 146
	error "error in sourced file"
	set y $x
    } source.file]
    set result [list [catch {source $file} msg] $msg $::errorInfo]
    removeFile source.file
    set result
} -match listGlob -result {1 {error in sourced file} {error in sourced file
    while executing
"error "error in sourced file""
    (file "*" line 3)
    invoked from within
"source $file"}}
test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} {
    set file [makeFile {list result} source.file]
    set result [source $file]
    removeFile source.file
    set result
} result

# Tcl_SplitObjCmd

test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
    list [catch split msg] $msg $::errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} {
    list [catch {split a b c} msg] $msg $::errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} {
    split "a\n b\t\r c\n "
} {a {} b {} {} c {} {}}
test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} {
    split "word 1xyzword 2zword 3" xyz
} {{word 1} {} {} {word 2} {word 3}}
test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} {
    split "12345" {}
} {1 2 3 4 5}
test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} {
    split "a\}b\[c\{\]\$"
} "a\\\}b\\\[c\\\{\\\]\\\$"
test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} {
    split {} {}
} {}
test cmdMZ-4.8 {Tcl_SplitObjCmd: basic split commands} {
    split {}
} {}
test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} {
    split {   }
} {{} {} {} {}}
test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} {
    proc foo {} {
        set x {}
        foreach f [split {]\n} {}] {
            append x $f
        }
        return $x	
    }
    foo
} {]\n}
test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} {
    proc foo {} {
        set x ab\000c
        set y [split $x {}]
        return $y
    }
    foo
} "a b \000 c"
test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} {
    split "a0ab1b2bbb3\000c4" ab\000c
} {{} 0 {} 1 2 {} {} 3 {} 4}
test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
    # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
    split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"

# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test

# todo: rewrite this if monotonic clock is provided resp. command "after" 
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
    set usec [expr {$msec * 1000}]
    set stime [clock microseconds]
    while {abs([clock microseconds] - $stime) < $usec} {after 0}
}

test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} {
    list [catch {time} msg] $msg
} {1 {wrong # args: should be "time command ?count?"}}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} {
    list [catch {time a b c} msg] $msg
} {1 {wrong # args: should be "time command ?count?"}}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} {
    list [catch {time a b} msg] $msg
} {1 {expected integer but got "b"}}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
    time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} {
    regexp {^\d+ microseconds per iteration} [time {format 1}]
} 1
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
    expr {[lindex [time {_nrt_sleep 1}] 0] < [lindex [time {_nrt_sleep 20}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
    list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
"time {error foo}"}}
test cmdMZ-5.7.1 {Tcl_TimeObjCmd: return from time} {
    set x 0
    proc r1 {} {upvar x x; time {incr x; return "r1"; incr x} 10}
    list [r1] $x
} {r1 1}
test cmdMZ-5.8 {Tcl_TimeObjCmd: done optimization: nested call of self inside time (if compiled)} {
    set x [set y 0]
    set m1 {
	if {[incr x] <= 5} {
	    # nested call should return result, so covering that:
	    if {![string is integer -strict [eval $m1]]} {error unexpected}
	}
	# increase again (no "continue" from nested call):
	incr x
    }
    time {incr y; eval $m1} 5
    list $y $x
} {5 20}

test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} {
    list [catch {timerate} msg] $msg
} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}}
test cmdMZ-6.2.1 {Tcl_TimeRateObjCmd: basic format of command} {
    list [catch {timerate a b c d} msg] $msg
} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}}
test cmdMZ-6.2.2 {Tcl_TimeRateObjCmd: basic format of command} {
    list [catch {timerate a b c} msg] $msg
} {1 {expected integer but got "b"}}
test cmdMZ-6.2.3 {Tcl_TimeRateObjCmd: basic format of command} {
    list [catch {timerate a b} msg] $msg
} {1 {expected integer but got "b"}}
test cmdMZ-6.3 {Tcl_TimeRateObjCmd: basic format of command} {
    list [catch {timerate -overhead b {} a b} msg] $msg
} {1 {expected floating-point number but got "b"}}
test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative iteration counts} {
    list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg
} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
    regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
    regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} {
    set m1 [timerate {_nrt_sleep 0} 20]
    set m2 [timerate {_nrt_sleep 0.2} 20]
    list \
	[expr {[lindex $m1 0] < [lindex $m2 0]}] \
	[expr {[lindex $m1 0] < 100}] \
	[expr {[lindex $m2 0] > 100}] \
	[expr {[lindex $m1 2] > 1000}] \
	[expr {[lindex $m2 2] < 1000}] \
	[expr {[lindex $m1 4] > 50000}] \
	[expr {[lindex $m2 4] < 50000}] \
	[expr {[lindex $m1 6] > 10 && [lindex $m1 6] < 100}] \
	[expr {[lindex $m2 6] > 10 && [lindex $m2 6] < 100}]
} [lrepeat 9 1]
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
    list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
"timerate {error foo} 1"}}
test cmdMZ-6.7.1 {Tcl_TimeRateObjCmd: return from timerate} {
    set x 0
    proc r1 {} {upvar x x; timerate {incr x; return "r1"; incr x} 1000 10}
    list [r1] $x
} {r1 1}
test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} {
    set m1 [timerate {break}]
    list \
	[expr {[lindex $m1 0] < 1000}] \
	[expr {[lindex $m1 2] == 1}] \
	[expr {[lindex $m1 4] > 1000}] \
	[expr {[lindex $m1 6] < 10}]
} {1 1 1 1}
test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} {
    set m1 [timerate {continue; return -code error "unexpected"} 1000 10]
    list \
	[expr {[lindex $m1 0] < 1000}] \
	[expr {[lindex $m1 2] == 10}] \
	[expr {[lindex $m1 4] > 1000}] \
	[expr {[lindex $m1 6] < 100}]
} {1 1 1 1}
test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} {
    set m1 [timerate {} 1000 5];	# max-count wins
    set m2 [timerate {_nrt_sleep 20} 1 5];	# max-time wins
    list [lindex $m1 2] [lindex $m2 2]
} {5 1}
test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} {
    set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1]
    list \
	[expr {[lindex $m1 0] == 0.0}] \
	[expr {[lindex $m1 2] == 1}] \
	[expr {[lindex $m1 4] == 1000000}] \
	[expr {[lindex $m1 6] <= 0.001}]
} {1 1 1 1}
test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} {
    set m1 {set m2 ok}
    if 1 $m1
    timerate $m1 1000 10
    if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop
} ok
test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self inside timerate} {
    set x 0
    set m1 {
	if {[incr x] <= 5} {
	    # nested call should return result, so covering that:
	    if {![string is integer -strict [eval $m1]]} {error unexpected}
	}
	# increase again (no "continue" from nested call):
	incr x
    }
    list [lindex [timerate $m1 1000 5] 2] $x
} {5 20}

# The tests for Tcl_WhileObjCmd are in while.test

# cleanup
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return