[PATCH] VFS portability improvements

Since they are not portable outside Unix systems, the `archive' virtual
filesystems (deb, lslR, mailfs, patchfs, uar, urar, uzoo, ulha, ucpio,
utar) are now available only if the VFSAddOns package is loaded.
Without the package, only #uzip is available and it will only support
extracting from ZIP files (i.e. you cannot write to them) using `unzip'.

This change prompted some refactoring to avoid duplicating code between
the new ZipFileHandler and ExternalArchiveFileHandler.  Generators
turned out to be real handy.

In addition, the scriptlets for VFS are installed under
/usr/libexec/smalltalk/ now.

Paolo


2007-07-03  Paolo Bonzini  <[hidden email]>

        * kernel/VFS.st: Move most of the code in ExternalArchiveFileHandler
        up to ArchiveFileHandler, modify ExternalArchiveFileHandler to be
        ZipFileHandler and adjusting it for the new ArchiveFileHandler protocol,
        add priorities to each class.
        * kernel/Directory.st: Add #libexec.

        * libgst/dict.c: Export LibexecPath.

        * packages/vfs/VFS.st: Move ExternalArchiveFileHandler here from
        kernel/VFS.st, complying to the new ArchiveFileHandler protocol.

* looking for [hidden email]--2004b/smalltalk--devo--2.2--patch-438 to compare with
* comparing to [hidden email]--2004b/smalltalk--devo--2.2--patch-438
A  packages/vfs/Makefile.am
A  packages/vfs/VFS.st
A  packages/vfs/package.xml
M  configure.ac
M  NEWS
M  kernel/Directory.st
M  kernel/VFS.st
M  libgst/Makefile.am
M  packages.xml
M  libgst/dict.c
M  packages/vfs/README
/> vfs packages/vfs

* modified files

--- orig/NEWS
+++ mod/NEWS
@@ -104,6 +104,11 @@ o   The image is now installed in /usr/l
 o   A pragma like "<category: 'bar'>" can be used to set the category
     of a method.
 
+o   Since they are not portable outside Unix systems, the `archive' virtual
+    filesystems (deb, lslR, mailfs, patchfs, uar, urar, uzoo, ulha, ucpio, utar)
+    are now available only if the VFSAddOns package is loaded.  Without the
+    package, only #uzip is available and it will only support extracting from
+    ZIP files.
 
 -----------------------------------------------------------------------------
 


--- orig/configure.ac
+++ mod/configure.ac
@@ -300,6 +300,7 @@ GST_PACKAGE([TCP], [tcp],
   [GST_INET_SOCKETS],
   [gst_cv_inet_sockets],
   [Makefile], [tcp.la])
+GST_PACKAGE([VFSAddOns], [vfs])
 GST_PACKAGE([XML], [xml])
 GST_PACKAGE([XPath], [xpath])
 GST_PACKAGE([XSL], [xsl])


--- orig/kernel/Directory.st
+++ mod/kernel/Directory.st
@@ -69,6 +69,11 @@ module
     ^ModulePath
 !
 
+libexec
+    "Answer the path to GNU Smalltalk's auxiliary executables"
+    ^LibexecPath
+!
+
 systemKernel
     "Answer the path to the GNU Smalltalk kernel's Smalltalk source files.
      Same as `Directory kernel' since GNU Smalltalk 2.4."


--- orig/kernel/VFS.st
+++ mod/kernel/VFS.st
@@ -71,7 +71,7 @@ virtual filesystems that take a file tha
 command on it, and then read from the result.'!
 
 RealFileHandler subclass: #ArchiveFileHandler
-       instanceVariableNames: 'handlers fsName'
+       instanceVariableNames: 'handlers fsName topLevelFiles allFiles extractedFiles'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Streams-Files'
@@ -88,21 +88,15 @@ resides entirely in ArchiveFileHandler b
 will still ask the archive to get directory information
 on them, to extract them to a real file, and so on.'!
 
-ArchiveFileHandler subclass: #ExternalArchiveFileHandler
-       instanceVariableNames: 'topLevelFiles allFiles extractedFiles'
+ArchiveFileHandler subclass: #ZipFileHandler
+       instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Streams-Files'
 !
 
