Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/tests/cmdMZ.test @ 25

Last change on this file since 25 was 25, checked in by landauf, 16 years ago

added tcl to libs

File size: 11.8 KB
Line 
1# The tests in this file cover the procedures in tclCmdMZ.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) 1991-1993 The Regents of the University of California.
8# Copyright (c) 1994 Sun Microsystems, Inc.
9# Copyright (c) 1998-1999 by Scriptics Corporation.
10#
11# See the file "license.terms" for information on usage and redistribution
12# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13#
14# RCS: @(#) $Id: cmdMZ.test,v 1.25 2006/10/09 19:15:44 msofer Exp $
15
16if {[catch {package require tcltest 2.1}]} {
17    puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
18    return
19}
20
21namespace eval ::tcl::test::cmdMZ {
22    namespace import ::tcltest::cleanupTests
23    namespace import ::tcltest::customMatch
24    namespace import ::tcltest::makeFile
25    namespace import ::tcltest::removeFile
26    namespace import ::tcltest::temporaryDirectory
27    namespace import ::tcltest::test
28
29# Tcl_PwdObjCmd
30
31test cmdMZ-1.1 {Tcl_PwdObjCmd} {
32    list [catch {pwd a} msg] $msg
33} {1 {wrong # args: should be "pwd"}}
34test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
35    catch pwd
36} 0
37test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} {
38    expr [string length pwd]>0
39} 1
40test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unix nonPortable} {
41    # This test fails on various unix platforms (eg Linux) where
42    # permissions caching causes this to fail.  The caching is strictly
43    # incorrect, but we have no control over that.
44    set foodir [file join [temporaryDirectory] foo]
45    file delete -force $foodir
46    file mkdir $foodir
47    set cwd [pwd]
48    cd $foodir
49    file attr . -permissions 000
50    set result [list [catch {pwd} msg] $msg]
51    cd $cwd
52    file delete -force $foodir
53    set result
54} {1 {error getting working directory name: permission denied}}
55
56# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test
57
58# Tcl_RenameObjCmd
59
60test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} {
61    list [catch {rename r1} msg] $msg $::errorCode
62} {1 {wrong # args: should be "rename oldName newName"} NONE}
63test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} {
64    list [catch {rename r1 r2 r3} msg] $msg $::errorCode
65} {1 {wrong # args: should be "rename oldName newName"} NONE}
66test cmdMZ-2.3 {Tcl_RenameObjCmd: success} {
67    catch {rename r2 {}}
68    proc r1 {} {return "r1"}
69    rename r1 r2
70    r2
71} {r1}
72test cmdMZ-2.4 {Tcl_RenameObjCmd: success} {
73    proc r1 {} {return "r1"}
74    rename r1 {}
75    list [catch {r1} msg] $msg
76} {1 {invalid command name "r1"}}
77
78# Some tests for Tcl_ReturnObjCmd are in proc-old.test
79
80test cmdMZ-return-1.0 {return checks for bad option values} -body {
81    return -options foo
82} -returnCodes error -match glob -result {bad -options value:*}
83test cmdMZ-return-1.1 {return checks for bad option values} -body {
84    return -code foo
85} -returnCodes error -match glob -result {bad completion code*}
86test cmdMZ-return-1.2 {return checks for bad option values} -body {
87    return -code 0x100000000
88} -returnCodes error -match glob -result {bad completion code*}
89test cmdMZ-return-1.3 {return checks for bad option values} -body {
90    return -level foo
91} -returnCodes error -match glob -result {bad -level value:*}
92test cmdMZ-return-1.4 {return checks for bad option values} -body {
93    return -level -1
94} -returnCodes error -match glob -result {bad -level value:*}
95test cmdMZ-return-1.5 {return checks for bad option values} -body {
96    return -level 3.1415926
97} -returnCodes error -match glob -result {bad -level value:*}
98
99proc dictSort {d} {
100    foreach k [lsort [dict keys $d]] {
101        lappend result $k [dict get $d $k]
102    }
103    return $result
104}
105
106test cmdMZ-return-2.0 {return option handling} {
107    list [catch return -> foo] [dictSort $foo]
108} {2 {-code 0 -level 1}}
109test cmdMZ-return-2.1 {return option handling} {
110    list [catch {return -bar soom} -> foo] [dictSort $foo]
111} {2 {-bar soom -code 0 -level 1}}
112test cmdMZ-return-2.2 {return option handling} {
113    list [catch {return -code return} -> foo] [dictSort $foo]
114} {2 {-code 0 -level 2}}
115test cmdMZ-return-2.3 {return option handling} {
116    list [catch {return -code return -level 10} -> foo] [dictSort $foo]
117} {2 {-code 0 -level 11}}
118test cmdMZ-return-2.4 {return option handling} -body {
119    return -level 0 -code error
120} -returnCodes error -result {}
121test cmdMZ-return-2.5 {return option handling} -body {
122    return -level 0 -code return
123} -returnCodes return -result {}
124test cmdMZ-return-2.6 {return option handling} -body {
125    return -level 0 -code break
126} -returnCodes break -result {}
127test cmdMZ-return-2.7 {return option handling} -body {
128    return -level 0 -code continue
129} -returnCodes continue -result {}
130test cmdMZ-return-2.8 {return option handling} -body {
131    return -level 0 -code -1
132} -returnCodes -1 -result {}
133test cmdMZ-return-2.9 {return option handling} -body {
134    return -level 0 -code 10
135} -returnCodes 10 -result {}
136test cmdMZ-return-2.10 {return option handling} {
137    list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
138} {1 {-code 1 -errorcode NONE -errorinfo {
139    while executing
140"return -level 0 -code error"} -errorline 1 -level 0}}
141test cmdMZ-return-2.11 {return option handling} {
142    list [catch {return -level 0 -code break} -> foo] [dictSort $foo]
143} {3 {-code 3 -level 0}}
144test cmdMZ-return-2.12 {return option handling} -body {
145    return -level 0 -code error -options {-code ok}
146} -returnCodes ok -result {}
147test cmdMZ-return-2.13 {return option handling} -body {
148    return -level 0 -code error -options {-code foo}
149} -returnCodes error -match glob -result {bad completion code*}
150test cmdMZ-return-2.14 {return option handling} -body {
151    return -level 0 -code error -options {-code foo -options {-code break}}
152} -returnCodes break -result {}
153
154test cmdMZ-return-2.15 {return opton handling} -setup {
155        proc p {} {
156            return -code error -errorcode {a b} c
157        }
158    } -body {
159        list [catch p result] $result $::errorCode
160    } -cleanup {
161        rename p {}
162    } -result {1 c {a b}}
163   
164test cmdMZ-return-2.16 {return opton handling} -setup {
165        proc p {} {
166            return -code error -errorcode [list a b] c
167        }
168    } -body {
169        list [catch p result] $result $::errorCode
170    } -cleanup {
171        rename p {}
172    } -result {1 c {a b}}
173   
174test cmdMZ-return-2.17 {return opton handling} -setup {
175        proc p {} {
176            return -code error -errorcode a\ b c
177        }
178    } -body {
179        list [catch p result] $result $::errorCode
180    } -cleanup {
181        rename p {}
182    } -result {1 c {a b}}
183   
184
185# Check that the result of a [return -options $opts $result] is
186# indistinguishable from that of the originally caught script, no
187# matter what the script is/does.  (TIP 90)
188set i 0
189foreach script {
190        {}
191        {format x}
192        {set}
193        {set a 1}
194        {error}
195        {error foo}
196        {error foo bar}
197        {error foo bar baz}
198        {return -level 0}
199        {return -code error}
200        {return -code error -errorinfo foo}
201        {return -code error -errorinfo foo -errorcode bar}
202        {return -code error -errorinfo foo -errorcode bar -errorline 10}
203        {return -options {x y z 2}}
204        {return -level 3 -code break sdf}
205} {
206    test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" {
207        set one [list [catch $script foo bar] $foo [dictSort $bar] \
208                $::errorCode $::errorInfo]
209        set two [list [catch {return -options $bar $foo} foo2 bar2] \
210                $foo2 [dictSort $bar2] $::errorCode $::errorInfo]
211        string equal $one $two
212    } 1
213    incr i
214}
215
216# The tests for Tcl_ScanObjCmd are in scan.test
217
218# Tcl_SourceObjCmd
219# More tests of Tcl_SourceObjCmd are in source.test
220
221test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
222    unixOrPc
223} -body {
224    list [catch {source} msg] $msg
225} -match glob -result {1 {wrong # args: should be "source*fileName"}}
226test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
227    unixOrPc
228} -body {
229    list [catch {source a b} msg] $msg
230} -match glob -result {1 {wrong # args: should be "source*fileName"}}
231
232proc ListGlobMatch {expected actual} {
233    if {[llength $expected] != [llength $actual]} {
234        return 0
235    }
236    foreach e $expected a $actual {
237        if {![string match $e $a]} {
238            return 0
239        }
240    }
241    return 1
242}
243customMatch listGlob [namespace which ListGlobMatch]
244
245test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
246    set file [makeFile {
247        set x 146
248        error "error in sourced file"
249        set y $x
250    } source.file]
251    set result [list [catch {source $file} msg] $msg $::errorInfo]
252    removeFile source.file
253    set result
254} -match listGlob -result {1 {error in sourced file} {error in sourced file
255    while executing
256"error "error in sourced file""
257    (file "*" line 3)
258    invoked from within
259"source $file"}}
260test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} {
261    set file [makeFile {list result} source.file]
262    set result [source $file]
263    removeFile source.file
264    set result
265} result
266
267# Tcl_SplitObjCmd
268
269test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
270    list [catch split msg] $msg $::errorCode
271} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
272test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} {
273    list [catch {split a b c} msg] $msg $::errorCode
274} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
275test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} {
276    split "a\n b\t\r c\n "
277} {a {} b {} {} c {} {}}
278test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} {
279    split "word 1xyzword 2zword 3" xyz
280} {{word 1} {} {} {word 2} {word 3}}
281test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} {
282    split "12345" {}
283} {1 2 3 4 5}
284test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} {
285    split "a\}b\[c\{\]\$"
286} "a\\\}b\\\[c\\\{\\\]\\\$"
287test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} {
288    split {} {}
289} {}
290test cmdMZ-4.8 {Tcl_SplitObjCmd: basic split commands} {
291    split {}
292} {}
293test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} {
294    split {   }
295} {{} {} {} {}}
296test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} {
297    proc foo {} {
298        set x {}
299        foreach f [split {]\n} {}] {
300            append x $f
301        }
302        return $x       
303    }
304    foo
305} {]\n}
306test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} {
307    proc foo {} {
308        set x ab\000c
309        set y [split $x {}]
310        return $y
311    }
312    foo
313} "a b \000 c"
314test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} {
315    split "a0ab1b2bbb3\000c4" ab\000c
316} {{} 0 {} 1 2 {} {} 3 {} 4}
317test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
318    # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
319    split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
320} "a b qw\u5e4eN wq"
321
322# The tests for Tcl_StringObjCmd are in string.test
323# The tests for Tcl_SubstObjCmd are in subst.test
324# The tests for Tcl_SwitchObjCmd are in switch.test
325
326test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} {
327    list [catch {time} msg] $msg
328} {1 {wrong # args: should be "time command ?count?"}}
329test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} {
330    list [catch {time a b c} msg] $msg
331} {1 {wrong # args: should be "time command ?count?"}}
332test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} {
333    list [catch {time a b} msg] $msg
334} {1 {expected integer but got "b"}}
335test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
336    time bogusCmd -12456
337} {0 microseconds per iteration}
338test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} {
339    regexp {^\d+ microseconds per iteration} [time {format 1}]
340} 1
341test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
342    expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]}
343} 1
344test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
345    list [catch {time {error foo}} msg] $msg $::errorInfo
346} {1 foo {foo
347    while executing
348"error foo"
349    invoked from within
350"time {error foo}"}}
351
352# The tests for Tcl_WhileObjCmd are in while.test
353
354# cleanup
355cleanupTests
356}
357namespace delete ::tcl::test::cmdMZ
358return
Note: See TracBrowser for help on using the repository browser.