+2001-09-27 Vince Darley <vincentdarley@sourceforge.net>
+ * library/mk4vfs.tcl: Update from Jean-Claude Wippler
+ * library/vfsUtils.tcl:
+ * generic/vfs.c: Moved 'list volumes' functionality
+ entirely into C from Tcl (faster and easier for tclkit
+ to make proper use of). This required the addition
+ of a '-volume' flag to the mount/unmount commands, and
+ meant we can remove the 'mountschanged' subcommand.
+
2001-09-07 Vince Darley <vincentdarley@sourceforge.net>
* generic/vfs.c: Fixed '==' error
* doc/vfs.n: Improved docs.
.sp
\fBvfs::filesystem\fR \fIunmount\fR
.sp
-\fBvfs::filesystem\fR \fImountschanged\fR
-.sp
.sp
\fBvfs::foo \fIa b c\fR
.BE
vfs package will at that stage not have any new filesystems mounted, so
it will have little effect.
.TP
-\fBvfs::filesystem\fR \fImount\fR \fIpath\fR \fIcommand\fR
+\fBvfs::filesystem\fR \fImount\fR \fI?-volume?\fR \fIpath\fR \fIcommand\fR
To use a virtual filesystem, it must be 'mounted'. Mounting involves
declaring to the vfs package that any subdirectories of a given
\fIpath\fR in the filesystem should be handled by the given \fIcommand\fR
-which should be a Tcl command or procedure.
+which should be a Tcl command or procedure. If the \fI?-volume?\fR
+flag is given, the given mount point is also registered with Tcl as
+a new volume (like a new drive).
.TP
-\fBvfs::filesystem\fR \fIunmount\fR \fIpath\fR
+\fBvfs::filesystem\fR \fIunmount\fR \fI?-volume?\fR \fIpath\fR
This unmounts the virtual filesystem which was mounted at \fIpath\fR
hence removing it from Tcl's filesystem, or throws an error if no
-filesystem was mounted there.
+filesystem was mounted there. The \fI?-volume?\fR flag should be
+given if it was also given when the path was mounted.
.TP
\fBvfs::filesystem\fR \fIinfo\fR \fI?path?\fR
If no arguments are given, this returns a list of all filesystems
mounted. If a path argument is given, then the \fIcommand\fR to be
used for that path is returned, or an error is thrown if no vfs is
mounted for that path.
-.TP
-\fBvfs::filesystem\fR \fImountschanged\fR
-There is generally no need to call this. It is used by the library
-when the list of volumes changes, or when any kind of new mount point
-is added. It ensures that Tcl's cached file representations are not
-out of date.
.PP
Currently mount information is stored by the extension in the
vfs::mount array variable, but this should be considered private
EXTERN int Vfs_Init _ANSI_ARGS_((Tcl_Interp*));
+static void Vfs_AddVolume _ANSI_ARGS_((Tcl_Obj*));
+static int Vfs_RemoveVolume _ANSI_ARGS_((Tcl_Obj*));
+
+/*
+ * Stores the list of volumes registered with the vfs
+ * (and therefore also registered with Tcl). It is
+ * maintained as a valid Tcl list at all times, or
+ * NULL if there are none. To improve Tcl's efficiency,
+ * when there are no volumes, we keep this NULL rather
+ * than as an empty list.
+ */
+static Tcl_Obj *vfsVolumes = NULL;
+
/*
* Structure used for the native representation of a path in a Tcl vfs.
* To fully specify a file, the string representation is also required.
int index;
static char *optionStrings[] = {
- "info", "mount", "unmount", "volumeschanged",
+ "info", "mount", "unmount",
NULL
};
enum options {
- VFS_INFO, VFS_MOUNT, VFS_UNMOUNT, VFS_VOLUMESCHANGED,
+ VFS_INFO, VFS_MOUNT, VFS_UNMOUNT,
};
if (objc < 2) {
switch ((enum options) index) {
case VFS_MOUNT: {
Tcl_Obj * path;
+ int i;
Tcl_Interp* vfsInterp;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "mount path cmd");
+ if (objc < 4 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "mount ?-volume? path cmd");
return TCL_ERROR;
}
vfsInterp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem);
Tcl_SetResult(interp, "vfs not registered", TCL_STATIC);
return TCL_ERROR;
}
- path = Tcl_FSGetNormalizedPath(interp, objv[2]);
+ if (objc == 5) {
+ char *option = Tcl_GetString(objv[2]);
+ if (strcmp("-volume", option)) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad option \"", option,
+ "\": must be -volume", (char *) NULL);
+ return TCL_ERROR;
+ }
+ i = 3;
+ Vfs_AddVolume(objv[i]);
+ } else {
+ i = 2;
+ }
+ path = Tcl_FSGetNormalizedPath(interp, objv[i]);
if (Tcl_SetVar2Ex(vfsInterp, "vfs::mount",
- Tcl_GetString(path), objv[3],
+ Tcl_GetString(path), objv[i+1],
TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY) == NULL) {
return TCL_ERROR;
}
case VFS_UNMOUNT: {
Tcl_Obj * path;
Tcl_Interp* vfsInterp;
- int res;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "path");
+ int res, i;
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-volume? path");
return TCL_ERROR;
}
vfsInterp = (Tcl_Interp*) Tcl_FSData(&vfsFilesystem);
Tcl_SetResult(interp, "vfs not registered", TCL_STATIC);
return TCL_ERROR;
}
- path = Tcl_FSGetNormalizedPath(interp, objv[2]);
+ if (objc == 4) {
+ char *option = Tcl_GetString(objv[2]);
+ if (strcmp("-volume", option)) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad option \"", option,
+ "\": must be -volume", (char *) NULL);
+ return TCL_ERROR;
+ }
+ i = 3;
+ } else {
+ i = 2;
+ }
+ path = Tcl_FSGetNormalizedPath(interp, objv[i]);
res = Tcl_UnsetVar2(vfsInterp, "vfs::mount", Tcl_GetString(path),
TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
if (res == TCL_OK) {
+ if (i == 3) {
+ Vfs_RemoveVolume(objv[i]);
+ }
Tcl_FSMountsChanged(&vfsFilesystem);
}
return res;
}
- case VFS_VOLUMESCHANGED: {
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
- Tcl_FSMountsChanged(&vfsFilesystem);
- }
}
return TCL_OK;
}
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);
+ if (vfsVolumes == NULL) {
+ return NULL;
} else {
- resultPtr = NULL;
+ Tcl_IncrRefCount(vfsVolumes);
+ return vfsVolumes;
}
- Tcl_RestoreResult(interp, &savedResult);
- return resultPtr;
+}
+
+void
+Vfs_AddVolume(volume)
+ Tcl_Obj *volume;
+{
+ if (vfsVolumes == NULL) {
+ vfsVolumes = Tcl_NewObj();
+ Tcl_IncrRefCount(vfsVolumes);
+ }
+ Tcl_ListObjAppendElement(NULL, vfsVolumes, volume);
+}
+
+int
+Vfs_RemoveVolume(volume)
+ Tcl_Obj *volume;
+{
+ int i, len;
+ Tcl_ListObjLength(NULL, vfsVolumes, &len);
+ for (i = 0;i < len; i++) {
+ Tcl_Obj *vol;
+ Tcl_ListObjIndex(NULL, vfsVolumes, i, &vol);
+ if (!strcmp(Tcl_GetString(vol),Tcl_GetString(volume))) {
+ /* It's in the list, at index i */
+ if (len == 1) {
+ /* An optimization here */
+ Tcl_DecrRefCount(vfsVolumes);
+ vfsVolumes = NULL;
+ } else {
+ /* Make ourselves the unique owner */
+ if (Tcl_IsShared(vfsVolumes)) {
+ Tcl_Obj *oldVols = vfsVolumes;
+ vfsVolumes = Tcl_DuplicateObj(oldVols);
+ Tcl_DecrRefCount(oldVols);
+ }
+ /* Remove the element */
+ Tcl_ListObjReplace(NULL, vfsVolumes, i, 1, 0, NULL);
+ return TCL_OK;
+ }
+ }
+ }
+ return TCL_ERROR;
}
\f
void VfsExitProc(ClientData clientData)
{
Tcl_FSUnregister(&vfsFilesystem);
+ if (vfsVolumes != NULL) {
+ Tcl_DecrRefCount(vfsVolumes);
+ vfsVolumes = NULL;
+ }
}
switch -- $cmd {
seek {
- switch $args {
- 1 { incr arg1 $_pos }
- 2 { incr arg1 [string length $_buf]}
+ switch [lindex $args 1] {
+ 1 - current { incr arg1 $_pos }
+ 2 - end { incr arg1 [string length $_buf]}
}
return [set _pos $arg1]
}
return $db
}
-namespace eval mk4vfs {}
-
-proc mk4vfs::mount {args} {
- uplevel 1 [list ::vfs::mk4::mount] $args
-}
-
proc vfs::mk4::Unmount {db local} {
vfs::filesystem unmount $local
- ::mk4vfs::umount $db
+ ::mk4vfs::_umount $db
}
proc vfs::mk4::handler {db cmd root relative actualpath args} {
#::vfs::log [array get sb]
# for new vfs:
- set sb(dev) 0
set sb(ino) 0
array get sb
}
proc vfs::mk4::access {db name mode} {
#::vfs::log "mk4-access $name $mode"
# This needs implementing better.
- #tclLog "mk4vfs::driver $db access $name $mode"
switch -- $mode {
0 {
# exists
}
}
+proc mk4vfs::mount {args} {
+ uplevel ::vfs::mk4::Mount $args
+}
+
proc mk4vfs::_mount {path file args} {
variable uid
set db mk4vfs[incr uid]
mk::file commit $db
}
-proc mk4vfs::umount {db} {
- tclLog [list unmount $db]
+proc mk4vfs::umount {local} {
+ foreach {db path} [mk::file open] {
+ if {[string equal $local $path]} {
+ uplevel ::vfs::mk4::Unmount $db $local
+ return
+ }
+ }
+ tclLog "umount $local? [mk::file open]"
+}
+
+proc mk4vfs::_umount {db} {
+ after cancel [list mk4vfs::_commit $db]
+ variable cache
+ array unset cache $db.*
+ #tclLog [list unmount $db]
mk::file close $db
}
set sb(type) $type
set sb(view) $view
set sb(ino) $cur
- set sb(dev) [list mk4vfs::driver $db]
if { [string equal $type "directory"] } {
set sb(atime) 0
#}
}
-proc mk4vfs::driver {db option args} {
- #tclLog "mk4vfs::driver $db $option $args"
- switch -- $option {
- lstat {return [uplevel 1 [concat [list mk4vfs::stat $db] $args]]}
- chdir {return [lindex $args 0]}
- access {
- # This needs implementing better. The 'lindex $args 1' is
- # the access mode we should be checking.
- set mode [lindex $args 1]
- #tclLog "mk4vfs::driver $db access [lindex $args 0] $mode"
- switch -- $mode {
- 0 {
- # exists
- if {![catch {stat $db [lindex $args 0] sb}]} {
- return
- }
- }
- 1 {
- # executable
- if {![catch {stat $db [lindex $args 0] sb}]} {
- return
- }
- }
- 2 {
- # writable
- if {![catch {stat $db [lindex $args 0] sb}]} {
- return
- }
- }
- 4 {
- # readable
- if {![catch {stat $db [lindex $args 0] sb}]} {
- return
- }
- }
- }
- #tclLog "access bad"
- error "bad file"
- }
- removedirectory {
- return [uplevel 1 [concat [list mk4vfs::delete $db] $args]]
- }
- atime {
- # Not implemented
- }
- mtime -
- delete -
- stat -
- getdir -
- mkdir {return [uplevel 1 [concat [list mk4vfs::$option $db] $args]]}
-
- open {
- set file [lindex $args 0]
- set mode [lindex $args 1]
-
- switch -glob -- $mode {
- {} -
- r {
- stat $db $file sb
-
- if { $sb(csize) != $sb(size) } {
- package require Trf
- package require memchan
- #tclLog "$file: decompressing on read"
-
- set fd [memchan]
- fconfigure $fd -translation binary
- set s [mk::get $sb(ino) contents]
- puts -nonewline $fd [zip -mode decompress $s]
-
- fconfigure $fd -translation auto
- seek $fd 0
- return [list $fd [list _memchan_handler close $fd]]
- } elseif { $::mk4vfs::direct } {
- package require Trf
- package require memchan
-
- set fd [memchan]
- fconfigure $fd -translation binary
- puts -nonewline $fd [mk::get $sb(ino) contents]
-
- fconfigure $fd -translation auto
- seek $fd 0
- return [list $fd [list _memchan_handler close $fd]]
- } else {
- set fd [mk::channel $sb(ino) contents r]
- }
- return [list $fd]
- }
- a {
- if { [catch {stat $db $file sb }] } {
- #tclLog "stat failed - creating $file"
- # Create file
- stat $db [file dirname $file] sb
-
- set cur [mk::row append $sb(ino).files name [file tail $file] size 0 date [clock seconds] ]
- set sb(ino) $cur
-
- if { [string match *z* $mode] || ${mk4vfs::compress} } {
- set sb(csize) -1 ;# HACK - force compression
- } else {
- set sb(csize) 0
- }
- }
-
- if { $sb(csize) != $sb(size) } {
- package require Trf
- package require memchan
-
- #tclLog "$file: compressing on append"
- append mode z
- set fd [memchan]
-
- fconfigure $fd -translation binary
- set s [mk::get $sb(ino) contents]
- puts -nonewline $fd [zip -mode decompress $s]
- fconfigure $fd -translation auto
- } else {
- set fd [mk::channel $sb(ino) contents a]
- }
- return [list $fd [list mk4vfs::do_close $fd $mode $sb(ino)]]
- }
- w* {
- if { [catch {stat $db $file sb }] } {
- #tclLog "stat failed - creating $file"
- # Create file
- stat $db [file dirname $file] sb
- set cur [mk::row append $sb(ino).files name [file tail $file] size 0 date [clock seconds] ]
- set sb(ino) $cur
- }
- if { [string match *z* $mode] || ${mk4vfs::compress} } {
- package require Trf
- package require memchan
- #tclLog "$file: compressing on write"
- ###zip -attach $fd -mode compress
- append mode z
- set fd [memchan]
- } else {
- set fd [mk::channel $sb(ino) contents w]
- }
- return [list $fd [list mk4vfs::do_close $fd $mode $sb(ino)]]
- }
- default {
- error "illegal access mode \"$mode\""
- }
- }
- }
- sync {eval [list mk::file commit $db] [lrange $args 1 end]}
- umount {eval [list mk::file close $db] $args}
- default {
- return -code error "bad option \"$option\": must be one of chdir, delete, getdir, load, lstat, mkdir, open, stat, sync, or umount"
- }
- }
-}
-
proc mk4vfs::do_close {fd mode cur} {
# Set size to -1 before the seek - just in case it fails.
} err]} {
global errorInfo
tclLog "mk4vfs::do_close callback error: $err $errorInfo"
+###!!! return -code error $err
}
}
proc vfs::urltype::Mount {type} {
set mountPoint [_typeToMount $type]
- ::vfs::addVolume $mountPoint
- ::vfs::filesystem mount $mountPoint [list vfs::urltype::handler $type]
+ ::vfs::filesystem mount -volume $mountPoint [list vfs::urltype::handler $type]
return "Mounted at \"${mountPoint}\""
}
proc vfs::urltype::Unmount {type} {
set mountPoint [_typeToMount $type]
- ::vfs::filesystem unmount $mountPoint
- ::vfs::removeVolume $mountPoint
+ ::vfs::filesystem unmount -volume $mountPoint
}
proc vfs::urltype::_typeToMount {type} {
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 ""}} {
DLL_VERSION = 10
# comment the following line to compile with symbols
-NODEBUG=1
+NODEBUG=0
!IF "$(NODEBUG)" == "1"
DEBUGDEFINES =
projects / tclvfs / commitdiff