-ExternalArchiveFileHandler class
- instanceVariableNames: 'fileTypes'!
-
-ExternalArchiveFileHandler comment: 'ExternalArchiveFileHandler
-allows for easy implementation of archive files (for example,
-transparent unzipping and untarring) with a single shell script.
-It implements a protocol that that is compatible with the Midnight
-Commander and with GNOME VFS.'!
+ZipFileHandler comment: 'ZipFileHandler transparently extracts
+files from a ZIP archive.'!
 
 VFSHandler subclass: #ArchiveMemberHandler
        instanceVariableNames: 'parent size stCtime stMtime stAtime isDirectory realFileName'
@@ -251,6 +245,11 @@ update: aspect
     ].
 !
 
+priority
+    "Answer the priority for this class (higher number = higher priority) in
+     case multiple classes implement the same file system.  The default is 0."
+    ^0!
+
 fileSystems
     "Answer the virtual file systems that can be processed by this subclass.
      The default is to answer an empty array, but subclasses can override
@@ -263,18 +262,26 @@ register: fileSystem forClass: vfsHandle
     "Register the given file system to be handled by an instance of
      vfsHandlerClass.  This is automatically called if the class overrides
      #fileSystems."
-    Registry at: fileSystem put: vfsHandlerClass! !
+    ((Registry includesKey: fileSystem) not
+ or: [ (Registry at: fileSystem) priority < vfsHandlerClass priority ])
+    ifTrue: [ Registry at: fileSystem put: vfsHandlerClass ]! !
 
 !VFSHandler class methodsFor: 'private'!
 
+register
+    Registry isNil ifTrue: [ VFSHandler registerAll ].
+    self fileSystems do: [ :fs | VFSHandler register: fs forClass: self ]!
+
+registerAll
+    "Register all file systems under the VFSHandler hierarchy."
+    Registry isNil ifTrue: [ Registry := LookupTable new ].
+    self allSubclassesDo: [ :each | each register ]!
+
 vfsFor: fileName name: fsName subPath: subPath
     "Create an instance of a subclass of the receiver, implementing the virtual
      file `subPath' inside the `fileName' archive.  fsName is the virtual
      filesystem name and is used to determine the subclass to be instantiated."
-    Registry isNil ifTrue: [
- Registry := LookupTable new.
- self allSubclassesDo: [ :each |
-    each fileSystems do: [ :fs | self register: fs forClass: each ] ] ].
+    Registry isNil ifTrue: [ self registerAll ].
     ^(Registry at: fsName)
  vfsFor: fileName name: fsName subPath: subPath!
 
@@ -652,6 +659,11 @@ do: aBlock
 
 !DecodedFileHandler class methodsFor: 'registering'!
 
+priority
+    "Answer the priority for this class (higher number = higher priority) in
+     case multiple classes implement the same file system."
+    ^-10!
+
 fileTypes
     "Return the valid virtual filesystems and the associated
      filter commands."
@@ -808,8 +820,7 @@ at: aName
 do: aBlock
     "Evaluate aBlock once for each file in the directory represented by the
     receiver, passing its name."
-
-    self subclassResponsibility!
+    topLevelFiles do: aBlock!
 
 release
     "Release the resources used by the receiver that don't survive when
@@ -818,6 +829,7 @@ release
     handlers isNil ifTrue: [ ^self ].
     handlers do: [ :each | each release ].
     handlers := nil.
+    extractedFiles := nil.
     super release! !
 
 
@@ -826,108 +838,20 @@ release
 extractMember: anArchiveMemberHandler
     "Extract the contents of anArchiveMemberHandler into a file
      that resides on disk, and answer the name of the file."
