cmdah.test

tcl是工具命令语言

    set res
} {1}
test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force $dirA}
    file mkdir $dirA/b
    set res [file isdirectory $dirA/b]
    file delete -force $dirA
    set res
} {1}
test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force $dirA}
    file mkdir $dirA/b/c
    set res [file isdirectory $dirA/b/c]
    file delete -force $dirA
    set res
} {1}
test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force $dirA}
    catch {file delete -force $dirB}
    file mkdir $dirA/b $dirB/a/c
    set res [list [file isdirectory $dirA/b] [file isdirectory $dirB/a/c]]
    file delete -force $dirA
    file delete -force $dirB
    set res
} {1 1}

# mtime 

set file [makeFile "data" touch.me]

test cmdAH-24.1 {Tcl_FileObjCmd: mtime} {
    list [catch {file mtime a b c} msg] $msg
} {1 {wrong # args: should be "file mtime name ?time?"}}
# Check (allowing for clock-skew and OS interrupts as best we can)
# that the change in mtime on a file being written is the time elapsed
# between writes.  Note that this can still fail on very busy systems
# if there are long preemptions between the writes and the reading of
# the clock, but there's not much you can do about that other than the
# completely horrible "keep on trying to write until you managed to do
# it all in less than a second."  - DKF
test cmdAH-24.2 {Tcl_FileObjCmd: mtime} {
    set f [open $gorpfile w]
    puts $f "More text"
    set localOld [clock seconds]
    close $f
    set old [file mtime $gorpfile]
    after 2000
    set f [open $gorpfile w]
    puts $f "More text"
    set localNew [clock seconds]
    close $f
    set new [file mtime $gorpfile]
    expr {
	($new > $old) && ($localNew > $localOld) &&
	(abs(($new-$old) - ($localNew-$localOld)) <= 1)
    }
} {1}
test cmdAH-24.3 {Tcl_FileObjCmd: mtime} {
    catch {unset stat}
    file stat $gorpfile stat
    list [expr {[file mtime $gorpfile] == $stat(mtime)}] \
	    [expr {[file atime $gorpfile] == $stat(atime)}]
} {1 1}
test cmdAH-24.4 {Tcl_FileObjCmd: mtime} {
    string tolower [list [catch {file mtime _bogus_} msg] $msg \
	    $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-24.5 {Tcl_FileObjCmd: mtime} {
    # Under Unix, use a file in /tmp to avoid clock skew due to NFS.
    # On other platforms, just use a file in the local directory.

    if {[string equal $tcl_platform(platform) "unix"]} {
	set name /tmp/tcl.test.[pid]
    } else {
	set name [file join [temporaryDirectory] tf]
    }

    # Make sure that a new file's time is correct.  10 seconds variance 
    # is allowed used due to slow networks or clock skew on a network drive.

    file delete -force $name
    close [open $name w]
    set a [expr abs([clock seconds]-[file mtime $name])<10]
    file delete $name
    set a
} {1}
test cmdAH-24.7 {Tcl_FileObjCmd: mtime} {
    list [catch {file mtime $file notint} msg] $msg
} {1 {expected integer but got "notint"}}
test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} {
    set mtime [file mtime $file]
    after 1100; # pause a sec to notice change in mtime
    set newmtime [clock seconds]
    set modmtime [file mtime $file $newmtime]
    expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1
test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} {
    set oldfile $file
    # introduce some non-ascii characters.
    append file \u2022
    file delete -force $file
    file rename $oldfile $file
    set mtime [file mtime $file]
    after 1100; # pause a sec to notice change in mtime
    set newmtime [clock seconds]
    set err [catch {file mtime $file $newmtime} modmtime]
    file rename $file $oldfile
    if {$err} {
	error $modmtime
    }
    expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1
removeFile touch.me

# owned

test cmdAH-25.1 {Tcl_FileObjCmd: owned} {
    list [catch {file owned a b} msg] $msg
} {1 {wrong # args: should be "file owned name"}}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} {
    file owned $gorpfile
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} {
    file owned /
} 0

# readlink

test cmdAH-26.1 {Tcl_FileObjCmd: readlink} {
    list [catch {file readlink a b} msg] $msg
} {1 {wrong # args: should be "file readlink name"}}
test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} {
    file readlink $linkfile
} $gorpfile
test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}}

# size

test cmdAH-27.1 {Tcl_FileObjCmd: size} {
    list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
    set oldsize [file size $gorpfile]
    set f [open $gorpfile a]
    fconfigure $f -translation lf -eofchar {}
    puts $f "More text"
    close $f
    expr {[file size $gorpfile] - $oldsize}
} {10}
test cmdAH-27.3 {Tcl_FileObjCmd: size} {
    string tolower [list [catch {file size _bogus_} msg] $msg \
	    $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}

# stat

catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0765}

test cmdAH-28.1 {Tcl_FileObjCmd: stat} {
    list [catch {file stat _bogus_} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.2 {Tcl_FileObjCmd: stat} {
    list [catch {file stat _bogus_ a b} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.3 {Tcl_FileObjCmd: stat} {
    catch {unset stat}
    file stat $gorpfile stat
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-28.4 {Tcl_FileObjCmd: stat} {
    catch {unset stat}
    file stat $gorpfile stat
    list $stat(nlink) $stat(size) $stat(type)
} {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} {
    catch {unset stat}
    file stat $gorpfile stat
    expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
    string tolower [list [catch {file stat _bogus_ stat} msg] \
	    $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-28.7 {Tcl_FileObjCmd: stat} {
    catch {unset x}
    set x 44
    list [catch {file stat $gorpfile x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
test cmdAH-28.8 {Tcl_FileObjCmd: stat} {
    # Sign extension of purported unsigned short to int.

    set filename [makeFile "" foo.text]
    file stat $filename stat
    set x [expr {$stat(mode) > 0}]
    removeFile $filename
    set x
} 1
test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    # relative paths that resolve to root
    set old [pwd]
    cd c:/
    file stat c: stat	    
    file stat c:. stat
    file stat . stat
    cd $old

    file stat / stat
    file stat c:/ stat
    file stat c:/. stat
} {}
test cmdAH-28.10 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    file stat //pop/$env(USERNAME) stat
    file stat //pop/$env(USERNAME)/ stat
    file stat //pop/$env(USERNAME)/. stat
} {}    
test cmdAH-28.11 {Tcl_FileObjCmd: stat} {pcOnly nonPortable} {
    # stat of network directory was returning id of current local drive.

    set old [pwd]
    cd c:/

    file stat //pop/$env(USERNAME) stat
    cd $old
    expr {$stat(dev) == 2}
} 0
test cmdAH-28.12 {Tcl_FileObjCmd: stat} {
    # stat(mode) with S_IFREG flag was returned as a negative number
    # if mode_t was a short instead of an unsigned short.

    set filename [makeFile "" foo.test]
    file stat $filename stat
    removeFile $filename
    expr {$stat(mode) > 0}
} 1
catch {unset stat}

# type

test cmdAH-29.1 {Tcl_FileObjCmd: type} {
    list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-29.2 {Tcl_FileObjCmd: type} {
    file type $dirfile
} directory
test cmdAH-29.3.0 {Tcl_FileObjCmd: delete removes link not file} {unixOnly nonPortable} {
    set exists [list [file exists $linkfile] [file exists $gorpfile]]
    file delete $linkfile
    set exists2	[list [file exists $linkfile] [file exists $gorpfile]]
    list $exists $exists2
} {{1 1} {0 1}}
test cmdAH-29.3 {Tcl_FileObjCmd: type} {
    file type $gorpfile
} file
test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly} {
    catch {file delete $linkfile}
    # Unlike [exec ln -s], [file link] requires an existing target
    file link -symbolic $linkfile $gorpfile
    set result [file type $linkfile]
    file delete $linkfile
    set result
} link
if {[string equal $tcl_platform(platform) "windows"]} {
    if {[string index $tcl_platform(osVersion) 0] >= 5 \
      && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
	tcltest::testConstraint linkDirectory 1
    } else {
	tcltest::testConstraint linkDirectory 0
    }
} else {
    tcltest::testConstraint linkDirectory 1
}
test cmdAH-29.4.1 {Tcl_FileObjCmd: type} {linkDirectory} {
    set tempdir [makeDirectory temp]
    set linkdir [file join [temporaryDirectory] link.dir]
    file link -symbolic $linkdir $tempdir
    set result [file type $linkdir]
    file delete $linkdir
    removeDirectory $tempdir
    set result
} link
test cmdAH-29.5 {Tcl_FileObjCmd: type} {
    string tolower [list [catch {file type _bogus_} msg] $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}

# Error conditions

test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
    list [catch {file gorp x} msg] $msg
} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
    list [catch {file ex x} msg] $msg
} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
    list [catch {file is x} msg] $msg
} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
    list [catch {file z x} msg] $msg
} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
    list [catch {file read x} msg] $msg
} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
    list [catch {file s x} msg] $msg
} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
    list [catch {file t x} msg] $msg
} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
    list [catch {file dirname ~woohgy} msg] $msg
} {1 {user "woohgy" doesn't exist}}

# channels
# In testing 'file channels', we need to make sure that a channel
# created in one interp isn't visible in another.

interp create simpleInterp
interp create -safe safeInterp
interp c
safeInterp expose file file

test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} {
    list [catch {file channels a b} msg] $msg
} {1 {wrong # args: should be "file channels ?pattern?"}}
test cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} {
    # Normal interps start out with only the standard channels
    lsort [simpleInterp eval [list file chan]]
} [lsort {stderr stdout stdin}]
test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} {
    string equal [file channels] [file channels *]
} {1}
test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} {
    lsort [file channels std*]
} [lsort {stdout stderr stdin}]

set newFileId [open $gorpfile w]

test cmdAH-31.5 {Tcl_FileObjCmd: channels} {
    set res [file channels $newFileId]
    string equal $newFileId $res
} {1}
test cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} {
    # Safe interps start out with no channels
    safeInterp eval [list file channels]
} {}
test cmdAH-31.7 {Tcl_FileObjCmd: channels in other interp} {
    list [catch {safeInterp eval [list puts $newFileId "hello"]} msg] $msg
} [list 1 "can not find channel named \"$newFileId\""]

interp share {} $newFileId safeInterp
interp share {} stdout safeInterp

test cmdAH-31.8 {Tcl_FileObjCmd: channels in other interp} {
    # $newFileId should now be visible in both interps
    list [file channels $newFileId] \
	    [safeInterp eval [list file channels $newFileId]]
} [list $newFileId $newFileId]
test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} {
    lsort [safeInterp eval [list file channels]]
} [lsort [list stdout $newFileId]]
test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} {
    # we can now write to $newFileId from slave
    safeInterp eval [list puts $newFileId "hello"]
} {}

interp transfer {} $newFileId safeInterp

test cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} {
    # $newFileId should now be visible only in safeInterp
    list [file channels $newFileId] \
	    [safeInterp eval [list file channels $newFileId]]
} [list {} $newFileId]
test cmdAH-31.12 {Tcl_FileObjCmd: channels in other interp} {
    lsort [safeInterp eval [list file channels]]
} [lsort [list stdout $newFileId]]
test cmdAH-31.13 {Tcl_FileObjCmd: channels in other interp} {
    safeInterp eval [list close $newFileId]
    safeInterp eval [list file channels]
} {stdout}

# This shouldn't work, but just in case a test above failed...
catch {close $newFileId}

interp delete safeInterp
interp delete simpleInterp

# cleanup
catch {testsetplatform $platform}
catch {unset platform}

# Tcl_ForObjCmd is tested in for.test

catch {file attributes $dirfile -permissions 0777}
removeDirectory $dirfile
removeFile $gorpfile
# No idea how well [removeFile] copes with links...
file delete $linkfile

cd $cmdAHwd

::tcltest::cleanupTests
return