From: Vince Darley Date: Thu, 27 Sep 2001 18:56:34 +0000 (+0000) Subject: better file vols X-Git-Tag: vfs-1-2~105 X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=3a8964cd67c38d0c37460bae106a12df4f350e04;p=tclvfs better file vols --- diff --git a/ChangeLog b/ChangeLog index cea86cf..78b6f1c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2001-09-27 Vince Darley + * 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 * generic/vfs.c: Fixed '==' error * doc/vfs.n: Improved docs. diff --git a/doc/vfs.n b/doc/vfs.n index 3e13c6b..cc9629b 100644 --- a/doc/vfs.n +++ b/doc/vfs.n @@ -21,8 +21,6 @@ .sp \fBvfs::filesystem\fR \fIunmount\fR .sp -\fBvfs::filesystem\fR \fImountschanged\fR -.sp .sp \fBvfs::foo \fIa b c\fR .BE @@ -52,28 +50,25 @@ control over this could be exposed to Tcl in the future). However, the 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 diff --git a/generic/vfs.c b/generic/vfs.c index a5beb0f..67bf52c 100644 --- a/generic/vfs.c +++ b/generic/vfs.c @@ -32,6 +32,19 @@ 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. @@ -241,11 +254,11 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv) 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) { @@ -260,9 +273,10 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv) 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); @@ -270,9 +284,22 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv) 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; } @@ -310,9 +337,9 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv) 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); @@ -320,21 +347,29 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv) 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; } @@ -1107,22 +1142,54 @@ VfsUtime(pathPtr, tval) 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; } @@ -1192,5 +1259,9 @@ static void VfsExitProc(ClientData clientData) { Tcl_FSUnregister(&vfsFilesystem); + if (vfsVolumes != NULL) { + Tcl_DecrRefCount(vfsVolumes); + vfsVolumes = NULL; + } } diff --git a/library/mk4vfs.tcl b/library/mk4vfs.tcl index 4e3c698..2815cc0 100644 --- a/library/mk4vfs.tcl +++ b/library/mk4vfs.tcl @@ -56,9 +56,9 @@ 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] } @@ -112,15 +112,9 @@ proc vfs::mk4::Mount {what local args} { 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} { @@ -164,7 +158,6 @@ proc vfs::mk4::stat {db name} { #::vfs::log [array get sb] # for new vfs: - set sb(dev) 0 set sb(ino) 0 array get sb } @@ -172,7 +165,6 @@ proc vfs::mk4::stat {db name} { 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 @@ -362,6 +354,10 @@ proc mk4vfs::init {db} { } } +proc mk4vfs::mount {args} { + uplevel ::vfs::mk4::Mount $args +} + proc mk4vfs::_mount {path file args} { variable uid set db mk4vfs[incr uid] @@ -388,8 +384,21 @@ proc mk4vfs::_commit {db} { 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 } @@ -470,7 +479,6 @@ proc mk4vfs::stat {db path arr} { 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 @@ -502,161 +510,6 @@ proc mk4vfs::stat {db path arr} { #} } -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. @@ -692,6 +545,7 @@ proc mk4vfs::do_close {fd mode cur} { } err]} { global errorInfo tclLog "mk4vfs::do_close callback error: $err $errorInfo" +###!!! return -code error $err } } diff --git a/library/vfsUrl.tcl b/library/vfsUrl.tcl index c1c284c..3ce0455 100644 --- a/library/vfsUrl.tcl +++ b/library/vfsUrl.tcl @@ -18,15 +18,13 @@ namespace eval ::vfs::urltype {} 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} { diff --git a/library/vfsUtils.tcl b/library/vfsUtils.tcl index 48f6963..829df59 100644 --- a/library/vfsUtils.tcl +++ b/library/vfsUtils.tcl @@ -7,30 +7,6 @@ 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 964f190..7564a40 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 =