-    self subclassResponsibility!
-
-fillMember: anArchiveMemberHandler
-    "Extract the information on anArchiveMemberHandler.  Answer
-     false if it actually does not exist in the archive; otherwise,
-     answer true after having told anArchiveMemberHandler about them
-     by sending #size:stCtime:stMtime:stAtime:isDirectory: to it."
-
-    self subclassResponsibility!
-
-member: anArchiveMemberHandler do: aBlock
-    "Evaluate aBlock once for each file in the directory represented by
-    anArchiveMemberHandler, passing its name."
-
-    self subclassResponsibility!
-
-removeMember: anArchiveMemberHandler
-    "Remove the member represented by anArchiveMemberHandler."
-
-    self subclassResponsibility!
-
-updateMember: anArchiveMemberHandler
-    "Update the member represented by anArchiveMemberHandler by
-     copying the file into which it was extracted back to the
-     archive."
-
-    self subclassResponsibility! !
-
-!ArchiveFileHandler methodsFor: 'private'!
-
-name: containerFileName fsName: aString
-    super name: containerFileName.
-    fsName := aString! !
-
-!ExternalArchiveFileHandler class methodsFor: 'registering'!
-
-fileSystems
-    "Answer the virtual file systems that can be processed by this subclass.
-     These are given by the names of the executable files in the `vfs'
-     subdirectory of the image directory, of the parent of the kernel
-     directory and (if the image is not the global installed image)
-     of the `.st' directory in the home directory."
-    fileTypes := LookupTable new.
-    [ self fileSystemsIn: Directory kernel, '/../vfs' ]
- on: Error do: [ :ex | ex return ].
-    [ self fileSystemsIn: Directory userBase, '/vfs' ]
- on: Error do: [ :ex | ex return ].
-    Smalltalk imageLocal ifTrue: [
-        [ self fileSystemsIn: Directory image, '/vfs' ]
-    on: Error do: [ :ex | ex return ] ].
-
-    ^fileTypes keys asSet!
-
-fileSystemsIn: path
-    "Registers the executable files in the given directory to be used
-     to resolve a virtual file system."
-    | dir |
-    dir := RealFileHandler for: path.
-    dir exists ifFalse: [ ^self ].
-    dir do: [ :each |
- (File isExecutable: path, '/', each)
-    ifTrue: [ fileTypes at: each put: path, '/', each ]
-    ]!
-
-fileTypes
-    ^fileTypes!
-
-release
-    "Avoid that paths stay in the image file"
-    fileTypes := nil.
-    super release! !
-
-!ExternalArchiveFileHandler methodsFor: 'members'!
-
-createDir: dirName
-    "Create a subdirectory of the receiver, naming it dirName."
-
-    Smalltalk system: ('%1 mkdir %2 %3' % { self command. self realFileName. dirName })!
-
-do: aBlock
-    "Evaluate aBlock once for each file in the directory represented by the
-    receiver, passing its name."
-    topLevelFiles do: aBlock!
-
-
-!ExternalArchiveFileHandler methodsFor: 'ArchiveMemberHandler protocol'!
-
-extractMember: anArchiveMemberHandler
-    "Extract the contents of anArchiveMemberHandler into a file
-     that resides on disk, and answer the name of the file."
 
     extractedFiles isNil ifTrue: [
  extractedFiles := IdentityDictionary new ].
 
     ^extractedFiles at: anArchiveMemberHandler ifAbsentPut: [
- | temp |
+        | temp |
         temp := FileStream openTemporaryFile: Directory temporary, '/vfs'.
-        Smalltalk system: ('%1 copyout %2 %3 %4'
-    % { self command. self realFileName. anArchiveMemberHandler name. temp name }).
+ self extractMember: anArchiveMemberHandler into: temp.
+        File fullNameFor: temp name ]!
 
-        File fullNameFor: temp name
-    ]!
+extractMember: anArchiveMemberHandler into: file
+    "Extract the contents of anArchiveMemberHandler into a file
+     that resides on disk, and answer the name of the file."
+    self subclassResponsibility!
 
 fillMember: anArchiveMemberHandler
     "Extract the information on anArchiveMemberHandler.  Answer
@@ -963,30 +887,6 @@ member: anArchiveMemberHandler do: aBloc
 
     (data at: 3) do: aBlock!
 
