From c80adf7181a11b958398883f72db85a904e19eb5 Mon Sep 17 00:00:00 2001 From: Vince Darley Date: Wed, 22 Aug 2001 16:38:22 +0000 Subject: [PATCH] url mounting --- ChangeLog | 7 +++++++ Readme.txt | 44 ++++++++++++++++++++++++++++++++++++++++++++ doc/vfs.n | 36 +++++++++++++++++++++++------------- generic/vfs.c | 26 ++++++++++++++++++++++++-- library/ftpvfs.tcl | 7 +++++-- library/pkgIndex.tcl | 7 ++++++- library/tclIndex | 5 +++++ library/vfsUrl.tcl | 24 ++++++++++++++++++++++++ library/vfsUtils.tcl | 24 ++++++++++++++++++++++++ win/makefile.vc | 2 +- 10 files changed, 163 insertions(+), 19 deletions(-) create mode 100644 library/vfsUrl.tcl diff --git a/ChangeLog b/ChangeLog index 6eed4b2..dbe7b0a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2001-08-22 Vince Darley + * added ability to treat entire urls as file paths, so + we can mount 'ftp://' as a root volume and examine its + contents. This requires a patch to Tcl 8.4a4 which + is currently available from the Tcl project (see the + 'fs update' patch/bug). + 2001-08-13 Vince Darley * ftp vfs works reasonably well now; try: % package require vfs diff --git a/Readme.txt b/Readme.txt index c71444d..136ff71 100644 --- a/Readme.txt +++ b/Readme.txt @@ -1,3 +1,11 @@ +Hello! The code here has evolved from ideas and excellent work by Matt +Newman, Jean-Claude Wippler, TclKit etc. To make this really successful, +we need a group of volunteers to enhance what we have and build a new way +of writing and distributing Tcl code. + +Introduction +------------ + This is an implementation of a 'vfs' extension (and a 'vfs' package, including a small library of Tcl code). The goal of this extension is to expose Tcl 8.4a3's new filesystem C API to the Tcl level. @@ -27,6 +35,9 @@ the code completely cleaned up and documented as the package evolves. -- Vince Darley, August 1st 2001 +Current implementation +---------------------- + Some of the provided vfs's require the Memchan extension for any operation which involves opening files. @@ -48,3 +59,36 @@ the archive itself. The result of this is that Tcl will then see the archive as a directory, rather than a file. Otherwise you might wish to create a dummy file/directory called 'local' before mounting. +Limitations +----------- + +We can't currently mount a file protocol. For example it would be nice to +tell Tcl that we understand 'ftp://' as meaning an absolute path to be +handled by our ftp-vfs system. Then we could so something like + + file copy ftp://ftp.foo.com/pub/readme.txt ~/readme.txt + +and our ftp-vfs system can deal with it. This is really a limitation in +Tcl's current understanding of file paths (and not any problem in this +extension per se). + +Of course what we can do is mount any specific ftp address to somewhere in +the filesystem. For example, we can mount 'ftp://ftp.foo.com/ to +/ftp.foo.com/ and proceed from there. + +Future thoughts +--------------- + +See: + +http://www.ximian.com/tech/gnome-vfs.php3 +http://www.lh.com/~oleg/ftp/HTTP-VFS.html + +for some ideas. It would be good to accumulate ideas on the limitations of +the current VFS support so we can plan out what vfs 2.0 will look like (and +what changes will be needed in Tcl's core to support it). Obvious things +which come to mind are asynchronicity: 'file copy' from a mounted remote +site (ftp or http) is going to be very slow and simply block the +application. Commands like that should have new asynchronous versions which +can be used when desired (e.g. 'file copy from to -callback foo'). + diff --git a/doc/vfs.n b/doc/vfs.n index 87ad878..9cc8648 100644 --- a/doc/vfs.n +++ b/doc/vfs.n @@ -124,21 +124,31 @@ the given file to that value. .TP \fIcommand\fR \fImatchindirectory\fR \fIr-r-a\fR \fIpattern\fR \fItypes\fR Return the list of files or directories in the given path (which is -always the name of an existing directory), which match the \fIpattern\fR -and are compatible with the \fItypes\fR given. It is very important -that the command correctly handle \fItypes\fR requests for directories -only (and files only). +always the name of an existing directory), which match the +\fIpattern\fR and are compatible with the \fItypes\fR given. It is +very important that the command correctly handle \fItypes\fR requests +for directories only (and files only), because to handle any kind of +recursive globbing, Tcl will actually generate requests for +directory-only matches from the filesystem. See \fBvfs::matchDirectories\fR +below for help. .TP \fIcommand\fR \fIopen\fR \fIr-r-a\fR \fImode\fR \fIpermissions\fR -For this command, \fImode\fR is a list of POSIX open modes or a -string such as "rw". If the open involves creating a file, then -\fIpermissions\fR dictates what modes to create it with. If the -open operation is successful, the command -should return a list of one or two items. The first item (which -is obligatory) is the name of the channel which has been created. -The second item, if given, is a Tcl-callback to be used when the -channel is closed, so that the vfs can clean up as appropriate. -If the open operation was not successful, an error should be thrown. +For this command, \fImode\fR is a list of POSIX open modes or a string +such as "rw". If the open involves creating a file, then +\fIpermissions\fR dictates what modes to create it with. If the open +operation was not successful, an error should be thrown. If the open +operation is successful, the command should return a list of either one +or two items. The first item (which is obligatory) is the name of the +channel which has been created. The second item, if given, is a +Tcl-callback to be used when the channel is closed, so that the vfs can +clean up as appropriate. This callback will be evaluated by Tcl just +before the channel is closed. The channel will still exist, and all +available data will have been flushed into it. The callback can, for +example, seek to the beginning of the channel, read its contents and +store that contents elsewhere (e.g. compressed or on a remote ftp +site, etc). The return code or any errors returned by the callback +are ignored (if the callback wishes to signal an error, it must do so +asychronously, with bgerror, for example). .TP \fIcommand\fR \fIremovedirectory\fR \fIr-r-a\fR Delete the given directory. diff --git a/generic/vfs.c b/generic/vfs.c index 96aee88..d6a8915 100644 --- a/generic/vfs.c +++ b/generic/vfs.c @@ -101,6 +101,7 @@ static Tcl_FSFilesystemPathTypeProc VfsFilesystemPathType; static Tcl_FSFilesystemSeparatorProc VfsFilesystemSeparator; static Tcl_FSFreeInternalRepProc VfsFreeInternalRep; static Tcl_FSDupInternalRepProc VfsDupInternalRep; +static Tcl_FSListVolumesProc VfsListVolumes; static Tcl_Filesystem vfsFilesystem = { "tclvfs", @@ -122,9 +123,9 @@ static Tcl_Filesystem vfsFilesystem = { &VfsOpenFileChannel, &VfsMatchInDirectory, &VfsUtime, - /* readlink and listvolumes are not important */ - NULL, + /* link is not important */ NULL, + &VfsListVolumes, &VfsFileAttrStrings, &VfsFileAttrsGet, &VfsFileAttrsSet, @@ -1071,6 +1072,27 @@ VfsUtime(pathPtr, tval) return returnVal; } +Tcl_Obj* +VfsListVolumes(void) +{ + Tcl_Obj *resultPtr; + Tcl_SavedResult savedResult; + Tcl_Interp* interp; + + interp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem); + Tcl_SaveResult(interp, &savedResult); + + /* List all vfs volumes */ + if (Tcl_GlobalEval(interp, "::vfs::listVolumes") == TCL_OK) { + resultPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + Tcl_IncrRefCount(resultPtr); + } else { + resultPtr = NULL; + } + Tcl_RestoreResult(interp, &savedResult); + return resultPtr; +} + /* *---------------------------------------------------------------------- diff --git a/library/ftpvfs.tcl b/library/ftpvfs.tcl index 5775ef2..eda3f7d 100644 --- a/library/ftpvfs.tcl +++ b/library/ftpvfs.tcl @@ -8,8 +8,11 @@ proc vfs::ftp::Mount {dirurl local} { if {[string range $dirurl 0 5] == "ftp://"} { set dirurl [string range $dirurl 6 end] } - regexp {(([^:]*)(:([^@]*))?@)?([^/]*)/(.*/)?([^/]*)$} $dirurl \ - junk junk user junk pass host path file + if {![regexp {(([^:]*)(:([^@]*))?@)?([^/]*)/(.*/)?([^/]*)$} $dirurl \ + junk junk user junk pass host path file]} { + return -code error "Sorry I didn't understand\ + the url address \"$dirurl\"" + } if {[string length $file]} { return -code error "Can only mount directories, not\ diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl index 45125a6..fc802e5 100644 --- a/library/pkgIndex.tcl +++ b/library/pkgIndex.tcl @@ -9,7 +9,12 @@ # full path name of this file's directory. lappend auto_path $dir -package ifneeded vfs 1.0 [list load [file join $dir vfs10[info sharedlibextension]]] +if {[info exists tcl_platform(debug)]} { + package ifneeded vfs 1.0 [list load [file join $dir vfs10d[info sharedlibextension]]] +} else { + package ifneeded vfs 1.0 [list load [file join $dir vfs10[info sharedlibextension]]] +} + package ifneeded scripdoc 0.3 [list source [file join $dir scripdoc.tcl]] package ifneeded mk4vfs 1.0 [list source [file join $dir mk4vfs.tcl]] package ifneeded vfslib 0.1 [list source [file join $dir vfs.tcl]] diff --git a/library/tclIndex b/library/tclIndex index 063c8b0..f00f3c1 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -74,6 +74,11 @@ set auto_index(::vfs::test::deletefile) [list source [file join $dir testvfs.tcl set auto_index(::vfs::test::fileattributes) [list source [file join $dir testvfs.tcl]] set auto_index(::vfs::test::utime) [list source [file join $dir testvfs.tcl]] set auto_index(::vfs::debug) [list source [file join $dir vfs.tcl]] +set auto_index(::vfs::url::Mount) [list source [file join $dir vfsUrl.tcl]] +set auto_index(::vfs::url::handler) [list source [file join $dir vfsUrl.tcl]] +set auto_index(::vfs::listVolumes) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::addVolume) [list source [file join $dir vfsUtils.tcl]] +set auto_index(::vfs::removeVolume) [list source [file join $dir vfsUtils.tcl]] set auto_index(::vfs::autoMountExtension) [list source [file join $dir vfsUtils.tcl]] set auto_index(::vfs::autoMountUrl) [list source [file join $dir vfsUtils.tcl]] set auto_index(::vfs::log) [list source [file join $dir vfsUtils.tcl]] diff --git a/library/vfsUrl.tcl b/library/vfsUrl.tcl new file mode 100644 index 0000000..2b22bcd --- /dev/null +++ b/library/vfsUrl.tcl @@ -0,0 +1,24 @@ + + +namespace eval ::vfs::url {} + +proc vfs::url::Mount {type} { + # This requires Tcl 8.4a4. + set volume "${type}://" + if {$type == "file"} { + append volume "/" + } + ::vfs::addVolume $volume + ::vfs::filesystem mount $volume [list vfs::url::handler $type] +} + +proc vfs::url::handler {type cmd root relative actualpath args} { + puts stderr [list $type $cmd $root $relative $actualpath $args] + error "" +} + +proc vfs::url::handler {args} { + puts stderr $args + error "" +} + diff --git a/library/vfsUtils.tcl b/library/vfsUtils.tcl index 829df59..48f6963 100644 --- a/library/vfsUtils.tcl +++ b/library/vfsUtils.tcl @@ -7,6 +7,30 @@ namespace eval ::vfs { if {[info exists env(VFS_DEBUG)]} { set debug $env(VFS_DEBUG) } + variable volumes "" +} + +# This procedure is called by Tcl when we are registered. +# The results of the procedure, as well as being listed +# in 'file volumes' affect whether files are treated as +# relative or absolute as well. +proc ::vfs::listVolumes {} { + variable volumes + return $volumes +} + +proc ::vfs::addVolume {vol} { + variable volumes + lappend volumes $vol +} + +proc ::vfs::removeVolume {vol} { + variable volumes + set idx [lsearch -exact $volumes $vol] + if {$idx == -1} { + return -code error "No such volume \"$vol\"" + } + set volumes [lreplace $volumes $idx $idx] } proc ::vfs::autoMountExtension {ext cmd {pkg ""}} { diff --git a/win/makefile.vc b/win/makefile.vc index 9c1cb7b..12fb8a0 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -13,7 +13,7 @@ VFS_VERSION = 1.0 DLL_VERSION = 10 # comment the following line to compile with symbols -NODEBUG=1 +NODEBUG=0 !IF "$(NODEBUG)" == "1" DEBUGDEFINES = -- 2.23.0