Tcl Source Code

# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

cd [temporaryDirectory]

testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winVista 0
testConstraint win2000orXP 0
testConstraint winOlderThan2000 0
# Don't know how to determine this constraint correctly
testConstraint notNetworkFilesystem 0
testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}]
testConstraint 2000orNewer [expr {![testConstraint 95or98]}]

# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
testConstraint foundGroup [expr {![testConstraint unix]}]
if {[testConstraint unix]} {
    catch {
	set groupList [exec groups]
	set group [lindex $groupList 0]
	testConstraint foundGroup 1
    }

    proc dev dir {
	file stat $dir stat
	return $stat(dev)
    }

    if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} {
	testConstraint xdev [expr {([dev .] != [dev $tmpspace])}]
    }
}

# Also used in winFCmd...
if {[testConstraint winOnly]} {
    set major [string index $tcl_platform(osVersion) 0]
    if {[testConstraint nt] && $major > 4} {
        if {$major > 5} {

proc contents {file} {
    set f [open $file]
    set r [read $f]
    close $f
    return $r
}









set root [lindex [file split [pwd]] 0]

# A really long file name
# length of long is 1216 chars, which should be greater than any static buffer
# or allowable filename.

} -constraints {notRoot} -body {
    file mkdir [file join td1 td2]
    createfile [file join td1 td2 tf1]
    file mkdir td2
    file rename -force td2 td1
} -returnCodes error -match glob -result \
    [subst {error renaming "td2" to "[file join td1 td2]": file *}]
test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {xdev notRoot} {
    cleanup $tmpspace
    createfile tf1
    file rename tf1 $tmpspace
    glob -nocomplain tf* [file join $tmpspace tf1]
} [file join $tmpspace tf1]
test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} -constraints {win} -setup {
    catch {file delete -force c:/tcl8975@ d:/tcl8975@}
} -body {
    file mkdir c:/tcl8975@
    if {[catch {file rename c:/tcl8975@ d:/}]} {
	return d:/tcl8975@
    }
    glob c:/tcl8975@ d:/tcl8975@
} -cleanup {
    file delete -force c:/tcl8975@
    catch {file delete -force d:/tcl8975@}
} -result {d:/tcl8975@}
test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} \
	{xdev notRoot} {
    cleanup $tmpspace
    file mkdir td1
    file rename td1 $tmpspace
    glob -nocomplain td* [file join $tmpspace td*]
} [file join $tmpspace td1]
test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} \
	{xdev notRoot} {
    cleanup $tmpspace
    createfile tf1
    file rename tf1 $tmpspace
    glob -nocomplain tf* [file join $tmpspace tf*]
} [file join $tmpspace tf1]
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
    cleanup $tmpspace
} -constraints {notRoot xdev} -body {
    file mkdir td1/td2/td3
    file attributes td1 -permissions 0000
    file rename td1 $tmpspace
} -returnCodes error -cleanup {
    file attributes td1 -permissions 0755
    cleanup
} -match regexp -result {^error renaming "td1"( to "/tmp/tcl\d+/td1")?: permission denied$}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup {
    cleanup
} -constraints {unix notRoot} -body {
    file mkdir ~/td1/td2
    set td1name [file join [file dirname ~] [file tail ~] td1]
    file attributes $td1name -permissions 0000
    file copy ~/td1 td1

    file attributes $td2name -permissions 0000
    file copy ~/td1 td1
} -returnCodes error -cleanup {
    file attributes $td2name -permissions 0755
    file delete -force ~/td1
} -result "error copying \"~/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
    cleanup $tmpspace
} -constraints {notRoot xdev} -returnCodes error -body {
    file mkdir td1/td2/td3
    file mkdir [file join $tmpspace td1]
    createfile [file join $tmpspace td1 tf1]
    file rename -force td1 $tmpspace
} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": file already exists}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
    cleanup $tmpspace
} -constraints {notRoot xdev} -body {
    file mkdir td1/td2/td3
    file attributes td1/td2/td3 -permissions 0000
    file rename td1 $tmpspace
} -returnCodes error -cleanup {
    file attributes td1/td2/td3 -permissions 0755
    cleanup $tmpspace
} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": "td1/td2/td3": permission denied}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} -setup {
    cleanup $tmpspace
} -constraints {notRoot xdev} -body {
    file mkdir td1/td2/td3
    file rename td1 $tmpspace
    glob td* [file join $tmpspace td1 t*]
} -result [file join $tmpspace td1 td2]
test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} -setup {
    cleanup $tmpspace
} -constraints {xdev notRoot} -body {
    file mkdir foo/bar
    file attr foo -perm 040555
    file rename foo/bar $tmpspace
} -returnCodes error -cleanup {
    catch {file delete [file join $tmpspace bar]}
    catch {file attr foo -perm 040777}
    catch {file delete -force foo}
} -match glob -result {*: permission denied}
test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} -setup {
    cleanup $tmpspace
} -constraints {notRoot xdev} -body {
    file mkdir [file join $tmpspace td1]
    createfile [file join $tmpspace td1 tf1]
    file rename [file join $tmpspace td1 tf1] tf1
    list [file exists [file join $tmpspace td1 tf1]] [file exists tf1]
} -result {0 1}
test fCmd-6.32 {CopyRenameOneFile: copy} -constraints {notRoot} -setup {
    cleanup
} -returnCodes error -body {
    file copy tf1 tf2
} -result {error copying "tf1": no such file or directory}


test fCmd-7.1 {FileForceOption: none} -constraints {notRoot} -setup {
    cleanup
} -returnCodes error -body {
    file mkdir [file join tf1 tf2]
    file delete tf1
} -result {error deleting "tf1": directory not empty}

    file attributes tfa -permissions 0555
    catch {file rename tfa/dir tfa2}
} -cleanup {
    catch {file attributes tfa -permissions 0777}
    file delete -force tfa
} -result {1}
test fCmd-12.9 {renamefile: moving a file across volumes} -setup {
    cleanup $tmpspace
} -constraints {xdev notRoot} -body {
    set s [createfile tfa]
    file rename tfa $tmpspace
    list [checkcontent [file join $tmpspace tfa] $s] [file exists tfa]
} -cleanup {
    cleanup $tmpspace
} -result {1 0}
test fCmd-12.10 {renamefile: moving a directory across volumes} -setup {
    cleanup $tmpspace
} -constraints {xdev notRoot} -body {
    file mkdir tfad
    set s [createfile tfad/a]
    file rename tfad $tmpspace
    list [checkcontent [file join $tmpspace tfad a] $s] [file exists tfad]
} -cleanup {
    cleanup $tmpspace
} -result {1 0}

#
# Coverage tests for TclCopyFilesCmd()
#
test fCmd-13.1 {TclCopyFilesCmd: -force option} -constraints notRoot -setup {
    catch {file delete -force -- tfa1}

	return [file readable "~/NTUSER.DAT"]
    }
    return 0
} -result {0}

# cleanup
cleanup
if {[testConstraint unix]} {
    removeDirectory tcl[pid] /tmp
}
::tcltest::cleanupTests
return