# 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. if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint linkDirectory [expr { ![testConstraint win] || ([string index $tcl_platform(osVersion) 0] >= 5 && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") }] global env set cmdAHwd [pwd] catch {set platform [testgetplatform]} proc waitForEvenSecondForFAT {} { # Windows 9x uses filesystems (the FAT* family of FSes) without enough # data in its timestamps for even per-second-accurate timings. :^( # This procedure based on work by Helmut Giese if { [testConstraint win] && [lindex [file system [temporaryDirectory]] 1] ne "NTFS" } then { # Assume non-NTFS means FAT{12,16,32} and hence in need of special # help... set start [clock seconds] while {1} { set now [clock seconds] if {$now!=$start && !($now & 1)} { break } after 50 } } } test cmdAH-0.1 {Tcl_BreakObjCmd, errors} -body { break foo } -returnCodes error -result {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} -returnCodes error -body { catch } -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { list [catch {catch foo bar baz} msg] $msg } {0 1} test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body { catch foo bar baz spaz } -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} test cmdAH-1.4 {Bug 3595576} { catch {catch {} -> noSuchNs::var} } 1 test cmdAH-1.5 {Bug 3595576} { catch {catch error -> noSuchNs::var} } 1 test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body { cd foo bar } -result {wrong # args: should be "cd ?dirName?"} set foodir [file join [temporaryDirectory] foo] test cmdAH-2.2 {Tcl_CdObjCmd} -setup { file delete -force $foodir set oldpwd [pwd] } -body { file mkdir $foodir cd $foodir file tail [pwd] } -cleanup { cd $oldpwd file delete $foodir } -result foo test cmdAH-2.3 {Tcl_CdObjCmd} -setup { global env set oldpwd [pwd] set temp $env(HOME) file delete -force $foodir } -body { set env(HOME) $oldpwd file mkdir $foodir cd $foodir cd ~ string equal [pwd] $oldpwd } -cleanup { cd $oldpwd file delete $foodir set env(HOME) $temp } -result 1 test cmdAH-2.4 {Tcl_CdObjCmd} -setup { global env set oldpwd [pwd] set temp $env(HOME) file delete -force $foodir } -body { set env(HOME) $oldpwd file mkdir $foodir cd $foodir cd string equal [pwd] $oldpwd } -cleanup { cd $oldpwd file delete $foodir set env(HOME) $temp } -result 1 test cmdAH-2.5 {Tcl_CdObjCmd} -returnCodes error -body { cd ~~ } -result {user "~" doesn't exist} test cmdAH-2.6 {Tcl_CdObjCmd} -returnCodes error -body { cd _foobar } -result {couldn't change working directory to "_foobar": no such file or directory} test cmdAH-2.6.1 {Tcl_CdObjCmd} -returnCodes error -body { cd "" } -result {couldn't change working directory to "": no such file or directory} test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup { set dir [pwd] } -body { cd / pwd } -cleanup { cd $dir } -result {/} test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -setup { set dir [pwd] } -returnCodes error -body { cd .\0 } -cleanup { cd $dir } -match glob -result "couldn't change working directory to \".\0\": *" 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} -returnCodes error -body { continue foo } -result {wrong # args: should be "continue"} test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { list [catch {continue} msg] $msg } {4 {}} test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding } -result {wrong # args: should be "encoding subcommand ?arg ...?"} test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto } -result {wrong # args: should be "encoding convertto ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system jis0208 encoding convertto \u4e4e } -cleanup { encoding system $system } -result 8C test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system identity encoding convertto jis0208 \u4e4e } -cleanup { encoding system $system } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system jis0208 encoding convertfrom 8C } -cleanup { encoding system $system } -result \u4e4e test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system identity encoding convertfrom jis0208 8C } -cleanup { encoding system $system } -result \u4e4e test cmdAH-4.11 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding names foo } -result {wrong # args: should be "encoding names"} test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding system foo bar } -result {wrong # args: should be "encoding system ?encoding?"} test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system identity encoding system } -cleanup { encoding system $system } -result identity test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x } -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} test cmdAH-5.4 {Tcl_FileObjCmd} { file exists "" } 0 # volume test cmdAH-6.1 {Tcl_FileObjCmd: volumes} -returnCodes error -body { file volumes x } -result {wrong # args: should be "file volumes"} test cmdAH-6.2 {Tcl_FileObjCmd: volumes} -body { lindex [file volumes] 0 } -match glob -result ?* test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body { set volumeList [file volumes] glob -nocomplain [lindex $volumeList 0]* } -match glob -result * test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body { set volumeList [string tolower [file volumes]] set element [lsearch -exact $volumeList "c:/"] list [expr {$element>-1}] [glob -nocomplain [lindex $volumeList $element]*] } -match glob -result {1 *} # attributes test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup { set foofile [makeFile abcde foo.file] catch {file delete -force $foofile} } -body { close [open $foofile w] file attributes $foofile } -cleanup { # We used [makeFile] so we undo with [removeFile] removeFile $foofile } -match glob -result * # dirname test cmdAH-8.1 {Tcl_FileObjCmd: dirname} -returnCodes error -body { file dirname a b } -result {wrong # args: should be "file dirname name"} test cmdAH-8.2 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname /a/b } /a test cmdAH-8.3 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname {} } . test cmdAH-8.5 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform win file dirname {} } . test cmdAH-8.6 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname .def } . test cmdAH-8.8 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform win file dirname a } . test cmdAH-8.9 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname a/b/c.d } a/b test cmdAH-8.10 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname a/b.c/d } a/b.c test cmdAH-8.11 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname /. } / test cmdAH-8.12 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname / } / test cmdAH-8.13 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname /foo } / test cmdAH-8.14 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname //foo } / test cmdAH-8.15 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname //foo/bar } /foo test cmdAH-8.16 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname {//foo\/bar/baz} } {/foo\/bar} test cmdAH-8.17 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname {//foo\/bar/baz/blat} } {/foo\/bar/baz} test cmdAH-8.18 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname /foo// } / test cmdAH-8.19 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname ./a } . test cmdAH-8.20 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname a/.a } a test cmdAH-8.21 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform windows file dirname c:foo } c: test cmdAH-8.22 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform windows file dirname c: } c: test cmdAH-8.23 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform windows file dirname c:/ } c:/ test cmdAH-8.24 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform windows file dirname {c:\foo} } c:/ test cmdAH-8.25 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform windows file dirname {//foo/bar/baz} } //foo/bar test cmdAH-8.26 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform windows file dirname {//foo/bar} } //foo/bar test cmdAH-8.38 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname ~/foo } ~ test cmdAH-8.39 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname ~bar/foo } ~bar test cmdAH-8.43 {Tcl_FileObjCmd: dirname} -setup { global env set temp $env(HOME) } -constraints testsetplatform -body { set env(HOME) "/homewontexist/test" testsetplatform unix file dirname ~ } -cleanup { set env(HOME) $temp } -result /homewontexist test cmdAH-8.44 {Tcl_FileObjCmd: dirname} -setup { global env set temp $env(HOME) } -constraints testsetplatform -body { set env(HOME) "~" testsetplatform unix file dirname ~ } -cleanup { set env(HOME) $temp } -result ~ test cmdAH-8.45 {Tcl_FileObjCmd: dirname} -setup { set temp $::env(HOME) } -constraints {win testsetplatform} -match regexp -body { set ::env(HOME) "/homewontexist/test" testsetplatform windows file dirname ~ } -cleanup { set ::env(HOME) $temp } -result {([a-zA-Z]:?)/homewontexist} test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { set f [file normalize [info nameof]] file exists $f set res1 [file dirname [file join $f foo/bar]] set res2 [file dirname "${f}/foo/bar"] if {$res1 eq $res2} { return "ok" } return "file dirname problem, $res1, $res2 not equal" } {ok} # tail test cmdAH-9.1 {Tcl_FileObjCmd: tail} -returnCodes error -body { file tail a b } -result {wrong # args: should be "file tail name"} test cmdAH-9.2 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail /a/b } b test cmdAH-9.3 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {} } {} test cmdAH-9.5 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform win file tail {} } {} test cmdAH-9.6 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail .def } .def test cmdAH-9.8 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform win file tail a } a test cmdAH-9.9 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file ta a/b/c.d } c.d test cmdAH-9.10 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail a/b.c/d } d test cmdAH-9.11 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail /. } . test cmdAH-9.12 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail / } {} test cmdAH-9.13 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail /foo } foo test cmdAH-9.14 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail //foo } foo test cmdAH-9.15 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail //foo/bar } bar test cmdAH-9.16 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {//foo\/bar/baz} } baz test cmdAH-9.17 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {//foo\/bar/baz/blat} } blat test cmdAH-9.18 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail /foo// } foo test cmdAH-9.19 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail ./a } a test cmdAH-9.20 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail a/.a } .a test cmdAH-9.21 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail c:foo } foo test cmdAH-9.22 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail c: } {} test cmdAH-9.23 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail c:/ } {} test cmdAH-9.24 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {c:\foo} } foo test cmdAH-9.25 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {//foo/bar/baz} } baz test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {//foo/bar} } {} test cmdAH-9.42 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) } -body { set env(HOME) "/home/test" testsetplatform unix file tail ~ } -cleanup { set env(HOME) $temp } -result test test cmdAH-9.43 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) } -body { set env(HOME) "~" testsetplatform unix file tail ~ } -cleanup { set env(HOME) $temp } -result {} test cmdAH-9.44 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) } -body { set env(HOME) "/home/test" testsetplatform windows file tail ~ } -cleanup { set env(HOME) $temp } -result test test cmdAH-9.46 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {f.oo\bar/baz.bat} } baz.bat test cmdAH-9.47 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail c:foo } foo test cmdAH-9.48 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail c: } {} test cmdAH-9.49 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail c:/foo } foo test cmdAH-9.50 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {c:/foo\bar} } bar test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {foo\bar} } bar # rootname test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body { file rootname a b } -result {wrong # args: should be "file rootname name"} test cmdAH-10.2 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file rootname {} } {} test cmdAH-10.3 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file ro foo } foo test cmdAH-10.4 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file rootname foo. } foo test cmdAH-10.5 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file rootname .foo } {} test cmdAH-10.6 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file rootname abc.def } abc test cmdAH-10.7 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file rootname abc.def.ghi } abc.def test cmdAH-10.8 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file rootname a/b/c.d } a/b/c test cmdAH-10.9 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file rootname a/b.c/d } a/b.c/d test cmdAH-10.10 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform unix file rootname a/b.c/ } a/b.c/ test cmdAH-10.23 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname {} } {} test cmdAH-10.24 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file ro foo } foo test cmdAH-10.25 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname foo. } foo test cmdAH-10.26 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname .foo } {} test cmdAH-10.27 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname abc.def } abc test cmdAH-10.28 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname abc.def.ghi } abc.def test cmdAH-10.29 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname a/b/c.d } a/b/c test cmdAH-10.30 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname a/b.c/d } a/b.c/d test cmdAH-10.31 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname a\\b.c\\ } a\\b.c\\ test cmdAH-10.32 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname a\\b\\c.d } a\\b\\c test cmdAH-10.33 {Tcl_FileObjCmd: rootname} testsetplatform { testsetplatform windows file rootname a\\b.c\\d } a\\b.c\\d test cmdAH-10.34 {Tcl_FileObjCmd: rootname} testsetplatform { 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-10.$num {Tcl_FileObjCmd: rootname and extension options} testsetplatform " testsetplatform unix [list format %s%s [file rootname $thing] [file ext $thing]] " $thing incr num } } # extension test cmdAH-11.1 {Tcl_FileObjCmd: extension} -returnCodes error -body { file extension a b } -result {wrong # args: should be "file extension name"} test cmdAH-11.2 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file extension {} } {} test cmdAH-11.3 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file ext foo } {} test cmdAH-11.4 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file extension foo. } . test cmdAH-11.5 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file extension .foo } .foo test cmdAH-11.6 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file extension abc.def } .def test cmdAH-11.7 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file extension abc.def.ghi } .ghi test cmdAH-11.8 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file extension a/b/c.d } .d test cmdAH-11.9 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file extension a/b.c/d } {} test cmdAH-11.10 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform unix file extension a/b.c/ } {} test cmdAH-11.23 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension {} } {} test cmdAH-11.24 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file ext foo } {} test cmdAH-11.25 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension foo. } . test cmdAH-11.26 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension .foo } .foo test cmdAH-11.27 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension abc.def } .def test cmdAH-11.28 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension abc.def.ghi } .ghi test cmdAH-11.29 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension a/b/c.d } .d test cmdAH-11.30 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension a/b.c/d } {} test cmdAH-11.31 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension a\\b.c\\ } {} test cmdAH-11.32 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension a\\b\\c.d } .d test cmdAH-11.33 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension a\\b.c\\d } {} test cmdAH-11.34 {Tcl_FileObjCmd: extension} testsetplatform { testsetplatform windows file extension a\\b.c\\ } {} foreach {test onPlatform value result} { cmdAH-11.35 unix a..b .b cmdAH-11.36 windows a..b .b cmdAH-11.37 unix a...b .b cmdAH-11.38 windows a...b .b cmdAH-11.39 unix a.c..b .b cmdAH-11.40 windows a.c..b .b cmdAH-11.41 unix ..b .b cmdAH-11.42 windows ..b .b } { test $test {Tcl_FileObjCmd: extension} testsetplatform " testsetplatform $onPlatform file extension $value " $result } # pathtype test cmdAH-12.1 {Tcl_FileObjCmd: pathtype} -returnCodes error -body { file pathtype a b } -result {wrong # args: should be "file pathtype name"} test cmdAH-12.2 {Tcl_FileObjCmd: pathtype} testsetplatform { testsetplatform unix file pathtype /a } absolute test cmdAH-12.3 {Tcl_FileObjCmd: pathtype} testsetplatform { testsetplatform unix file p a } relative test cmdAH-12.4 {Tcl_FileObjCmd: pathtype} testsetplatform { testsetplatform windows file pathtype c:a } volumerelative # split test cmdAH-13.1 {Tcl_FileObjCmd: split} -returnCodes error -body { file split a b } -result {wrong # args: should be "file split name"} test cmdAH-13.2 {Tcl_FileObjCmd: split} testsetplatform { testsetplatform unix file split a } a test cmdAH-13.3 {Tcl_FileObjCmd: split} testsetplatform { testsetplatform unix file split a/b } {a b} # join test cmdAH-14.1 {Tcl_FileObjCmd: join} testsetplatform { testsetplatform unix file join a } a test cmdAH-14.2 {Tcl_FileObjCmd: join} testsetplatform { testsetplatform unix file join a b } a/b test cmdAH-14.3 {Tcl_FileObjCmd: join} testsetplatform { testsetplatform unix file join a b c d } a/b/c/d # error handling of Tcl_TranslateFileName test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body { testsetplatform unix file atime ~_bad_user } -returnCodes error -result {user "_bad_user" doesn't exist} catch {testsetplatform $platform} # readable set gorpfile [makeFile abcde gorp.file] set dirfile [makeDirectory dir.file] test cmdAH-16.1 {Tcl_FileObjCmd: readable} { -returnCodes error -body {file readable a b} -result {wrong # args: should be "file readable name"} } test cmdAH-16.2 {Tcl_FileObjCmd: readable} { -constraints testchmod -setup {testchmod 0o444 $gorpfile} -body {file readable $gorpfile} -result 1 } test cmdAH-16.3 {Tcl_FileObjCmd: readable} { -constraints {unix notRoot testchmod} -setup {testchmod 0o333 $gorpfile} -body {file readable $gorpfile} -result 0 } # writable test cmdAH-17.1 {Tcl_FileObjCmd: writable} { -returnCodes error -body {file writable a b} -result {wrong # args: should be "file writable name"} } test cmdAH-17.2 {Tcl_FileObjCmd: writable} { -constraints {notRoot testchmod} -setup {testchmod 0o555 $gorpfile} -body {file writable $gorpfile} -result 0 } test cmdAH-17.3 {Tcl_FileObjCmd: writable} { -constraints testchmod -setup {testchmod 0o222 $gorpfile} -body {file writable $gorpfile} -result 1 } # executable removeFile $gorpfile removeDirectory $dirfile set dirfile [makeDirectory dir.file] set gorpfile [makeFile abcde gorp.file] test cmdAH-18.1 {Tcl_FileObjCmd: executable} -returnCodes error -body { file executable a b } -result {wrong # args: should be "file executable name"} test cmdAH-18.2 {Tcl_FileObjCmd: executable} {notRoot} { file executable $gorpfile } 0 test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} { # Only on unix will setting the execute bit on a regular file cause that # file to be executable. testchmod 0o775 $gorpfile file exe $gorpfile } 1 test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body { # On pc, must be a .exe, .com, etc. set x {} set gorpexes {} foreach ext {exe com cmd bat} { lappend x [file exe nosuchfile.$ext] set gorpexe [makeFile foo gorp.$ext] lappend gorpexes $gorpexe lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]] } set x } -cleanup { foreach gorpexe $gorpexes { removeFile $gorpexe } } -result {0 1 1 0 1 1 0 1 1 0 1 1} test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} { # 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} -returnCodes error -body { file exists a b } -result {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 test cmdAH-19.6 {Tcl_FileObjCmd: nativename} -body { testsetplatform unix file nativename a/b } -constraints testsetplatform -cleanup { testsetplatform $platform } -result a/b test cmdAH-19.7 {Tcl_FileObjCmd: nativename} -body { testsetplatform windows file nativename a/b } -constraints testsetplatform -cleanup { testsetplatform $platform } -result {a\b} test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body { # should probably be a non-error in fact... file nativename ~nOsUcHuSeR } -returnCodes error -match glob -result * # 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} -constraints {unix notRoot} -setup { file delete -force /tmp/tcl.foo.dir/file file delete -force /tmp/tcl.foo.dir } -body { makeDirectory /tmp/tcl.foo.dir makeFile 12345 /tmp/tcl.foo.dir/file file attributes /tmp/tcl.foo.dir -permissions 0000 file exists /tmp/tcl.foo.dir/file } -cleanup { file attributes /tmp/tcl.foo.dir -permissions 0775 removeFile /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir } -result 0 test cmdAH-19.12 {Bug 3608360: [file exists] mustn't do globbing} -setup { set newdirfile [makeDirectory newdir.file] set cwd [pwd] cd $newdirfile # Content of file is totally unimportant; name is *not* set innocentBystander [makeFile "abc" [file join $newdirfile foo.bar]] } -body { list [file exists foo.bar] [file exists *.bar] } -cleanup { cd $cwd removeFile $innocentBystander removeDirectory $newdirfile } -result {1 0} # Stat related commands catch {testsetplatform $platform} removeFile $gorpfile set gorpfile [makeFile "Test string" gorp.file] catch {file attributes $gorpfile -permissions 0765} # avoid problems with non-local filesystems if {[testConstraint unix] && [file exists /tmp]} { set file [makeFile "data" touch.me /tmp] } else { set file [makeFile "data" touch.me] } # atime test cmdAH-20.1 {Tcl_FileObjCmd: atime} -returnCodes error -body { file atime a b c } -result {wrong # args: should be "file atime name ?time?"} test cmdAH-20.2 {Tcl_FileObjCmd: atime} -setup { unset -nocomplain stat } -body { file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ [expr {[file atime $gorpfile] == $stat(atime)}] } -result {1 1} test cmdAH-20.3 {Tcl_FileObjCmd: atime} { list [catch {file atime _bogus_} msg] [string tolower $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} -returnCodes error -body { file atime $file notint } -result {expected integer but got "notint"} test cmdAH-20.5 {Tcl_FileObjCmd: atime touch} {unix} { 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 test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} -setup { set old [pwd] cd $::tcltest::temporaryDirectory set volumetype [testvolumetype] cd $old } -constraints {win testvolumetype} -body { if {"NTFS" ne $volumetype} { # Windows FAT doesn't understand atime, but NTFS does. May also fail # for Windows on NFS mounted disks. 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"} } -result 1 test cmdAH-20.7 { Tcl_FileObjCmd: atime (built-in Windows names) } -constraints {win} -body { file atime con } -result "could not get access time for file \"con\"" -returnCodes error test cmdAH-20.7.1 { Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension) } -constraints {win} -body { file atime [file join [temporaryDirectory] CON.txt] } -result "could not get access time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error if {[testConstraint unix] && [file exists /tmp]} { removeFile touch.me /tmp } else { removeFile touch.me } # isdirectory test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} -returnCodes error -body { file isdirectory a b } -result {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 isdirectory $dirfile} 1 # isfile test cmdAH-22.1 {Tcl_FileObjCmd: isfile} -returnCodes error -body { file isfile a b } -result {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} -returnCodes error -body { file lstat a } -result {wrong # args: should be "file lstat name varName"} test cmdAH-23.2 {Tcl_FileObjCmd: lstat} -returnCodes error -body { file lstat a b c } -result {wrong # args: should be "file lstat name varName"} test cmdAH-23.3 {Tcl_FileObjCmd: lstat} -setup { unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat lsort [array names stat] } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup { unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) } -result {1 511 link} test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { list [catch {file lstat _bogus_ stat} msg] [string tolower $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} -setup { unset -nocomplain x } -body { set x 44 list [catch {file lstat $gorpfile x} msg] $msg $errorCode } -result {1 {can't set "x(dev)": variable isn't array} {TCL LOOKUP VARNAME x}} unset -nocomplain stat # mkdir set dirA [file join [temporaryDirectory] a] set dirB [file join [temporaryDirectory] a] test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} -setup { catch {file delete -force $dirA} } -body { file mkdir $dirA file isdirectory $dirA } -cleanup { file delete $dirA } -result {1} test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} -setup { catch {file delete -force $dirA} } -body { file mkdir $dirA/b file isdirectory $dirA/b } -cleanup { file delete -force $dirA } -result {1} test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} -setup { catch {file delete -force $dirA} } -body { file mkdir $dirA/b/c file isdirectory $dirA/b/c } -cleanup { file delete -force $dirA } -result {1} test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} -setup { catch {file delete -force $dirA} catch {file delete -force $dirB} } -body { file mkdir $dirA/b $dirB/a/c list [file isdirectory $dirA/b] [file isdirectory $dirB/a/c] } -cleanup { file delete -force $dirA file delete -force $dirB } -result {1 1} test cmdAH-23.11 {Tcl_FileObjCmd: mkdir} { # Allow zero arguments (TIP 323) file mkdir } {} set file [makeFile "data" touch.me] # mtime test cmdAH-24.1 {Tcl_FileObjCmd: mtime} -returnCodes error -body { file mtime a b c } -result {wrong # args: should be "file mtime name ?time?"} test cmdAH-24.2 {Tcl_FileObjCmd: mtime} -setup { # 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 waitForEvenSecondForFAT } -body { set f [open $gorpfile w] puts $f "More text" close $f set clockOld [clock seconds] set fileOld [file mtime $gorpfile] after 2000 set f [open $gorpfile w] puts $f "More text" close $f set clockNew [clock seconds] set fileNew [file mtime $gorpfile] expr { (($fileNew > $fileOld) && ($clockNew > $clockOld) && (abs(($fileNew-$fileOld) - ($clockNew-$clockOld)) <= 1)) ? "1" : "file:($fileOld=>$fileNew) clock:($clockOld=>$clockNew)" } } -result {1} test cmdAH-24.3 {Tcl_FileObjCmd: mtime} -setup { unset -nocomplain stat } -body { file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ [expr {[file atime $gorpfile] == $stat(atime)}] } -result {1 1} test cmdAH-24.4 {Tcl_FileObjCmd: mtime} { list [catch {file mtime _bogus_} msg] [string tolower $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} -setup { # 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 {[testConstraint unix]} { set name /tmp/tcl.test.[pid] } else { set name [file join [temporaryDirectory] tf] } } -body { # 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] expr {abs([clock seconds]-[file mtime $name])<10} } -cleanup { file delete $name } -result {1} test cmdAH-24.7 {Tcl_FileObjCmd: mtime} -returnCodes error -body { file mtime $file notint } -result {expected integer but got "notint"} test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} unix { 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} -setup { set oldfile $file } -constraints unix -body { # 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 modmtime [file mtime $file $newmtime] expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"} } -cleanup { file rename $file $oldfile } -result 1 test cmdAH-24.10 {Tcl_FileObjCmd: mtime touch} -constraints win -setup { waitForEvenSecondForFAT } -body { set mtime [file mtime $file] after 2100; # pause two secs to notice change in mtime on FAT fs'es set newmtime [clock seconds] set modmtime [file mtime $file $newmtime] expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"} } -result 1 test cmdAH-24.11 {Tcl_FileObjCmd: mtime touch with non-ascii chars} -setup { waitForEvenSecondForFAT set oldfile $file } -constraints win -body { # introduce some non-ascii characters. append file \u2022 file delete -force $file file rename $oldfile $file set mtime [file mtime $file] after 2100; # pause two secs to notice change in mtime on FAT fs'es set newmtime [clock seconds] set modmtime [file mtime $file $newmtime] expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"} } -cleanup { file rename $file $oldfile } -result 1 removeFile touch.me rename waitForEvenSecondForFAT {} test cmdAH-24.12 {Tcl_FileObjCmd: mtime and daylight savings} -setup { set name [file join [temporaryDirectory] clockchange] file delete -force $name close [open $name w] } -body { set time [clock scan "21:00:00 October 30 2004 GMT"] file mtime $name $time set newmtime [file mtime $name] expr {$newmtime == $time ? 1 : "$newmtime != $time"} } -cleanup { file delete $name } -result {1} # bug 1420432: setting mtime fails for directories on windows. test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} -setup { set dirname [file join [temporaryDirectory] tmp[pid]] file delete -force $dirname } -constraints tempNotWin -body { file mkdir $dirname set old [file mtime $dirname] file mtime $dirname 0 set new [file mtime $dirname] list $new [expr {$old != $new}] } -cleanup { file delete -force $dirname } -result {0 1} test cmdAH-24.14 { Tcl_FileObjCmd: mtime (built-in Windows names) } -constraints {win} -body { file mtime con } -result "could not get modification time for file \"con\"" -returnCodes error test cmdAH-24.14.1 { Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension) } -constraints {win} -body { file mtime [file join [temporaryDirectory] CON.txt] } -result "could not get modification time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body { file owned a b } -result {wrong # args: should be "file owned name"} test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -body { file owned $gorpfile } -result 1 test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { # Avoid problems with AFS set tmpfile [makeFile "data" touch.me /tmp] } -body { file owned $tmpfile } -cleanup { removeFile touch.me /tmp } -result 1 test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} { file owned / } 0 test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body { file owned $env(windir) } -result 0 test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body { file owned nosuchfile } -result 0 # readlink test cmdAH-26.1 {Tcl_FileObjCmd: readlink} -returnCodes error -body { file readlink a b } -result {wrong # args: should be "file readlink name"} test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unix nonPortable} { file readlink $linkfile } $gorpfile test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unix nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] $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} {win nonPortable} { list [catch {file readlink _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not readlink "_bogus_": invalid argument} {POSIX EINVAL {invalid argument}}} # size test cmdAH-27.1 {Tcl_FileObjCmd: size} -returnCodes error -body { file size a b } -result {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} { list [catch {file size _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} test cmdAH-27.4 { Tcl_FileObjCmd: size (built-in Windows names) } -constraints {win} -body { file size con } -result 0 test cmdAH-27.4.1 { Tcl_FileObjCmd: size (built-in Windows names with dir path and extension) } -constraints {win} -body { file size [file join [temporaryDirectory] con.txt] } -result 0 catch {testsetplatform $platform} removeFile $gorpfile set gorpfile [makeFile "Test string" gorp.file] catch {file attributes $gorpfile -permissions 0765} # stat test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body { file stat _bogus_ } -result {wrong # args: should be "file stat name varName"} test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body { file stat _bogus_ a b } -result {wrong # args: should be "file stat name varName"} test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { unset -nocomplain stat set stat(blocks) [set stat(blksize) {}] } -body { file stat $gorpfile stat unset stat(blocks) stat(blksize); # Ignore these fields; not always set lsort [array names stat] } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-28.4 {Tcl_FileObjCmd: stat} -setup { unset -nocomplain stat } -body { file stat $gorpfile stat list $stat(nlink) $stat(size) $stat(type) } -result {1 12 file} test cmdAH-28.5 {Tcl_FileObjCmd: stat} -constraints {unix} -setup { unset -nocomplain stat } -body { file stat $gorpfile stat expr {$stat(mode) & 0o777} } -result {501} test cmdAH-28.6 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ stat} msg] [string tolower $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} -setup { unset -nocomplain x } -returnCodes error -body { set x 44 file stat $gorpfile x } -result {can't set "x(dev)": variable isn't array} test cmdAH-28.8 {Tcl_FileObjCmd: stat} -setup { set filename [makeFile "" foo.text] } -body { # Sign extension of purported unsigned short to int. file stat $filename stat expr {$stat(mode) > 0} } -cleanup { removeFile $filename } -result 1 test cmdAH-28.9 {Tcl_FileObjCmd: stat} win { # 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} {win 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} -setup { set old [pwd] } -constraints {win nonPortable} -body { # stat of network directory was returning id of current local drive. cd c:/ file stat //pop/$env(USERNAME) stat expr {$stat(dev) == 2} } -cleanup { cd $old } -result 0 test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup { set filename [makeFile "" foo.test] } -body { # stat(mode) with S_IFREG flag was returned as a negative number if mode_t # was a short instead of an unsigned short. file stat $filename stat expr {$stat(mode) > 0} } -cleanup { removeFile $filename } -result 1 test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { unset -nocomplain stat } -body { file stat con stat lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} } -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { unset -nocomplain stat } -body { file stat [file join [temporaryDirectory] CON.txt] stat lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} } -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} unset -nocomplain stat # type test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body { file type a b } -result {wrong # args: should be "file type name"} test cmdAH-29.2 {Tcl_FileObjCmd: type} { file type $dirfile } directory test cmdAH-29.3.0 {Tcl_FileObjCmd: delete removes link not file} {unix 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} -constraints {unix} -setup { catch {file delete $linkfile} } -body { # Unlike [exec ln -s], [file link] requires an existing target file link -symbolic $linkfile $gorpfile file type $linkfile } -cleanup { file delete $linkfile } -result link test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup { set tempdir [makeDirectory temp] } -body { set linkdir [file join [temporaryDirectory] link.dir] file link -symbolic $linkdir $tempdir file type $linkdir } -cleanup { file delete $linkdir removeDirectory $tempdir } -result link test cmdAH-29.5 {Tcl_FileObjCmd: type} { list [catch {file type _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} test cmdAH-29.6 { Tcl_FileObjCmd: type (built-in Windows names) } -constraints {win} -body { file type con } -result "characterSpecial" test cmdAH-29.6.1 { Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension) } -constraints {win} -body { file type [file join [temporaryDirectory] CON.txt] } -result "characterSpecial" # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x } -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file is x } -match glob -result {unknown or ambiguous subcommand "is": must be *} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file z x } -match glob -result {unknown or ambiguous subcommand "z": must be *} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file read x } -match glob -result {unknown or ambiguous subcommand "read": must be *} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file s x } -match glob -result {unknown or ambiguous subcommand "s": must be *} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file t x } -match glob -result {unknown or ambiguous subcommand "t": must be *} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file dirname ~woohgy } -result {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 create catch {safeInterp expose file file} test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} -body { file channels a b } -returnCodes error -result {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]] } {stderr stdin stdout} 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*] } {stderr stdin stdout} 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} -body { safeInterp eval [list puts $newFileId "hello"] } -returnCodes error -result "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} # Temp files (TIP#210) test cmdAH-32.1 {file tempfile - usage} -returnCodes error -body { file tempfile a b c } -result {wrong # args: should be "file tempfile ?nameVar? ?template?"} test cmdAH-32.2 {file tempfile - returns a read/write channel} -body { set f [file tempfile] puts $f ok seek $f 0 gets $f } -cleanup { catch {close $f} } -result ok test cmdAH-32.3 {file tempfile - makes filenames} -setup { unset -nocomplain name } -body { set result [info exists name] set f [file tempfile name] lappend result [info exists name] [file exists $name] close $f lappend result [file exists $name] } -cleanup { catch {close $f} catch {file delete $name} } -result {0 1 1 1} # We try to obey the template on Unix, but don't (currently) bother on Win test cmdAH-32.4 {file tempfile - templates} -constraints unix -body { close [file tempfile name foo] expr {[string match foo* [file tail $name]] ? "ok" : "foo produced $name"} } -cleanup { catch {file delete $name} } -result ok test cmdAH-32.5 {file tempfile - templates} -constraints unix -body { set template [file join $dirfile foo] close [file tempfile name $template] expr {[string match $template* $name] ? "ok" : "$template produced $name"} } -cleanup { catch {file delete $name} } -result ok # Not portable; not all unix systems have mkstemps() test cmdAH-32.6 {file tempfile - templates} -body { set template [file join $dirfile foo] close [file tempfile name $template.bar] expr {[string match $template*.bar $name] ? "ok" : "$template.bar produced $name"} } -constraints {unix nonPortable} -cleanup { catch {file delete $name} } -result ok # 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} unset -nocomplain 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 # Local Variables: # mode: tcl # End: