1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
|
# Commands covered: vfs::urltype::Mount and friends.
#
# 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) 2001 by Vince Darley.
#
# 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
namespace import ::tcltest::*
}
package require vfs::urltype
puts stdout "These tests require an internet connection, and might"
puts stdout "take a long time to complete."
set vfsTestDir [pwd]
if {![file writable $vfsTestDir]} {
if {[info exists env(TEMP)] && [file writable $env(TEMP)]} {
set vfsTestDir $env(TEMP)
tcltest::testConstraint vfsWritable 1
puts stdout "Using temporary directory for some files\
(since [pwd] is not writable)"
} else {
tcltest::testConstraint vfsWritable 0
}
} else {
tcltest::testConstraint vfsWritable 1
}
test vfsUrl-1.1 {mount} {
vfs::urltype::Mount ftp
} {Mounted at "ftp://"}
test vfsUrl-1.2 {mount} {
file exists ftp://ftp.tcl.tk
} {1}
test vfsUrl-1.3 {mounted volumes} {
set idx [lsearch -exact [file volumes] ftp://]
if {$idx < 0} {
set res "No ftp:// volume!"
} else {
set res "New volume 'ftp://' mounted"
}
set res
} {New volume 'ftp://' mounted}
test vfsUrl-2.1 {auto-mount ftp and copy file} {vfsWritable} {
file delete -force README.tclversions
file copy ftp://ftp.tcl.tk/pub/tcl/README.tclversions $vfsTestDir
set to [file join $vfsTestDir README.tclversions]
if {[file exists $to]} {
if {[file size $to] < 800} {
set res "file too short"
} else {
set res "ok"
}
} else {
set res "file doesn't exist"
}
file delete $to
set res
} {ok}
test vfsUrl-2.2 {auto-mount bad ftp} {
catch {file copy ftp://invalid.name.dom/pub/tcl/README.tclversions $vfsTestDir}
set to [file join $vfsTestDir README.tclversions]
if {[file exists $to]} {
set res "file shouldn't exist!"
file delete -force $to
} else {
set res "file doesn't exist"
}
set res
} {file doesn't exist}
test vfsUrl-3.1 {mount http} {
vfs::urltype::Mount http
} {Mounted at "http://"}
# cleanup
catch {
# Unmount all successfully mounted volumes.
foreach vol [file volumes] {
if {[regexp {^([a-zA-Z]+):/?//$} $vol "" type]} {
catch {vfs::urltype::Unmount $type}
}
}
}
::tcltest::cleanupTests
return
|