# The file tests the tclCmdAH.c file. # # 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) 1996-1998 by 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: cmdAH.test,v 1.30.2.1 2003/03/18 10:51:31 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]] global env set cmdAHwd [pwd] catch {set platform [testgetplatform]} test cmdAH-0.1 {Tcl_BreakObjCmd, errors} { list [catch {break foo} msg] $msg } {1 {wrong # args: should be "break"}} test cmdAH-0.2 {Tcl_BreakObjCmd, success} { list [catch {break} msg] $msg } {3 {}} # Tcl_CaseObjCmd is tested in case.test test cmdAH-1.1 {Tcl_CatchObjCmd, errors} { list [catch {catch} msg] $msg } {1 {wrong # args: should be "catch command ?varName?"}} test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { list [catch {catch foo bar baz} msg] $msg } {1 {wrong # args: should be "catch command ?varName?"}} test cmdAH-2.1 {Tcl_CdObjCmd} { list [catch {cd foo bar} msg] $msg } {1 {wrong # args: should be "cd ?dirName?"}} set foodir [file join [temporaryDirectory] foo] test cmdAH-2.2 {Tcl_CdObjCmd} { file delete -force $foodir file mkdir $foodir cd $foodir set result [file tail [pwd]] cd .. file delete $foodir set result } foo test cmdAH-2.3 {Tcl_CdObjCmd} { global env set oldpwd [pwd] set temp $env(HOME) set env(HOME) $oldpwd file delete -force $foodir file mkdir $foodir cd $foodir cd ~ set result [string equal [pwd] $oldpwd] file delete $foodir set env(HOME) $temp set result } 1 test cmdAH-2.4 {Tcl_CdObjCmd} { global env set oldpwd [pwd] set temp $env(HOME) set env(HOME) $oldpwd file delete -force $foodir file mkdir $foodir cd $foodir cd set result [string equal [pwd] $oldpwd] file delete $foodir set env(HOME) $temp set result } 1 test cmdAH-2.5 {Tcl_CdObjCmd} { list [catch {cd ~~} msg] $msg } {1 {user "~" doesn't exist}} test cmdAH-2.6 {Tcl_CdObjCmd} { list [catch {cd _foobar} msg] $msg } {1 {couldn't change working directory to "_foobar": no such file or directory}} test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat } {} test cmdAH-2.8 {Tcl_ConcatObjCmd} { concat a } a test cmdAH-2.9 {Tcl_ConcatObjCmd} { concat a {b c} } {a b c} test cmdAH-3.1 {Tcl_ContinueObjCmd, errors} { list [catch {continue foo} msg] $msg } {1 {wrong # args: should be "continue"}} test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { list [catch {continue} msg] $msg } {4 {}} test cmdAH-4.1 {Tcl_EncodingObjCmd} { list [catch {encoding} msg] $msg } {1 {wrong # args: should be "encoding option ?arg ...?"}} test cmdAH-4.2 {Tcl_EncodingObjCmd} { list [catch {encoding foo} msg] $msg } {1 {bad option "foo": must be convertfrom, convertto, names, or system}} test cmdAH-4.3 {Tcl_EncodingObjCmd} { list [catch {encoding convertto} msg] $msg } {1 {wrong # args: should be "encoding convertto ?encoding? data"}} test cmdAH-4.4 {Tcl_EncodingObjCmd} { list [catch {encoding convertto foo bar} msg] $msg } {1 {unknown encoding "foo"}} test cmdAH-4.5 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system jis0208 set x [encoding convertto \u4e4e] encoding system $system set x } 8C test cmdAH-4.6 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system identity set x [encoding convertto jis0208 \u4e4e] encoding system $system set x } 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} { list [catch {encoding convertfrom} msg] $msg } {1 {wrong # args: should be "encoding convertfrom ?encoding? data"}} test cmdAH-4.8 {Tcl_EncodingObjCmd} { list [catch {encoding convertfrom foo bar} msg] $msg } {1 {unknown encoding "foo"}} test cmdAH-4.9 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system jis0208 set x [encoding convertfrom 8C] encoding system $system set x } \u4e4e test cmdAH-4.10 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system identity set x [encoding convertfrom jis0208 8C] encoding system $system set x } \u4e4e test cmdAH-4.11 {Tcl_EncodingObjCmd} { list [catch {encoding names foo} msg] $msg } {1 {wrong # args: should be "encoding names"}} test cmdAH-4.12 {Tcl_EncodingObjCmd} { list [catch {encoding system foo bar} msg] $msg } {1 {wrong # args: should be "encoding system ?encoding?"}} test cmdAH-4.13 {Tcl_EncodingObjCmd} { set system [encoding system] encoding system identity set x [encoding system] encoding system $system set x } identity test cmdAH-5.1 {Tcl_FileObjCmd} { list [catch file msg] $msg } {1 {wrong # args: should be "file option ?arg ...?"}} test cmdAH-5.2 {Tcl_FileObjCmd} { list [catch {file x} msg] $msg } {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-5.3 {Tcl_FileObjCmd} { list [catch {file exists} msg] $msg } {1 {wrong # args: should be "file exists name"}} test cmdAH-5.4 {Tcl_FileObjCmd} { list [catch {file exists ""} msg] $msg } {0 0} #volume test cmdAH-6.1 {Tcl_FileObjCmd: volumes} { list [catch {file volumes x} msg] $msg } {1 {wrong # args: should be "file volumes"}} test cmdAH-6.2 {Tcl_FileObjCmd: volumes} { set volumeList [file volumes] if { [llength $volumeList] == 0 } { set result 0 } else { set result 1 } } {1} test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {macOrUnix} { set volumeList [file volumes] catch [list glob -nocomplain [lindex $volumeList 0]*] } {0} test cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} { set volumeList [string tolower [file volumes]] list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] } {0 1 0} test cmdAH-6.5 {cd} {unixOnly nonPortable} { set dir [pwd] cd / set res [pwd] cd $dir set res } {/} # attributes test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} { set foofile [makeFile abcde foo.file] catch {file delete -force $foofile} close [open $foofile w] set res [catch {file attributes $foofile}] # We used [makeFile] so we undo with [removeFile] removeFile $foofile set res } {0} # dirname if {[info commands testsetplatform] == {}} { puts "This application hasn't been compiled with the \"testsetplatform\"" puts "command, so I can't test Tcl_FileObjCmd etc." } else { test cmdAH-8.1 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a b} msg] $msg } {1 {wrong # args: should be "file dirname name"}} test cmdAH-8.2 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /a/b } /a test cmdAH-8.3 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname {} } . test cmdAH-8.4 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname {} } : test cmdAH-8.5 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname {} } . test cmdAH-8.6 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname .def } . test cmdAH-8.7 {Tcl_FileObjCmd: dirname} { testsetplatform mac file dirname a } : test cmdAH-8.8 {Tcl_FileObjCmd: dirname} { testsetplatform win file dirname a } . test cmdAH-8.9 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b/c.d } a/b test cmdAH-8.10 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname a/b.c/d } a/b.c test cmdAH-8.11 {Tcl_FileObjCmd: dirname} { testsetplatform unix file dirname /. } / test cmdAH-8.12 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /} msg] $msg } {0 /} test cmdAH-8.13 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo} msg] $msg } {0 /} test cmdAH-8.14 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo} msg] $msg } {0 /} test cmdAH-8.15 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname //foo/bar} msg] $msg } {0 /foo} test cmdAH-8.16 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz}} msg] $msg } {0 {/foo\/bar}} test cmdAH-8.17 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg } {0 {/foo\/bar/baz}} test cmdAH-8.18 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname /foo//} msg] $msg } {0 /} test cmdAH-8.19 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ./a} msg] $msg } {0 .} test cmdAH-8.20 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname a/.a} msg] $msg } {0 a} test cmdAH-8.21 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:foo} msg] $msg } {0 c:} test cmdAH-8.22 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:} msg] $msg } {0 c:} test cmdAH-8.23 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname c:/} msg] $msg } {0 c:/} test cmdAH-8.24 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {c:\foo}} msg] $msg } {0 c:/} test cmdAH-8.25 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar/baz}} msg] $msg } {0 //foo/bar} test cmdAH-8.26 {Tcl_FileObjCmd: dirname} { testsetplatform windows list [catch {file dirname {//foo/bar}} msg] $msg } {0 //foo/bar} test cmdAH-8.27 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :} msg] $msg } {0 :} test cmdAH-8.28 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo} msg] $msg } {0 :} test cmdAH-8.29 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:} msg] $msg } {0 Foo:} test cmdAH-8.30 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname Foo:bar} msg] $msg } {0 Foo:} test cmdAH-8.31 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :Foo:bar} msg] $msg } {0 :Foo} test cmdAH-8.32 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ::} msg] $msg } {0 :} test cmdAH-8.33 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname :::} msg] $msg } {0 ::} test cmdAH-8.34 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar/} msg] $msg } {0 foo:} test cmdAH-8.35 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo/bar} msg] $msg } {0 foo:} test cmdAH-8.36 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname /foo} msg] $msg } {0 foo:} test cmdAH-8.37 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname foo} msg] $msg } {0 :} test cmdAH-8.38 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~/foo} msg] $msg } {0 ~} test cmdAH-8.39 {Tcl_FileObjCmd: dirname} { testsetplatform unix list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar} test cmdAH-8.40 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~bar/foo} msg] $msg } {0 ~bar:} test cmdAH-8.41 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~/foo} msg] $msg } {0 ~:} test cmdAH-8.42 {Tcl_FileObjCmd: dirname} { testsetplatform mac list [catch {file dirname ~:baz} msg] $msg } {0 ~:} test cmdAH-8.43 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform unix set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result } [list 0 [expr {([file exists /home] && ([file type /home] == "link")) ? [file readlink /home] : "/home"}]] test cmdAH-8.44 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "~" testsetplatform unix set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result } {0 ~} test cmdAH-8.45 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform windows set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result } [list 0 [expr {([file exists /home] && ([file type /home] == "link")) ? [file readlink /home] : "/home"}]] test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform mac set result [list [catch {file dirname ~} msg] $msg] set env(HOME) $temp set result } {0 home:} # tail test cmdAH-9.1 {Tcl_FileObjCmd: tail} { testsetplatform unix list [catch {file tail a b} msg] $msg } {1 {wrong # args: should be "file tail name"}} test cmdAH-9.2 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /a/b } b test cmdAH-9.3 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {} } {} test cmdAH-9.4 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail {} } {} test cmdAH-9.5 {Tcl_FileObjCmd: tail} { testsetplatform win file tail {} } {} test cmdAH-9.6 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail .def } .def test cmdAH-9.7 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail a } a test cmdAH-9.8 {Tcl_FileObjCmd: tail} { testsetplatform win file tail a } a test cmdAH-9.9 {Tcl_FileObjCmd: tail} { testsetplatform unix file ta a/b/c.d } c.d test cmdAH-9.10 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/b.c/d } d test cmdAH-9.11 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /. } . test cmdAH-9.12 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail / } {} test cmdAH-9.13 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo } foo test cmdAH-9.14 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo } foo test cmdAH-9.15 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail //foo/bar } bar test cmdAH-9.16 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz} } baz test cmdAH-9.17 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {//foo\/bar/baz/blat} } blat test cmdAH-9.18 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail /foo// } foo test cmdAH-9.19 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail ./a } a test cmdAH-9.20 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail a/.a } .a test cmdAH-9.21 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo test cmdAH-9.22 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} test cmdAH-9.23 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/ } {} test cmdAH-9.24 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:\foo} } foo test cmdAH-9.25 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar/baz} } baz test cmdAH-9.26 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {//foo/bar} } {} test cmdAH-9.27 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail : } : test cmdAH-9.28 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo } Foo test cmdAH-9.29 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo: } {} test cmdAH-9.30 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail Foo:bar } bar test cmdAH-9.31 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :Foo:bar } bar test cmdAH-9.32 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail :: } :: test cmdAH-9.33 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ::: } :: test cmdAH-9.34 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar/ } bar test cmdAH-9.35 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo/bar } bar test cmdAH-9.36 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail /foo } {} test cmdAH-9.37 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail foo } foo test cmdAH-9.38 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~:foo } foo test cmdAH-9.39 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar:foo } foo test cmdAH-9.40 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~bar/foo } foo test cmdAH-9.41 {Tcl_FileObjCmd: tail} { testsetplatform mac file tail ~/foo } foo test cmdAH-9.42 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform unix set result [file tail ~] set env(HOME) $temp set result } test test cmdAH-9.43 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "~" testsetplatform unix set result [file tail ~] set env(HOME) $temp set result } {} test cmdAH-9.44 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform windows set result [file tail ~] set env(HOME) $temp set result } test test cmdAH-9.45 {Tcl_FileObjCmd: tail} { global env set temp $env(HOME) set env(HOME) "/home/test" testsetplatform mac set result [file tail ~] set env(HOME) $temp set result } test test cmdAH-9.46 {Tcl_FileObjCmd: tail} { testsetplatform unix file tail {f.oo\bar/baz.bat} } baz.bat test cmdAH-9.47 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:foo } foo test cmdAH-9.48 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c: } {} test cmdAH-9.49 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail c:/foo } foo test cmdAH-9.50 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {c:/foo\bar} } bar test cmdAH-9.51 {Tcl_FileObjCmd: tail} { testsetplatform windows file tail {foo\bar} } bar # rootname test cmdAH-10.1 {Tcl_FileObjCmd: rootname} { testsetplatform unix list [catch {file rootname a b} msg] $msg } {1 {wrong # args: should be "file rootname name"}} test cmdAH-10.2 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname {} } {} test cmdAH-10.3 {Tcl_FileObjCmd: rootname} { testsetplatform unix file ro foo } foo test cmdAH-10.4 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname foo. } foo test cmdAH-10.5 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname .foo } {} test cmdAH-10.6 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def } abc test cmdAH-10.7 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname abc.def.ghi } abc.def test cmdAH-10.8 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b/c.d } a/b/c test cmdAH-10.9 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/d } a/b.c/d test cmdAH-10.10 {Tcl_FileObjCmd: rootname} { testsetplatform unix file rootname a/b.c/ } a/b.c/ test cmdAH-10.11 {Tcl_FileObjCmd: rootname} { testsetplatform mac file ro foo } foo test cmdAH-10.12 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname {} } {} test cmdAH-10.13 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo. } foo test cmdAH-10.14 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname .foo } {} test cmdAH-10.15 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def } abc test cmdAH-10.16 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname abc.def.ghi } abc.def test cmdAH-10.17 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b:c.d } a:b:c test cmdAH-10.18 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a:b.c:d } a:b.c:d test cmdAH-10.19 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b/c.d } a/b/c test cmdAH-10.20 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname a/b.c/d } a/b.c/d test cmdAH-10.21 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname /a.b } /a test cmdAH-10.22 {Tcl_FileObjCmd: rootname} { testsetplatform mac file rootname foo.c: } foo.c: test cmdAH-10.23 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname {} } {} test cmdAH-10.24 {Tcl_FileObjCmd: rootname} { testsetplatform windows file ro foo } foo test cmdAH-10.25 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname foo. } foo test cmdAH-10.26 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname .foo } {} test cmdAH-10.27 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def } abc test cmdAH-10.28 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname abc.def.ghi } abc.def test cmdAH-10.29 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b/c.d } a/b/c test cmdAH-10.30 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a/b.c/d } a/b.c/d test cmdAH-10.31 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ test cmdAH-10.32 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b\\c.d } a\\b\\c test cmdAH-10.33 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\d } a\\b.c\\d test cmdAH-10.34 {Tcl_FileObjCmd: rootname} { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ set num 35 foreach outer { {} a .a a. a.a } { foreach inner { {} a .a a. a.a } { set thing [format %s/%s $outer $inner] ; test cmdAH-6.$num {Tcl_FileObjCmd: rootname and extension options} { testsetplatform unix format %s%s [file rootname $thing] [file ext $thing] } $thing set num [expr $num+1] } } # extension test cmdAH-11.1 {Tcl_FileObjCmd: extension} { testsetplatform unix list [catch {file extension a b} msg] $msg } {1 {wrong # args: should be "file extension name"}} test cmdAH-11.2 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension {} } {} test cmdAH-11.3 {Tcl_FileObjCmd: extension} { testsetplatform unix file ext foo } {} test cmdAH-11.4 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension foo. } . test cmdAH-11.5 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension .foo } .foo test cmdAH-11.6 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def } .def test cmdAH-11.7 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension abc.def.ghi } .ghi test cmdAH-11.8 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b/c.d } .d test cmdAH-11.9 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/d } {} test cmdAH-11.10 {Tcl_FileObjCmd: extension} { testsetplatform unix file extension a/b.c/ } {} test cmdAH-11.11 {Tcl_FileObjCmd: extension} { testsetplatform mac file ext foo } {} test cmdAH-11.12 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension {} } {} test cmdAH-11.13 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo. } . test cmdAH-11.14 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension .foo } .foo test cmdAH-11.15 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def } .def test cmdAH-11.16 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension abc.def.ghi } .ghi test cmdAH-11.17 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b:c.d } .d test cmdAH-11.18 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a:b.c:d } {} test cmdAH-11.19 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b/c.d } .d test cmdAH-11.20 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension a/b.c/d } {} test cmdAH-11.21 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension /a.b } .b test cmdAH-11.22 {Tcl_FileObjCmd: extension} { testsetplatform mac file extension foo.c: } {} test cmdAH-11.23 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension {} } {} test cmdAH-11.24 {Tcl_FileObjCmd: extension} { testsetplatform windows file ext foo } {} test cmdAH-11.25 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension foo. } . test cmdAH-11.26 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension .foo } .foo test cmdAH-11.27 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def } .def test cmdAH-11.28 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension abc.def.ghi } .ghi test cmdAH-11.29 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b/c.d } .d test cmdAH-11.30 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a/b.c/d } {} test cmdAH-11.31 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} test cmdAH-11.32 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b\\c.d } .d test cmdAH-11.33 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\d } {} test cmdAH-11.34 {Tcl_FileObjCmd: extension} { testsetplatform windows file extension a\\b.c\\ } {} set num 35 foreach value {a..b a...b a.c..b ..b} result {.b .b .b .b} { foreach p {unix mac windows} { ; test cmdAH-7.$num {Tcl_FileObjCmd: extension} " testsetplatform $p file extension $value " $result incr num } } # pathtype test cmdAH-12.1 {Tcl_FileObjCmd: pathtype} { testsetplatform unix list [catch {file pathtype a b} msg] $msg } {1 {wrong # args: should be "file pathtype name"}} test cmdAH-12.2 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file pathtype /a } absolute test cmdAH-12.3 {Tcl_FileObjCmd: pathtype} { testsetplatform unix file p a } relative test cmdAH-12.4 {Tcl_FileObjCmd: pathtype} { testsetplatform windows file pathtype c:a } volumerelative # split test cmdAH-13.1 {Tcl_FileObjCmd: split} { testsetplatform unix list [catch {file split a b} msg] $msg } {1 {wrong # args: should be "file split name"}} test cmdAH-13.2 {Tcl_FileObjCmd: split} { testsetplatform unix file split a } a test cmdAH-13.3 {Tcl_FileObjCmd: split} { testsetplatform unix file split a/b } {a b} # join test cmdAH-14.1 {Tcl_FileObjCmd: join} { testsetplatform unix file join a } a test cmdAH-14.2 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b } a/b test cmdAH-14.3 {Tcl_FileObjCmd: join} { testsetplatform unix file join a b c d } a/b/c/d # error handling of Tcl_TranslateFileName test cmdAH-15.1 {Tcl_FileObjCmd} { testsetplatform unix list [catch {file atime ~_bad_user} msg] $msg } {1 {user "_bad_user" doesn't exist}} testsetplatform $platform } # readable set gorpfile [makeFile abcde gorp.file] set dirfile [makeDirectory dir.file] if {[info commands testchmod] == {}} { puts "This application hasn't been compiled with the \"testchmod\"" puts "command, so I can't test Tcl_FileObjCmd etc." } else { test cmdAH-16.1 {Tcl_FileObjCmd: readable} {testchmod} { list [catch {file readable a b} msg] $msg } {1 {wrong # args: should be "file readable name"}} testchmod 0444 $gorpfile test cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} { file readable $gorpfile } 1 testchmod 0333 $gorpfile test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} { file reada $gorpfile } 0 # writable test cmdAH-17.1 {Tcl_FileObjCmd: writable} {testchmod} { list [catch {file writable a b} msg] $msg } {1 {wrong # args: should be "file writable name"}} testchmod 0555 $gorpfile test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} { file writable $gorpfile } 0 testchmod 0222 $gorpfile test cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} { file writable $gorpfile } 1 } # executable removeFile $gorpfile removeDirectory $dirfile set dirfile [makeDirectory dir.file] set gorpfile [makeFile abcde gorp.file] test cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} { list [catch {file executable a b} msg] $msg } {1 {wrong # args: should be "file executable name"}} test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} { file executable $gorpfile } 0 test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} { # Only on unix will setting the execute bit on a regular file # cause that file to be executable. testchmod 0775 $gorpfile file exe $gorpfile } 1 test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} { # On mac, the only executable files are of type APPL. set x [file exe $gorpfile] file attrib $gorpfile -type APPL lappend x [file exe $gorpfile] } {0 1} test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} { # On pc, must be a .exe, .com, etc. set x [file exe $gorpfile] set gorpexe [makeFile foo gorp.exe] lappend x [file exe $gorpexe] removeFile $gorpexe set x } {0 1} test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} { # Directories are always executable. file exe $dirfile } 1 removeDirectory $dirfile removeFile $gorpfile set linkfile [file join [temporaryDirectory] link.file] file delete $linkfile # exists test cmdAH-19.1 {Tcl_FileObjCmd: exists} { list [catch {file exists a b} msg] $msg } {1 {wrong # args: should be "file exists name"}} test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists $gorpfile} 0 test cmdAH-19.3 {Tcl_FileObjCmd: exists} { file exists [file join [temporaryDirectory] dir.file gorp.file] } 0 catch { set gorpfile [makeFile abcde gorp.file] set dirfile [makeDirectory dir.file] set subgorp [makeFile 12345 [file join $dirfile gorp.file]] } test cmdAH-19.4 {Tcl_FileObjCmd: exists} { file exists $gorpfile } 1 test cmdAH-19.5 {Tcl_FileObjCmd: exists} { file exists $subgorp } 1 # nativename if {[info commands testsetplatform] == {}} { puts "This application hasn't been compiled with the \"testsetplatform\"" puts "command, so I can't test Tcl_FileObjCmd etc." } else { test cmdAH-19.6 {Tcl_FileObjCmd: nativename} { testsetplatform unix list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 a/b {}} test cmdAH-19.7 {Tcl_FileObjCmd: nativename} { testsetplatform windows list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 {a\b} {}} test cmdAH-19.8 {Tcl_FileObjCmd: nativename} { testsetplatform mac list [catch {file nativename a/b} msg] $msg [testsetplatform $platform] } {0 :a:b {}} } test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} { # should probably be 0 in fact... catch {file nativename ~nOsUcHuSeR} } 1 # The test below has to be done in /tmp rather than the current # directory in order to guarantee (?) a local file system: some # NFS file systems won't do the stuff below correctly. test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} { file delete -force /tmp/tcl.foo.dir/file file delete -force /tmp/tcl.foo.dir makeDirectory /tmp/tcl.foo.dir makeFile 12345 /tmp/tcl.foo.dir/file file attributes /tmp/tcl.foo.dir -permissions 0000 set result [file exists /tmp/tcl.foo.dir/file] file attributes /tmp/tcl.foo.dir -permissions 0775 removeFile /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir set result } 0 # Stat related commands catch {testsetplatform $platform} removeFile $gorpfile set gorpfile [makeFile "Test string" gorp.file] catch {file attributes $gorpfile -permissions 0765} # atime set file [makeFile "data" touch.me] test cmdAH-20.1 {Tcl_FileObjCmd: atime} { list [catch {file atime a b c} msg] $msg } {1 {wrong # args: should be "file atime name ?time?"}} test cmdAH-20.2 {Tcl_FileObjCmd: atime} { catch {unset stat} file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ [expr {[file atime $gorpfile] == $stat(atime)}] } {1 1} test cmdAH-20.3 {Tcl_FileObjCmd: atime} { string tolower [list [catch {file atime _bogus_} msg] \ $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-20.4 {Tcl_FileObjCmd: atime} { list [catch {file atime $file notint} msg] $msg } {1 {expected integer but got "notint"}} test cmdAH-20.5 {Tcl_FileObjCmd: atime touch} {unixOrPc} { if {[string equal $tcl_platform(platform) "windows"]} { set old [pwd] cd $::tcltest::temporaryDirectory if {![string equal "NTFS" [testvolumetype]]} { # Windows FAT doesn't understand atime, but NTFS does # May also fail for Windows on NFS mounted disks cd $old return 1 } cd $old } set atime [file atime $file] after 1100; # pause a sec to notice change in atime set newatime [clock seconds] set modatime [file atime $file $newatime] expr {$newatime == $modatime ? 1 : "$newatime != $modatime"} } 1 removeFile touch.me # isdirectory test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} { list [catch {file isdirectory a b} msg] $msg } {1 {wrong # args: should be "file isdirectory name"}} test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} { file isdirectory $gorpfile } 0 test cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} { file isd $dirfile } 1 # isfile test cmdAH-22.1 {Tcl_FileObjCmd: isfile} { list [catch {file isfile a b} msg] $msg } {1 {wrong # args: should be "file isfile name"}} test cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile $gorpfile} 1 test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile $dirfile} 0 # lstat and readlink: don't run these tests everywhere, since not all # sites will have symbolic links catch {file link -symbolic $linkfile $gorpfile} test cmdAH-23.1 {Tcl_FileObjCmd: lstat} { list [catch {file lstat a} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} test cmdAH-23.2 {Tcl_FileObjCmd: lstat} { list [catch {file lstat a b c} msg] $msg } {1 {wrong # args: should be "file lstat name varName"}} test cmdAH-23.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat $linkfile stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-23.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} { catch {unset stat} file lstat $linkfile stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) } {1 511 link} test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { string tolower [list [catch {file lstat _bogus_ stat} msg] \ $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} { catch {unset x} set x 44 list [catch {file lstat $gorpfile x} msg] $msg $errorCode } {1 {can't set "x(dev)": variable isn't array} NONE} catch {unset stat} # mkdir set dirA [file join [temporaryDirectory] a] set dirB [file join [temporaryDirectory] a] test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} { catch {file delete -force $dirA} file mkdir $dirA set res [file isdirectory $dirA] file delete $dirA set res } {1} test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} { catch {file delete -force $dirA} file mkdir $dirA/b set res [file isdirectory $dirA/b] file delete -force $dirA set res } {1} test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} { catch {file delete -force $dirA} file mkdir $dirA/b/c set res [file isdirectory $dirA/b/c] file delete -force $dirA set res } {1} test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} { catch {file delete -force $dirA} catch {file delete -force $dirB} file mkdir $dirA/b $dirB/a/c set res [list [file isdirectory $dirA/b] [file isdirectory $dirB/a/c]] file delete -force $dirA file delete -force $dirB set res } {1 1} # mtime set file [makeFile "data" touch.me] test cmdAH-24.1 {Tcl_FileObjCmd: mtime} { list [catch {file mtime a b c} msg] $msg } {1 {wrong # args: should be "file mtime name ?time?"}} # Check (allowing for clock-skew and OS interrupts as best we can) # that the change in mtime on a file being written is the time elapsed # between writes. Note that this can still fail on very busy systems # if there are long preemptions between the writes and the reading of # the clock, but there's not much you can do about that other than the # completely horrible "keep on trying to write until you managed to do # it all in less than a second." - DKF test cmdAH-24.2 {Tcl_FileObjCmd: mtime} { set f [open $gorpfile w] puts $f "More text" set localOld [clock seconds] close $f set old [file mtime $gorpfile] after 2000 set f [open $gorpfile w] puts $f "More text" set localNew [clock seconds] close $f set new [file mtime $gorpfile] expr { ($new > $old) && ($localNew > $localOld) && (abs(($new-$old) - ($localNew-$localOld)) <= 1) } } {1} test cmdAH-24.3 {Tcl_FileObjCmd: mtime} { catch {unset stat} file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ [expr {[file atime $gorpfile] == $stat(atime)}] } {1 1} test cmdAH-24.4 {Tcl_FileObjCmd: mtime} { string tolower [list [catch {file mtime _bogus_} msg] $msg \ $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-24.5 {Tcl_FileObjCmd: mtime} { # Under Unix, use a file in /tmp to avoid clock skew due to NFS. # On other platforms, just use a file in the local directory. if {[string equal $tcl_platform(platform) "unix"]} { set name /tmp/tcl.test.[pid] } else { set name [file join [temporaryDirectory] tf] } # Make sure that a new file's time is correct. 10 seconds variance # is allowed used due to slow networks or clock skew on a network drive. file delete -force $name close [open $name w] set a [expr abs([clock seconds]-[file mtime $name])<10] file delete $name set a } {1} test cmdAH-24.7 {Tcl_FileObjCmd: mtime} { list [catch {file mtime $file notint} msg] $msg } {1 {expected integer but got "notint"}} test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} { set mtime [file mtime $file] after 1100; # pause a sec to notice change in mtime set newmtime [clock seconds] set modmtime [file mtime $file $newmtime] expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"} } 1 test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} { set oldfile $file # introduce some non-ascii characters. append file \u2022 file delete -force $file file rename $oldfile $file set mtime [file mtime $file] after 1100; # pause a sec to notice change in mtime set newmtime [clock seconds] set err [catch {file mtime $file $newmtime} modmtime] file rename $file $oldfile if {$err} { error $modmtime } expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"} } 1 removeFile touch.me # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} { list [catch {file owned a b} msg] $msg } {1 {wrong # args: should be "file owned name"}} test cmdAH-25.2 {Tcl_FileObjCmd: owned} { file owned $gorpfile } 1 test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} { file owned / } 0 # readlink test cmdAH-26.1 {Tcl_FileObjCmd: readlink} { list [catch {file readlink a b} msg] $msg } {1 {wrong # args: should be "file readlink name"}} test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} { file readlink $linkfile } $gorpfile test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} # size test cmdAH-27.1 {Tcl_FileObjCmd: size} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} test cmdAH-27.2 {Tcl_FileObjCmd: size} { set oldsize [file size $gorpfile] set f [open $gorpfile a] fconfigure $f -translation lf -eofchar {} puts $f "More text" close $f expr {[file size $gorpfile] - $oldsize} } {10} test cmdAH-27.3 {Tcl_FileObjCmd: size} { string tolower [list [catch {file size _bogus_} msg] $msg \ $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # stat catch {testsetplatform $platform} removeFile $gorpfile set gorpfile [makeFile "Test string" gorp.file] catch {file attributes $gorpfile -permissions 0765} test cmdAH-28.1 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} test cmdAH-28.2 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ a b} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} test cmdAH-28.3 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat $gorpfile stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-28.4 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat $gorpfile stat list $stat(nlink) $stat(size) $stat(type) } {1 12 file} test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} { catch {unset stat} file stat $gorpfile stat expr $stat(mode)&0777 } {501} test cmdAH-28.6 {Tcl_FileObjCmd: stat} { string tolower [list [catch {file stat _bogus_ stat} msg] \ $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test cmdAH-28.7 {Tcl_FileObjCmd: stat} { catch {unset x} set x 44 list [catch {file stat $gorpfile x} msg] $msg $errorCode } {1 {can't set "x(dev)": variable isn't array} NONE} test cmdAH-28.8 {Tcl_FileObjCmd: stat} { # Sign extension of purported unsigned short to int. set filename [makeFile "" foo.text] file stat $filename stat set x [expr {$stat(mode) > 0}] removeFile $filename set x } 1 test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} { # stat of root directory was failing. # don't care about answer, just that test runs. # relative paths that resolve to root set old [pwd] cd c:/ file stat c: stat file stat c:. stat file stat . stat cd $old file stat / stat file stat c:/ stat file stat c:/. stat } {} test cmdAH-28.10 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} { # stat of root directory was failing. # don't care about answer, just that test runs. file stat //pop/$env(USERNAME) stat file stat //pop/$env(USERNAME)/ stat file stat //pop/$env(USERNAME)/. stat } {} test cmdAH-28.11 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} { # stat of network directory was returning id of current local drive. set old [pwd] cd c:/ file stat //pop/$env(USERNAME) stat cd $old expr {$stat(dev) == 2} } 0 test cmdAH-28.12 {Tcl_FileObjCmd: stat} { # stat(mode) with S_IFREG flag was returned as a negative number # if mode_t was a short instead of an unsigned short. set filename [makeFile "" foo.test] file stat $filename stat removeFile $filename expr {$stat(mode) > 0} } 1 catch {unset stat} # type test cmdAH-29.1 {Tcl_FileObjCmd: type} { list [catch {file size a b} msg] $msg } {1 {wrong # args: should be "file size name"}} test cmdAH-29.2 {Tcl_FileObjCmd: type} { file type $dirfile } directory test cmdAH-29.3.0 {Tcl_FileObjCmd: delete removes link not file} {unixOnly nonPortable} { set exists [list [file exists $linkfile] [file exists $gorpfile]] file delete $linkfile set exists2 [list [file exists $linkfile] [file exists $gorpfile]] list $exists $exists2 } {{1 1} {0 1}} test cmdAH-29.3 {Tcl_FileObjCmd: type} { file type $gorpfile } file test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly} { catch {file delete $linkfile} # Unlike [exec ln -s], [file link] requires an existing target file link -symbolic $linkfile $gorpfile set result [file type $linkfile] file delete $linkfile set result } link if {[string equal $tcl_platform(platform) "windows"]} { if {[string index $tcl_platform(osVersion) 0] >= 5 \ && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} { tcltest::testConstraint linkDirectory 1 } else { tcltest::testConstraint linkDirectory 0 } } else { tcltest::testConstraint linkDirectory 1 } test cmdAH-29.4.1 {Tcl_FileObjCmd: type} {linkDirectory} { set tempdir [makeDirectory temp] set linkdir [file join [temporaryDirectory] link.dir] file link -symbolic $linkdir $tempdir set result [file type $linkdir] file delete $linkdir removeDirectory $tempdir set result } link test cmdAH-29.5 {Tcl_FileObjCmd: type} { string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] } {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} { list [catch {file gorp x} msg] $msg } {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} { list [catch {file ex x} msg] $msg } {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} { list [catch {file is x} msg] $msg } {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} { list [catch {file z x} msg] $msg } {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} { list [catch {file read x} msg] $msg } {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} { list [catch {file s x} msg] $msg } {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} { list [catch {file t x} msg] $msg } {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} { list [catch {file dirname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} # channels # In testing 'file channels', we need to make sure that a channel # created in one interp isn't visible in another. interp create simpleInterp interp create -safe safeInterp interp c safeInterp expose file file test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} { list [catch {file channels a b} msg] $msg } {1 {wrong # args: should be "file channels ?pattern?"}} test cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} { # Normal interps start out with only the standard channels lsort [simpleInterp eval [list file chan]] } [lsort {stderr stdout stdin}] test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} { string equal [file channels] [file channels *] } {1} test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} { lsort [file channels std*] } [lsort {stdout stderr stdin}] set newFileId [open $gorpfile w] test cmdAH-31.5 {Tcl_FileObjCmd: channels} { set res [file channels $newFileId] string equal $newFileId $res } {1} test cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} { # Safe interps start out with no channels safeInterp eval [list file channels] } {} test cmdAH-31.7 {Tcl_FileObjCmd: channels in other interp} { list [catch {safeInterp eval [list puts $newFileId "hello"]} msg] $msg } [list 1 "can not find channel named \"$newFileId\""] interp share {} $newFileId safeInterp interp share {} stdout safeInterp test cmdAH-31.8 {Tcl_FileObjCmd: channels in other interp} { # $newFileId should now be visible in both interps list [file channels $newFileId] \ [safeInterp eval [list file channels $newFileId]] } [list $newFileId $newFileId] test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} { # we can now write to $newFileId from slave safeInterp eval [list puts $newFileId "hello"] } {} interp transfer {} $newFileId safeInterp test cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} { # $newFileId should now be visible only in safeInterp list [file channels $newFileId] \ [safeInterp eval [list file channels $newFileId]] } [list {} $newFileId] test cmdAH-31.12 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.13 {Tcl_FileObjCmd: channels in other interp} { safeInterp eval [list close $newFileId] safeInterp eval [list file channels] } {stdout} # This shouldn't work, but just in case a test above failed... catch {close $newFileId} interp delete safeInterp interp delete simpleInterp # cleanup catch {testsetplatform $platform} catch {unset platform} # Tcl_ForObjCmd is tested in for.test catch {file attributes $dirfile -permissions 0777} removeDirectory $dirfile removeFile $gorpfile # No idea how well [removeFile] copes with links... file delete $linkfile cd $cmdAHwd ::tcltest::cleanupTests return