summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/fileutil/pathops.test
diff options
context:
space:
mode:
Diffstat (limited to 'tcllib/modules/fileutil/pathops.test')
-rw-r--r--tcllib/modules/fileutil/pathops.test515
1 files changed, 515 insertions, 0 deletions
diff --git a/tcllib/modules/fileutil/pathops.test b/tcllib/modules/fileutil/pathops.test
new file mode 100644
index 0000000..0ff6866
--- /dev/null
+++ b/tcllib/modules/fileutil/pathops.test
@@ -0,0 +1,515 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# Copyright (c) 2005-2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pathops.test,v 1.2 2009/10/27 19:16:34 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal fileutil.tcl fileutil
+}
+
+# -------------------------------------------------------------------------
+
+set dir $::tcltest::temporaryDirectory
+
+# -------------------------------------------------------------------------
+
+test jail-1.0 {jail error} {
+ catch {::fileutil::jail} res
+ set res
+} [tcltest::wrongNumArgs {::fileutil::jail} {jail filename} 0]
+
+test jail-1.2 {jail error} {
+ catch {::fileutil::jail a} res
+ set res
+} [tcltest::wrongNumArgs {::fileutil::jail} {jail filename} 1]
+
+test jail-1.3 {jail error} {
+ catch {::fileutil::jail a b c} res
+ set res
+} [tcltest::tooManyArgs {::fileutil::jail} {jail filename}]
+
+test jail-2.0 {jail relative} {
+ ::fileutil::jail /var/www a/b/c
+} /var/www/a/b/c
+
+test jail-2.1 {jail absolute outside} {
+ ::fileutil::jail /var/www /a/b/c
+} /var/www/a/b/c
+
+test jail-2.1.1 {jail absolute outside, spaces} {
+ ::fileutil::jail /var/www {/a/b/c d}
+} {/var/www/a/b/c d}
+
+test jail-2.2 {jail absolute inside} {
+ ::fileutil::jail /var/www /var/www/a/b/c
+} /var/www/a/b/c
+
+test jail-2.2.1 {jail absolute inside} {
+ ::fileutil::jail /var/www {/var/www/a/b/c d}
+} {/var/www/a/b/c d}
+
+test jail-2.3 {try to escape from jail} {
+ ::fileutil::jail /var/www ../../etc/passwd
+} /var/www/etc/passwd
+
+test jail-2.4 {jail is relative itself} {
+ ::fileutil::jail a b
+} [file join $dir a b]
+
+test jail-2.4.1 {jail is relative itself, spaces in path} {
+ ::fileutil::jail a {b c}
+} [file join $dir a {b c}]
+
+test jail-2.4.2 {jail is relative itself, spaces in path} {
+ ::fileutil::jail {a b} {c d}
+} [file join $dir {a b} {c d}]
+
+
+# Need tests using non-existing paths for sure. Similar tests for
+# 'normalize' as well.
+
+# Tests for the internal 'Normalize' command. This is our forward
+# compatibility wrapper and it should behave identical to the
+# 8.4. builtin 'file normalize'. We pilfered the test cases from the
+# test suite for 'file normalize' in the Tcl core.
+
+if {![string equal $::tcl_platform(platform) windows]} {
+
+ set dirfile [makeDirectory dir.file]
+ set dirbfile [makeDirectory dir2.file]
+ set insidefile [makeFile "test file in directory" dir.file/inside.file]
+ set gorpfile [makeFile "test file" gorp.file]
+
+ # Paths for the links.
+
+ set linkfile [tempPath link.file]
+ set dirlink [tempPath dir.link]
+ set dirblink [tempPath dir2.link]
+ set linkinsidefile [tempPath $dirfile/linkinside.file]
+ set dirbblink [tempPath $dirbfile/dir2.link]]
+
+ # Create the links. Unix specific.
+
+ exec ln -s gorp.file $linkfile
+ exec ln -s inside.file $linkinsidefile
+ exec ln -s dir.file $dirlink
+ exec ln -s dir.link $dirblink
+ exec ln -s ../dir2.link $dirbblink
+
+ # File/Directory structure created by the above.
+ #
+ # /FOO/dir2.link -> dir.link
+ # /FOO/dir.link -> dir.file
+ # /FOO/dir.file/
+ # /FOO/dir.file/linkinside.file -> inside.file
+ # /FOO/dir.file/inside.file
+ #
+ # /FOO/link.file -> gorp.file
+ # /FOO/gorp.file
+ #
+ # /FOO/dir2.file/
+ # /FOO/dir2.file/dir2.link -> ../dir2.link
+}
+
+
+test fu-normalize-1.0 {link normalisation} {unixOnly} {
+ # Symlink of last path element is not resolved.
+ string equal \
+ [::fileutil::Normalize $gorpfile] \
+ [::fileutil::Normalize $linkfile]
+} {0}
+
+test fu-normalize-1.1 {link normalisation} {unixOnly} {
+ # Symlink of last path element is not resolved.
+ string equal \
+ [::fileutil::Normalize $dirfile] \
+ [::fileutil::Normalize $dirlink]
+} {0}
+
+test fu-normalize-1.2 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (File!, non-existing last component).
+ string equal \
+ [::fileutil::Normalize [file join $gorpfile foo]] \
+ [::fileutil::Normalize [file join $linkfile foo]]
+} {1}
+
+test fu-normalize-1.3 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (Directory, non-existing last component).
+ string equal \
+ [::fileutil::Normalize [file join $dirfile foo]] \
+ [::fileutil::Normalize [file join $dirlink foo]]
+} {1}
+
+test fu-normalize-1.4 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (Directory, existing last component).
+ string equal \
+ [::fileutil::Normalize $insidefile] \
+ [::fileutil::Normalize [file join $dirlink inside.file]]
+} {1}
+
+test fu-normalize-1.5 {link normalisation} {unixOnly} {
+ # Identical paths.
+ string equal \
+ [::fileutil::Normalize $linkinsidefile] \
+ [::fileutil::Normalize $linkinsidefile]
+} {1}
+
+test fu-normalize-1.6 {link normalisation} {unixOnly} {
+ # Double link, one in last component, that one not resolved.
+ string equal \
+ [::fileutil::Normalize $linkinsidefile] \
+ [::fileutil::Normalize [file join $dirlink inside.file]]
+} {0}
+
+test fu-normalize-1.7 {link normalisation} {unixOnly} {
+ # Double link, both higher up, second is file!, both resolved
+ string equal \
+ [::fileutil::Normalize [file join $dirlink linkinside.file foo]] \
+ [::fileutil::Normalize [file join $insidefile foo]]
+} {1}
+
+test fu-normalize-1.8 {link normalisation} {unixOnly} {
+ # Directory link, and bad last component
+ string equal \
+ [::fileutil::Normalize ${linkinsidefile}foo] \
+ [::fileutil::Normalize [file join $dirlink inside.filefoo]]
+} {0}
+
+if 0 {
+ test fu-normalize-1.9 {link normalisation} {unixOnly} {
+ file delete -force $dirlink
+ file link $dirlink [file nativename $dirfile]
+ string equal \
+ [::fileutil::Normalize [file join $linkinsidefile foo]] \
+ [::fileutil::Normalize [file join $dirlink inside.file foo]]
+ } {1}
+}
+
+test fu-normalize-1.10 {link normalisation: double link} {unixOnly} {
+ # Double symlink in one component.
+ string equal \
+ [::fileutil::Normalize [file join $linkinsidefile foo]] \
+ [::fileutil::Normalize [file join $dirblink inside.file foo]]
+} {1}
+
+
+test fu-normalize-1.11 {link normalisation: double link, back in tree} {unixOnly} {
+ # Double link and back up in the tree.
+
+ string equal \
+ [::fileutil::Normalize [file join $linkinsidefile foo]] \
+ [::fileutil::Normalize [file join $dirbblink inside.file foo]]
+} {1}
+
+
+test fu-normalize-2.0 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /a/b/c
+} /a/b/c
+
+test fu-normalize-2.1 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /a/../b/c
+} /b/c
+
+test fu-normalize-2.2 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /a/./b/c
+} /a/b/c
+
+test fu-normalize-2.3 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /../b/c
+} /b/c
+
+test fu-normalize-2.4 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /a/../../b/c
+} /b/c
+
+
+
+# Based on the internal Normalize, a fullnormalize (which resolves a
+# link in the last element as well.
+
+test fu-fullnormalize-1.0 {link normalisation} {unixOnly} {
+ # Symlink of last path element _is_ resolved.
+ string equal \
+ [::fileutil::fullnormalize $gorpfile] \
+ [::fileutil::fullnormalize $linkfile]
+} {1}
+
+test fu-fullnormalize-1.1 {link normalisation} {unixOnly} {
+ # Symlink of last path element _is_ resolved.
+ string equal \
+ [::fileutil::fullnormalize $dirfile] \
+ [::fileutil::fullnormalize $dirlink]
+} {1}
+
+test fu-fullnormalize-1.2 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (File!, non-existing last component).
+ string equal \
+ [::fileutil::fullnormalize [file join $gorpfile foo]] \
+ [::fileutil::fullnormalize [file join $linkfile foo]]
+} {1}
+
+test fu-fullnormalize-1.3 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (Directory, non-existing last component).
+ string equal \
+ [::fileutil::fullnormalize [file join $dirfile foo]] \
+ [::fileutil::fullnormalize [file join $dirlink foo]]
+} {1}
+
+test fu-fullnormalize-1.4 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (Directory, existing last component).
+ string equal \
+ [::fileutil::fullnormalize $insidefile] \
+ [::fileutil::fullnormalize [file join $dirlink inside.file]]
+} {1}
+
+test fu-fullnormalize-1.5 {link normalisation} {unixOnly} {
+ # Identical paths.
+ string equal \
+ [::fileutil::fullnormalize $linkinsidefile] \
+ [::fileutil::fullnormalize $linkinsidefile]
+} {1}
+
+test fu-fullnormalize-1.6 {link normalisation} {unixOnly} {
+ # Double link, one in last component, this one is resolved.
+ string equal \
+ [::fileutil::fullnormalize $linkinsidefile] \
+ [::fileutil::fullnormalize [file join $dirlink inside.file]]
+} {1}
+
+test fu-fullnormalize-1.7 {link normalisation} {unixOnly} {
+ # Double link, both higher up, second is file!, both resolved
+ string equal \
+ [::fileutil::fullnormalize [file join $dirlink linkinside.file foo]] \
+ [::fileutil::fullnormalize [file join $insidefile foo]]
+} {1}
+
+test fu-fullnormalize-1.8 {link normalisation} {unixOnly} {
+ # Directory link, and bad last component
+ string equal \
+ [::fileutil::fullnormalize ${linkinsidefile}foo] \
+ [::fileutil::fullnormalize [file join $dirlink inside.filefoo]]
+} {0}
+
+test fu-fullnormalize-1.10 {link normalisation: double link} {unixOnly} {
+ # Double symlink in one component.
+ string equal \
+ [::fileutil::fullnormalize [file join $linkinsidefile foo]] \
+ [::fileutil::fullnormalize [file join $dirblink inside.file foo]]
+} {1}
+
+
+test fu-fullnormalize-2.0 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /a/b/c
+} /a/b/c
+
+test fu-fullnormalize-2.1 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /a/../b/c
+} /b/c
+
+test fu-fullnormalize-2.2 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /a/./b/c
+} /a/b/c
+
+test fu-fullnormalize-2.3 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /../b/c
+} /b/c
+
+test fu-fullnormalize-2.4 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /a/../../b/c
+} /b/c
+
+# Cleaning up after.
+
+removeFile find3/find4/file5
+removeDirectory find3/find4
+removeDirectory find3
+removeDirectory touchTest
+removeDirectory installDst
+removeDirectory installSrc
+removeDirectory {find 1}
+removeDirectory dotfiles
+removeDirectory grepTest
+
+if {![string equal $::tcl_platform(platform) windows]} {
+ file delete -force $linkfile
+ file delete -force $dirlink
+ file delete -force $dirblink
+ file delete -force $linkinsidefile
+ file delete -force $dirbblink
+
+ removeFile dir.file/inside.file
+ removeFile gorp.file
+ removeDirectory dir.file
+ removeDirectory dir2.file
+}
+
+# -------------------------------------------------------------------------
+# Computation of paths relative to a base.
+
+test fu-relative-1.0 {fileutil::relative, wrong#args} {
+ catch {fileutil::relative} msg
+ set msg
+} [tcltest::wrongNumArgs fileutil::relative {base dst} 0]
+
+test fu-relative-1.1 {fileutil::relative, wrong#args} {
+ catch {fileutil::relative a} msg
+ set msg
+} [tcltest::wrongNumArgs fileutil::relative {base dst} 1]
+
+test fu-relative-1.2 {fileutil::relative, wrong#args} {
+ catch {fileutil::relative a b c} msg
+ set msg
+} [tcltest::tooManyArgs fileutil::relative {base dst}]
+
+foreach {n base dst result} {
+ 0 /base /base/destination destination
+ 1 /base /destination ../destination
+ 2 base base/destination destination
+ 3 base destination ../destination
+ 4 /sub/base /sub/sub/destination ../sub/destination
+ 5 /sub/sub/base /sub/destination ../../destination
+ 6 sub/base sub/sub/destination ../sub/destination
+ 7 sub/sub/base sub/destination ../../destination
+ 8 /base /base .
+ 9 base base .
+ 10 /base/sub /base/sub .
+ 11 base/sub base/sub .
+ 12 /base/sub /base ..
+ 13 base/sub base ..
+ 14 base/sub destination ../../destination
+ 15 base/tcl base/common ../common
+ 16 base/tcl/x base/common ../../common
+ 17 /base/tcl /base/common ../common
+ 18 /base/tcl/x /base/common ../../common
+} {
+ test fu-relative-2.$n {fileutil::relative} {
+ fileutil::relative $base $dst
+ } $result
+}
+
+foreach {n base dst ra rb} {
+ 0 /base base/destination absolute relative
+ 1 base /destination relative absolute
+} {
+ test fu-relative-3.$n {fileutil::relative, bad mix} unixOnly {
+ catch {fileutil::relative $base $dst} msg
+ set msg
+ } "Unable to compute relation for paths of different pathtypes: $ra vs. $rb, ($base vs. $dst)"
+}
+
+foreach {n base dst ra rb} {
+ 0 /base base/destination volumerelative relative
+ 1 base /destination relative volumerelative
+} {
+ test fu-relative-4.$n {fileutil::relative, bad mix} winOnly {
+ catch {fileutil::relative $base $dst} msg
+ set msg
+ } "Unable to compute relation for paths of different pathtypes: $ra vs. $rb, ($base vs. $dst)"
+}
+
+test fu-relativeurl-1.0 {fileutil::relativeUrl, wrong#args} {
+ catch {fileutil::relativeUrl} msg
+ set msg
+} [tcltest::wrongNumArgs fileutil::relativeUrl {base dst} 0]
+
+test fu-relativeurl-1.1 {fileutil::relativeUrl, wrong#args} {
+ catch {fileutil::relativeUrl a} msg
+ set msg
+} [tcltest::wrongNumArgs fileutil::relativeUrl {base dst} 1]
+
+test fu-relativeurl-1.2 {fileutil::relativeUrl, wrong#args} {
+ catch {fileutil::relativeUrl a b c} msg
+ set msg
+} [tcltest::tooManyArgs fileutil::relativeUrl {base dst}]
+
+foreach {n base dst result} {
+ 0 /base/file.html /base/destination/xx.html destination/xx.html
+ 1 /base/file.html /destination/xx.html ../destination/xx.html
+ 2 base/file.html base/destination/xx.html destination/xx.html
+ 3 base/file.html destination/xx.html ../destination/xx.html
+ 4 /sub/base/file.html /sub/sub/destination/xx.html ../sub/destination/xx.html
+ 5 /sub/sub/base/file.html /sub/destination/xx.html ../../destination/xx.html
+ 6 sub/base/file.html sub/sub/destination/xx.html ../sub/destination/xx.html
+ 7 sub/sub/base/file.html sub/destination/xx.html ../../destination/xx.html
+ 8 /base/file.html /base/xx.html xx.html
+ 9 base/file.html base/xx.html xx.html
+ 10 /base/sub/file.html /base/sub/xx.html xx.html
+ 11 base/sub/file.html base/sub/xx.html xx.html
+ 12 /base/sub/file.html /base/xx.html ../xx.html
+ 13 base/sub/file.html base/xx.html ../xx.html
+ 14 base/sub/file.html xx.html ../../xx.html
+ 15 base/tcl/a.html base/common/../common/./style.css ../common/style.css
+ 16 base/tcl/x/a.html base/common/../common/./style.css ../../common/style.css
+ 17 /base/tcl/a.html /base/common/../common/./style.css ../common/style.css
+ 18 /base/tcl/x/a.html /base/common/../common/./style.css ../../common/style.css
+} {
+ test fu-relativeurl-2.$n {fileutil::relativeUrl} {
+ fileutil::relativeUrl $base $dst
+ } $result
+}
+
+foreach {n base dst ra rb} {
+ 0 /base/file.html base/destination/xx.html absolute relative
+ 1 base/file.html /destination/xx.html relative absolute
+} {
+ test fu-relativeurl-3.$n {fileutil::relativeUrl, bad mix} unixOnly {
+ catch {fileutil::relativeUrl $base $dst} msg
+ set msg
+ } "Unable to compute relation for paths of different pathtypes: $ra vs. $rb, ($base vs. $dst)"
+}
+
+foreach {n base dst ra rb} {
+ 0 /base/file.html base/destination/xx.html volumerelative relative
+ 1 base/file.html /destination/xx.html relative volumerelative
+} {
+ test fu-relativeurl-4.$n {fileutil::relativeUrl, bad mix} winOnly {
+ catch {fileutil::relativeUrl $base $dst} msg
+ set msg
+ } "Unable to compute relation for paths of different pathtypes: $ra vs. $rb, ($base vs. $dst)"
+}
+
+if {[llength [info commands ::fileutil::LexNormalize]]} {
+
+ # Check an internal command. May not exist (i.e. an accelerator
+ # may not define it).
+
+ foreach {n base dst} {
+ 0 a/../b b
+ 1 a/./b a/b
+ 2 a a
+ 3 a/b a/b
+ 4 ./a a
+ 5 ../a a
+ 6 /../a /a
+ 7 /./a /a
+ 8 /a/../b /b
+ 9 /foo/bar/../snafu/../gobble /foo/gobble
+ } {
+ test fu-lexnormalize-1.$n "fileutil::LexNormalize $base" {
+ fileutil::LexNormalize $base
+ } $dst
+ }
+}
+
+# -------------------------------------------------------------------------
+
+unset dir
+testsuiteCleanup
+return
generated by cgit v0.12 at 2024-12-27 06:17:57 (GMT)