-removeMember: anArchiveMemberHandler
-    "Remove the member represented by anArchiveMemberHandler."
-
-    | subcmd |
-    subcmd := anArchiveMemberHandler isDirectory
- ifTrue: [ 'rmdir' ]
- ifFalse: [ 'rm' ].
-
-    Smalltalk system: ('%1 %2 %3 %4'
- % { self command. subcmd. self realFileName. anArchiveMemberHandler name. })!
-
-updateMember: anArchiveMemberHandler
-    "Update the member represented by anArchiveMemberHandler by
-     copying the file into which it was extracted back to the
-     archive."
-
-    Smalltalk system: ('%1 copyin %2 %3 %4'
- % { self command. self realFileName. anArchiveMemberHandler name.
-    anArchiveMemberHandler realFileName })!
-
-command
-    ^self class fileTypes at: fsName
-!
-
 refresh
     "Extract the directory listing from the archive"
 
@@ -997,28 +897,13 @@ refresh
     current := currentPath := nil.
     allFiles := LookupTable new.
     directoryTree := LookupTable new.
-    pipe := FileStream
- popen: self command, ' list ', self realFileName
- dir: FileStream read.
-    pipe linesDo: [ :l || line |
- line := l readStream.
- isDir := line next = $d.
- line skipTo: Character space.   "Attributes"
- line skipSeparators.
- line skipTo: Character space.   "Number of links"
- line skipSeparators.
- line skipTo: Character space.   "Owner"
- line skipSeparators.
- line skipTo: Character space.   "Group"
- line skipSeparators.
- size := Number readFrom: line. "File size"
- line skipSeparators.
- date := DateTime readFrom: line. "Date"
- line skipSeparators.
- path := line upToAll: ' -> '. "Path"
+    self files do: [ :data || path size date |
+ path := data at: 1.
+ size := data at: 2.
+ date := data at: 3.
+ isDir := data at: 4.
 
- path last = $/
-    ifTrue: [ path := path copyFrom: 1 to: path size - 1 ].
+ path last = $/ ifTrue: [ path := path copyFrom: 1 to: path size - 1 ].
 
  "Look up the tree for the directory in which the file resides.
          We keep a simple 1-element cache."
@@ -1037,8 +922,7 @@ refresh
     ifTrue: [ current at: name put: LookupTable new ]
     ifFalse: [ current at: name put: nil ].
 
- allFiles at: path put: { size. date. directory }.
-    ].
+ allFiles at: path put: { size. date. directory } ].
 
     "Leave the LookupTables to be garbage collected, we are now interested
      in the file names only."
@@ -1047,13 +931,21 @@ refresh
  (data at: 3) isNil ifFalse: [
     data at: 3 put: (data at: 3) keys asArray
  ]
-    ].
+    ]!
 
-    pipe close
-! !
+removeMember: anArchiveMemberHandler
+    "Remove the member represented by anArchiveMemberHandler."
 
-
-!ExternalArchiveFileHandler methodsFor: 'private'!
+    self subclassResponsibility!
+
+updateMember: anArchiveMemberHandler
+    "Update the member represented by anArchiveMemberHandler by
+     copying the file into which it was extracted back to the
+     archive."
+
+    self subclassResponsibility! !
+
+!ArchiveFileHandler methodsFor: 'private'!
 
 findDirectory: path into: tree
     "Look up into tree (which is a tree of Dictionaries) the directory
@@ -1084,17 +976,70 @@ findDirectory: path into: tree
     last := i + 1
  ]
     ].
-    ^current! !
+    ^current!
+
+name: containerFileName fsName: aString
+    super name: containerFileName.
+    fsName := aString! !
 
 
-!ExternalArchiveFileHandler methodsFor: 'releasing'!
+!ZipFileHandler class methodsFor: 'registering'!
 
-release
-    "Release the resources used by the receiver that don't survive when
-     reloading a snapshot."
+priority
+    "Answer the priority for this class (higher number = higher priority) in
+     case multiple classes implement the same file system."
+    ^-10!
 
