# 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.57.2.1 2009/12/28 13:53:40 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
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]}
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 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} {
list [catch {catch foo bar baz spaz} msg] $msg
} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}}
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.6.1 {Tcl_CdObjCmd} {
list [catch {cd ""} msg] $msg
} {1 {couldn't change working directory to "": 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, dirs, 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} {unix} {
set volumeList [file volumes]
catch [list glob -nocomplain [lindex $volumeList 0]*]
} {0}
test cmdAH-6.4 {Tcl_FileObjCmd: volumes} win {
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} {unix 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
test cmdAH-8.1 {Tcl_FileObjCmd: dirname} testsetplatform {
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 {
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
list [catch {file dirname /} msg] $msg
} {0 /}
test cmdAH-8.13 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname /foo} msg] $msg
} {0 /}
test cmdAH-8.14 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname //foo} msg] $msg
} {0 /}
test cmdAH-8.15 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname //foo/bar} msg] $msg
} {0 /foo}
test cmdAH-8.16 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname {//foo\/bar/baz}} msg] $msg
} {0 {/foo\/bar}}
test cmdAH-8.17 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg
} {0 {/foo\/bar/baz}}
test cmdAH-8.18 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname /foo//} msg] $msg
} {0 /}
test cmdAH-8.19 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname ./a} msg] $msg
} {0 .}
test cmdAH-8.20 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname a/.a} msg] $msg
} {0 a}
test cmdAH-8.21 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform windows
list [catch {file dirname c:foo} msg] $msg
} {0 c:}
test cmdAH-8.22 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform windows
list [catch {file dirname c:} msg] $msg
} {0 c:}
test cmdAH-8.23 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform windows
list [catch {file dirname c:/} msg] $msg
} {0 c:/}
test cmdAH-8.24 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform windows
list [catch {file dirname {c:\foo}} msg] $msg
} {0 c:/}
test cmdAH-8.25 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform windows
list [catch {file dirname {//foo/bar/baz}} msg] $msg
} {0 //foo/bar}
test cmdAH-8.26 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform windows
list [catch {file dirname {//foo/bar}} msg] $msg
} {0 //foo/bar}
test cmdAH-8.38 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname ~/foo} msg] $msg
} {0 ~}
test cmdAH-8.39 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
list [catch {file dirname ~bar/foo} msg] $msg
} {0 ~bar}
test cmdAH-8.43 {Tcl_FileObjCmd: dirname} testsetplatform {
global env
set temp $env(HOME)
set env(HOME) "/homewontexist/test"
testsetplatform unix
set result [list [catch {file dirname ~} msg] $msg]
set env(HOME) $temp
set result
} {0 /homewontexist}
test cmdAH-8.44 {Tcl_FileObjCmd: dirname} testsetplatform {
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} {
-constraints {win testsetplatform}
-match regexp
-setup {
set temp $::env(HOME)
}
-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} {
set res "ok"
} else {
set res "file dirname problem, $res1, $res2 not equal"
}
set res
} {ok}
# tail
test cmdAH-9.1 {Tcl_FileObjCmd: tail} testsetplatform {
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 {
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} testsetplatform {
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} testsetplatform {
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} testsetplatform {
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.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} testsetplatform {
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 {
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} testsetplatform {
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 {
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\\
} {}
set num 35
foreach value {a..b a...b a.c..b ..b} result {.b .b .b .b} {
foreach p {unix windows} {
;test cmdAH-11.$num {Tcl_FileObjCmd: extension} testsetplatform "
testsetplatform $p
file extension $value
" $result
incr num
}
}
# pathtype
test cmdAH-12.1 {Tcl_FileObjCmd: pathtype} testsetplatform {
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 {
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} testsetplatform {
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 {
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} testsetplatform {
testsetplatform unix
list [catch {file atime ~_bad_user} msg] $msg
} {1 {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} {
-body {list [catch {file readable a b} msg] $msg}
-result {1 {wrong # args: should be "file readable name"}}
}
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
-constraints testchmod
-setup {testchmod 0444 $gorpfile}
-body {file readable $gorpfile}
-result 1
}
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {
-constraints {unix notRoot testchmod}
-setup {testchmod 0333 $gorpfile}
-body {file reada $gorpfile}
-result 0
}
# writable
test cmdAH-17.1 {Tcl_FileObjCmd: writable} {
-body {list [catch {file writable a b} msg] $msg}
-result {1 {wrong # args: should be "file writable name"}}
}
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {
-constraints {notRoot testchmod}
-setup {testchmod 0555 $gorpfile}
-body {file writable $gorpfile}
-result 0
}
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
-constraints testchmod
-setup {testchmod 0222 $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} {} {
list [catch {file executable a b} msg] $msg
} {1 {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 0775 $gorpfile
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} {win} {
# 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.5.1 {Tcl_FileObjCmd: executable} {win} {
# On pc, must be a .exe, .com, etc.
set x [file exe $gorpfile]
set gorpexe [makeFile foo gorp.exe]
lappend x [file exe [string toupper $gorpexe]]
removeFile $gorpexe
set x
} {0 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} {
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
test cmdAH-19.6 {Tcl_FileObjCmd: nativename} testsetplatform {
testsetplatform unix
list [catch {file nativename a/b} msg] $msg [testsetplatform $platform]
} {0 a/b {}}
test cmdAH-19.7 {Tcl_FileObjCmd: nativename} testsetplatform {
testsetplatform windows
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} {unix 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
# 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]
}
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} {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} {win testvolumetype} {
set old [pwd]
cd $::tcltest::temporaryDirectory
if {"NTFS" ne [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
if {[testConstraint unix] && [file exists /tmp]} {
removeFile touch.me /tmp
} else {
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} {unix 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} {unix 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
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
}
}
}
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} {
waitForEvenSecondForFAT
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)"
}
} {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 {[testConstraint 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} 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} unix {
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
test cmdAH-24.10 {Tcl_FileObjCmd: mtime touch} win {
waitForEvenSecondForFAT
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"}
} 1
test cmdAH-24.11 {Tcl_FileObjCmd: mtime touch with non-ascii chars} win {
waitForEvenSecondForFAT
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 2100; # pause two secs to notice change in mtime on FAT fs'es
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
rename waitForEvenSecondForFAT {}
test cmdAH-24.12 {Tcl_FileObjCmd: mtime and daylight savings} {
set name [file join [temporaryDirectory] clockchange]
file delete -force $name
close [open $name w]
set time [clock scan "21:00:00 October 30 2004 GMT"]
file mtime $name $time
set newmtime [file mtime $name]
file delete $name
expr {$newmtime == $time ? 1 : "$newmtime != $time"}
} {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}
# 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} -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
# 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} {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] \
[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} {win 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}
set stat(blocks) [set stat(blksize) {}]
file stat $gorpfile stat
unset stat(blocks) stat(blksize)
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} {unix} {
catch {unset stat}
file stat $gorpfile stat
expr $stat(mode)&0o777
} {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} 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} {win 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} {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} {unix} {
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
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
# Local Variables:
# mode: tcl
# End:
|