-    extractedFiles := nil.
-    super release! !
+fileSystems
+    "Answer the virtual file systems that can be processed by this subclass."
+    ^#('uzip')! !
+
+!ZipFileHandler methodsFor: 'members'!
+
+createDir: dirName
+    "Create a subdirectory of the receiver, naming it dirName."
+
+    self notYetImplemented!
+
+extractMember: anArchiveMemberHandler into: temp
+    "Extract the contents of anArchiveMemberHandler into a file
+     that resides on disk, and answer the name of the file."
+    Smalltalk system: ('unzip -p %1 %2 > %3'
+ % { self realFileName. anArchiveMemberHandler name. temp name })!
+
+removeMember: anArchiveMemberHandler
+    "Remove the member represented by anArchiveMemberHandler."
+
+    Smalltalk system: ('zip -d %1 %2'
+ % { self realFileName. anArchiveMemberHandler name. })!
+
+updateMember: anArchiveMemberHandler
+    "Update the member represented by anArchiveMemberHandler by
+     copying the file into which it was extracted back to the
+     archive."
+
+    self notYetImplemented!
+
+files
+    "Extract the directory listing from the archive"
+
+    ^Generator on: [ :gen || pipe |
+ pipe := FileStream
+    popen: 'unzip -Z ', self realFileName
+    dir: FileStream read.
+
+        pipe linesDo: [ :l || result isDir size path date |
+    "Extract first character, fourth field, seventh+eighth field, rest of line."
+    result := l searchRegex:
+ '^(.)\S+\s+\S+\s+\S+\s+(\d+)\s+\S+\s+\S+\s+(\S+\s+\S+)\s(.*?)(?: -> |$)'.
+    result matched ifTrue: [
+        isDir := (result at: 1) = $d.
+        size := (result at: 2) asInteger.
+        date := DateTime readFrom: (result at: 3) readStream.
+        path := result at: 4.
+        gen yield: { path. size. date. isDir } ] ].
+
+ pipe close ]! !
 
 
 !ArchiveMemberHandler methodsFor: 'initializing'!


--- orig/libgst/Makefile.am
+++ mod/libgst/Makefile.am
@@ -6,6 +6,7 @@ AM_LFLAGS = -Cfe -o$(LEX_OUTPUT_ROOT).c
 AM_YFLAGS = -vy
 AM_CPPFLAGS = -DKERNEL_PATH=\"$(pkgdatadir)/kernel\" \
   -DIMAGE_PATH=\"$(imagedir)\" -DMODULE_PATH=\"$(pkglibdir)\" \
+  -DLIBEXEC_PATH=\"$(libexecdir)/$(PACKAGE)\" \
   -I$(top_srcdir)/lib-src -I$(top_srcdir)/libffi/include \
   -I$(top_builddir)/libffi/include $(INCLIGHTNING) \
   @INCSNPRINTFV@ $(INCSIGSEGV) -I$(top_builddir)/lib-src


--- orig/libgst/dict.c
+++ mod/libgst/dict.c
@@ -1056,6 +1056,7 @@ init_runtime_objects (void)
 {
   add_smalltalk ("UserFileBasePath", _gst_string_new (_gst_user_file_base_path));
   add_smalltalk ("ModulePath", _gst_string_new (MODULE_PATH));
+  add_smalltalk ("LibexecPath", _gst_string_new (LIBEXEC_PATH));
   add_smalltalk ("ImageFilePath",
  _gst_string_new (_gst_image_file_path));
   add_smalltalk ("ImageFileName",


--- orig/packages.xml
+++ mod/packages.xml
@@ -218,19 +218,6 @@
   <file>Getopt.st</file>
   <file>Regex.st</file>
   <file>StreamOps.st</file>
-
-  <file>../vfs/README</file>
-  <file>../vfs/deb</file>
-  <file>../vfs/lslR</file>
-  <file>../vfs/mailfs</file>
-  <file>../vfs/patchfs</file>
-  <file>../vfs/uar</file>
-  <file>../vfs/urar</file>
-  <file>../vfs/uzip</file>
-  <file>../vfs/uzoo</file>
-  <file>../vfs/ulha</file>
-  <file>../vfs/ucpio</file>
-  <file>../vfs/utar</file>
 </disabled-package>
 
 <disabled-package>


--- orig/vfs/README
+++ mod/packages/vfs/README
@@ -4,13 +4,12 @@
 Starting with version 1.96.5, GNU Smalltalk includes the Midnight
 Commander's virtual filesystem layer.  One of the virtual filesystems,
 implemented by the ExternalArchiveFileHandler class, makes it possible
-to create new virtual filesystems for GNU Smalltalk very easily (this
-was not implemented until 2.0c, however).
+to create new virtual filesystems for GNU Smalltalk very easily.
 
 This is achieved simply by creating a shell script/program to handle
-requests.  (Note: $(sharedir) should be substituted for actual
+requests.  (Note: $(libexecdir) should be substituted for actual
 sharedir path stored when configured or compiled, like
-/usr/local/share/smalltalk or /usr/share/smalltalk).
+/usr/local/libexec or /usr/libexec).
 
 The script must be called with the vfs suffix you give to your
 filesystem. For example, if you have .zip file, and would like to see
@@ -24,8 +23,8 @@ U. Note that sometime in future filesyst
 take whole tree and create .zip file from it. So /usr#zip will be
 zipfile containing whole /usr tree.
 
-You then have to create a program (with executable permissions) prefix
-in $(sharedir)/extfs (in our example $(sharedir)/extfs/uzip).
+You then have to create a program (with executable permissions) prefix in
+$(libexecdir)/smalltalk/vfs (in our example $(libexecdir)/smalltalk/vfs/uzip).
 
 * Commands that should be implemented by your shell script
 ----------------------------------------------------------
@@ -33,7 +32,7 @@ in $(sharedir)/extfs (in our example $(s
 Return zero from your script upon completion of the command, otherwise
 nonzero for failure or in case of an unsupported command.
 
-$libdir/extfs/prefix command [arguments]
+$(libexecdir)/smalltalk/vfs/prefix command [arguments]
 
 * Command: list archivename
 
@@ -99,8 +98,7 @@ This should create a new directory calle
 
 * Command: rmdir archivename dirname
 
-This should remove an existing directory dirname. If the directory is
-not empty, mc will recursively delete it (possibly prompting).
+This should remove an existing directory dirname.
 
 ---------------------------------------------------------
 
@@ -113,5 +111,5 @@ similar to yours.
 
 In constructing these routines, errors will be made.  Since this
 routine is an executable shell script it can be run from the command
-line independently of mc, and its output will show on the console or
+line independently of gst, and its output will show on the console or
 can be redirected to a file.



* added files

--- /dev/null
+++ mod/packages/vfs/Makefile.am
@@ -0,0 +1,6 @@
+EXTRA_DIST = README
+pkglibexecdir = $(libexecdir)/$(PACKAGE)
+dist_pkglibexec_SCRIPTS = deb lslR mailfs patchfs uar \
+  urar uzoo ulha ucpio utar
+
+
--- /dev/null
+++ mod/packages/vfs/VFS.st
@@ -0,0 +1,157 @@
+"======================================================================
+|
+|   Virtual File System extfs-compatible handler
+|
+|
+ ======================================================================"
+
+
+"======================================================================
+|
+| Copyright 2007 Free Software Foundation, Inc.
+| Written by Paolo Bonzini.
+|
+| This file is part of the GNU Smalltalk class library.
+|
+| The GNU Smalltalk class library is free software; you can redistribute it
+| and/or modify it under the terms of the GNU Lesser General Public License
+| as published by the Free Software Foundation; either version 2.1, or (at
+| your option) any later version.
+|
+| The GNU Smalltalk class library is distributed in the hope that it will be
+| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
+| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
+| General Public License for more details.
+|
+| You should have received a copy of the GNU Lesser General Public License
+| along with the GNU Smalltalk class library; see the file COPYING.LIB.
+| If not, write to the Free Software Foundation, 59 Temple Place - Suite
+| 330, Boston, MA 02110-1301, USA.  
+|
+ ======================================================================"
+
+ArchiveFileHandler subclass: #ExternalArchiveFileHandler
+       instanceVariableNames: ''
+       classVariableNames: ''
+       poolDictionaries: ''
+       category: 'Streams-Files'
+!
+
+ExternalArchiveFileHandler class
+ instanceVariableNames: 'fileTypes'!
+
+ExternalArchiveFileHandler comment: 'ExternalArchiveFileHandler
+allows for easy implementation of archive files (for example,
+transparent unzipping and untarring) with a single shell script.
+It implements a protocol that that is compatible with the Midnight
+Commander and with GNOME VFS.'!
+
+!ExternalArchiveFileHandler class methodsFor: 'registering'!
+
+priority
+    ^-5!
+
+fileSystems
+    "Answer the virtual file systems that can be processed by this subclass.
+     These are given by the names of the executable files in the `vfs'
+     subdirectory of the image directory, of the parent of the kernel
+     directory and (if the image is not the global installed image)
+     of the `.st' directory in the home directory."
+    fileTypes := LookupTable new.
+    [ self fileSystemsIn: Directory libexec, '/vfs' ]
+ on: Error do: [ :ex | ex return ].
+    [ self fileSystemsIn: Directory userBase, '/vfs' ]
+ on: Error do: [ :ex | ex return ].
+    Smalltalk imageLocal ifTrue: [
+        [ self fileSystemsIn: Directory image, '/vfs' ]
+    on: Error do: [ :ex | ex return ] ].
+
+    ^fileTypes keys asSet!
+
+fileSystemsIn: path
+    "Registers the executable files in the given directory to be used
+     to resolve a virtual file system."
+    | dir |
+    dir := RealFileHandler for: path.
+    dir exists ifFalse: [ ^self ].
+    dir do: [ :each |
+ (File isExecutable: path, '/', each)
+    ifTrue: [ fileTypes at: each put: path, '/', each ]
+    ]!
+
+fileTypes
+    ^fileTypes!
+
+release
+    "Avoid that paths stay in the image file"
+    fileTypes := nil.
+    super release! !
+
+!ExternalArchiveFileHandler methodsFor: 'members'!
+
+createDir: dirName
+    "Create a subdirectory of the receiver, naming it dirName."
+
+    Smalltalk system: ('%1 mkdir %2 %3' % { self command. self realFileName. dirName })! !
+
+
+!ExternalArchiveFileHandler methodsFor: 'ArchiveMemberHandler protocol'!
+
+extractMember: anArchiveMemberHandler into: file
+    "Extract the contents of anArchiveMemberHandler into a file
+     that resides on disk, and answer the name of the file."
+
+    Smalltalk system: ('%1 copyout %2 %3 %4'
+ % { self command. self realFileName. anArchiveMemberHandler name. file name })!
+
+removeMember: anArchiveMemberHandler
+    "Remove the member represented by anArchiveMemberHandler."
+
+    | subcmd |
+    subcmd := anArchiveMemberHandler isDirectory
+ ifTrue: [ 'rmdir' ]
+ ifFalse: [ 'rm' ].
+
+    Smalltalk system: ('%1 %2 %3 %4'
+ % { self command. subcmd. self realFileName. anArchiveMemberHandler name. })!
+
+updateMember: anArchiveMemberHandler
+    "Update the member represented by anArchiveMemberHandler by
+     copying the file into which it was extracted back to the
+     archive."
+
+    Smalltalk system: ('%1 copyin %2 %3 %4'
+ % { self command. self realFileName. anArchiveMemberHandler name.
+    anArchiveMemberHandler realFileName })!
+
+command
+    "Return the script that is invoked by the receiver."
+    ^self class fileTypes at: self fsName!
+
+files
+    "Extract the directory listing from the archive"
+
+    ^Generator on: [ :gen || pipe |
+        pipe := FileStream
+    popen: self command, ' list ', self realFileName
+    dir: FileStream read.
+
+        pipe linesDo: [ :l || line isDir size path date |
+    line := l readStream.
+    isDir := line next = $d.
+    "Attributes, number of links, owner, group"
+    4 timesRepeat: [
+ line skipTo: Character space.
+        line skipSeparators ].
+
+    size := Number readFrom: line. "File size"
+    line skipSeparators.
+    date := DateTime readFrom: line. "Date"
+    line skipSeparators.
+    path := line upToAll: ' -> '. "Path"
+
+            gen yield: { path. size. date. isDir } ].
+
+        pipe close ]! !
+
+ExternalArchiveFileHandler register!
--- /dev/null
+++ mod/packages/vfs/package.xml
@@ -0,0 +1,7 @@
+<package>
+  <name>VFSAddOns</name>
+  <namespace>VFS</namespace>
+
+  <filein>VFS.st</filein>
+  <file>VFS.st</file>
+</package>


_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk