[PATCH] design pattern fest continues... command pattern in scripts/Packages.st

Here it is.  now that the code works, I can refactor it.

Paolo

--- orig/scripts/Package.st
+++ mod/scripts/Package.st
@@ -29,6 +29,24 @@
  ======================================================================"
 
 
+Package extend [
+    isStarPackageBody [
+ ^'*.star#uzip' match: self baseDirectories first
+    ]
+
+    starFileName [
+ | dir |
+ self isStarPackageBody ifFalse: [ self halt ].
+ dir := self baseDirectories first.
+ ^dir copyFrom: 1 to: dir size - 5 ]
+
+    runCommand: aCommand [
+ self isStarPackageBody
+    ifTrue: [ aCommand runOnStar: self ]
+    ifFalse: [ aCommand runOnPackage: self ]
+    ]
+]
+
 Kernel.PackageDirectory subclass: PackageFile [
     refreshStarList []
 
@@ -49,9 +67,15 @@ Kernel.PackageDirectories subclass: Pack
 
     addFile: fileName [
  | packageFile |
- packageFile := PackageFile
-    on: fileName
-    baseDirectories: (self baseDirsFor: fileName).
+ packageFile := ('*.star' match: fileName)
+    ifFalse: [
+ PackageFile
+    on: fileName
+    baseDirectories: (self baseDirsFor: fileName) ]
+    ifTrue: [
+ PackageFile
+    on: fileName, '#uzip/package.xml'
+    baseDirectories: fileName, '#uzip' ].
 
  packageFile refresh.
  self add: packageFile.
@@ -80,7 +104,7 @@ File extend [
     emitSymlink: dest [
  self isDirectory ifTrue: [ ^(Directory name: dest) emitMkdir ].
 
- ('cp -pf %1 %2'
+ ('$LN_S -f %1 %2'
  bindWith: self
  with: (File name: dest)) displayNl
     ]
@@ -101,12 +125,149 @@ Directory extend [
     ]
 ]
 
-| installDir mode listFiles destdir files packageFiles helpString |
+Object subclass: Command [
+    | packages installDir |
+
+    validateDestDir: destdir installDir: instDir [
+ instDir isNil ifTrue: [ ^self ].
+ ((Directory name: instDir) name ~= instDir
+    and: [ destdir notEmpty ]) ifTrue: [
+ self error: '--destdir used with relative target directory' ]
+    ]
+
+    destDir: destdir installDir: instDir [
+ self validateDestDir: destdir installDir: installDir.
+ instDir isNil
+    ifTrue: [ installDir := destdir, self defaultInstallDir ]
+    ifFalse: [ installDir := destdir, instDir ]
+    ]
+
+    defaultInstallDir [ ^Directory image ]
+    installDir [ ^installDir ]
+
+    packages [
+ packages isNil ifTrue: [ packages := PackageFiles new ].
+ ^packages
+    ]
+
+    srcdir: aString [ self packages srcdir: aString ]
+    addAllFiles: aCollection [ self packages addAllFiles: aCollection ]
+
+    run [ self packages do: [ :pkg | pkg runCommand: self ] ]
+    runOnStar: self [ self runOnPackage: self ]
+    runOnPackage: self [ ]
+
+    listFiles: listFiles [
+        listFiles do: [ :each || package |
+    package := self packages at: each.
+    package allFiles do: [ :file |
+ (package findPathFor: file) displayNl ] ]
+    ]
+]
+
+Command subclass: PkgDist [
+    validateDestDir: destdir installDir: installDir [
+ destdir isEmpty ifTrue: [
+    self error: 'using --dist without specifying --distdir' ].
+    ]
 
-mode := #install.
+    defaultInstallDir [ ^'' ]
+    runOnPackage: aPackage [
+ | dirs files baseDir |
+ files := aPackage files.
+        dirs := files collect: [ :file |
+    Directory append: (File pathFor: file) to: aPackage relativeDirectory ].
+
+        dirs asSet asSortedCollection do: [ :dir || destName |
+    destName := Directory append: dir to: self installDir.
+    (Directory name: destName) emitMkdir ].
+
+ baseDir := Directory append: aPackage relativeDirectory to: self installDir.
+        files do: [ :file || srcFile destName |
+    srcFile := File name: (aPackage findPathFor: file).
+    destName := Directory append: file to: baseDir.
+    srcFile emitSymlink: destName ]
+    ]
+]
+
+Command subclass: PkgInstall [
+    run [
+        | destFile mergeResult |
+        "Create the installation directory.  Then, if we are installing, add
+         packages.xml to the list and merge the supplied packages files with it.
+         This is temporary, as installation will create .star packages later on."
+        (Directory name: self installDir) emitMkdir.
+
+        "This is also temporary.  To merge the packages.xml file, we need to
+         really create the file.  This screws up --dry-run but, again, it's
+         temporary.  For distribution it is not necessary, because the distdir
+ should have already been created."
+        ((Directory name: self installDir) name subStrings: $/)
+    inject: (Directory name: '/')
+    into: [ :old :each || dir |
+        dir := old directoryAt: each.
+        dir exists ifFalse: [ dir := Directory create: dir name ].
+        dir ].
+
+ "Do merge the package files.  So far we did this in install mode only,
+ but it actually makes more sense to do it in distribution mode."
+        destFile := File name: self installDir, '/packages.xml'.
+ mergeResult := packages copy.
+        destFile exists ifTrue: [
+    "In this case, we can pass problematic packages through."
+    [ mergeResult addFile: destFile name ]
+ on: Kernel.PackageNotAvailable
+ do: [ :ex | ex resume ] ].
+
+        destFile withWriteStreamDo: [ :s | mergeResult printOn: s ].
+ super run
+    ]
+
+    runOnPackage: aPackage [
+ "Right now this is almost a copy of PkgDist>>#runOnPackage:, but
+ this will change when this will create a .star file."
+ | dirs files baseDir |
+ files := aPackage allFiles.
+        dirs := files collect: [ :file |
+    Directory append: (File pathFor: file) to: aPackage relativeDirectory ].
+
+        dirs asSet asSortedCollection do: [ :dir || destName |
+    destName := Directory append: dir to: self installDir.
+    (Directory name: destName) emitMkdir ].
+
+ baseDir := Directory append: aPackage relativeDirectory to: self installDir.
+        files do: [ :file || srcFile destName |
+    srcFile := File name: (aPackage findPathFor: file).
+    destName := Directory append: file to: baseDir.
+    srcFile emitInstall: destName ]
+    ]
+]
+
+Command subclass: PkgUninstall [
+    runOnPackage: aPackage [
+ | baseDir |
+ baseDir := Directory append: aPackage relativeDirectory to: self installDir.
+ aPackage allFiles do: [ :file || destName |
+    destName := (Directory append: file to: baseDir).
+    (File name: destName) emitRemove ]
+    ]
+]
+
+Command subclass: PkgList [
+    validateDestDir: destdir installDir: installDir [ ]
+]
+
+PkgList subclass: PkgPackageList [
+    runOnPackage: aPackage [ aPackage name displayNl ]
+]
+
+| srcdir installDir mode listFiles destdir packageFiles helpString |
+
+mode := PkgInstall.
 listFiles := OrderedCollection new.
-installDir := Directory image.
+installDir := nil.
 destdir := ''.
+srcdir := nil.
 packageFiles := OrderedCollection new.
 packages := PackageFiles new.
 
@@ -116,7 +277,7 @@ helpString :=
 
     -n, --dry-run               print commands rather than running them
  --test                  run unit tests after merging
- --no-load               don''t load the Smalltalk files in the image
+ --load                  also load the Smalltalk files in the image
         --uninstall             remove the packages mentioned in the FILES
         --dist                  create symbolic links of non-built files
         --list-files PKG        just output the list of files in the package
@@ -137,9 +298,11 @@ The default target directory is $install
 
 [
     Smalltalk
-        "--no-load, --image-file, --dry-run are processed by gst-package."
-        arguments: '-h|--help --no-load --uninstall --dist
-            -t|--target-directory: --list-files: --list-packages
+        "--load, --image-file, --dry-run are processed by gst-package.
+ --no-load present for backwards compatibility, it is now the default.
+ --no-install is also present for backwards compatibility."
+        arguments: '-h|--help --no-load --load --no-install --uninstall
+            --dist -t|--target-directory: --list-files: --list-packages
             --srcdir: --distdir|--destdir: -n|--dry-run -I|--image-file:'
 
         do: [ :opt :arg |
@@ -147,102 +310,28 @@ The default target directory is $install
                 helpString displayOn: stderr.
                 ObjectMemory quit: 0 ].
 
-            opt = 'uninstall' ifTrue: [ mode := #uninstall ].
-            opt = 'dist' ifTrue: [ mode := #dist ].
+            opt = 'uninstall' ifTrue: [ mode := PkgUninstall ].
+            opt = 'dist' ifTrue: [ mode := PkgDist ].
+            opt = 'list-packages' ifTrue: [ mode := PkgPackageList ].
+
             opt = 'target-directory' ifTrue: [ installDir := arg ].
-            opt = 'list-files' ifTrue: [ listFiles add: arg ].
-            opt = 'list-packages' ifTrue: [ mode := #list ].
-            opt = 'srcdir' ifTrue: [ packages srcdir: arg ].
+            opt = 'no-install' ifTrue: [ mode := Command ].
+            opt = 'list-files' ifTrue: [ mode := PkgList. listFiles add: arg ].
+            opt = 'srcdir' ifTrue: [ srcdir := arg ].
             opt = 'destdir' ifTrue: [ destdir := arg ].
 
             opt isNil ifTrue: [ packageFiles add: arg ] ].
 
     "Validate the installation and source directory."
-    mode = #dist
-        ifTrue: [
-    destdir isEmpty ifTrue: [
-        self error: 'using --dist without specifying --distdir' ].
-    installDir := '' ]
-        ifFalse: [
-    ((Directory name: installDir) name ~= installDir
-        and: [ destdir notEmpty ]) ifTrue: [
-    self error: '--destdir used with relative target directory' ] ].
-
-    packages addAllFiles: packageFiles.
-
-    "Process --uninstall, --list-packages, --list-files now, then exit."
-    mode = #uninstall ifTrue: [
-        packages do: [ :each || baseDir |
-    baseDir := Directory append: each relativeDirectory to: installDir.
-    each allFiles do: [ :file || destName |
-        destName := destdir, (Directory append: file to: baseDir).
-        (File name: destName) emitRemove ] ].
-
-        ObjectMemory quit ].
-
-    mode = #list ifTrue: [
-        packages do: [ :each | each name displayNl ].
-        ObjectMemory quit ].
-
-    listFiles isEmpty ifFalse: [
-        listFiles do: [ :each || package |
-    package := packages at: each.
-    package allFiles do: [ :file |
- (package findPathFor: file) displayNl ] ].
-        ObjectMemory quit ].
-
-
-    "Create the installation directory.  Then, if we are installing, add
-     packages.xml to the list and merge the supplied packages files with it.
-     This is temporary, as installation will create .star packages later on."
-
-    installDir := destdir, installDir.
-    (Directory name: installDir) emitMkdir.
-
-    "This is also temporary.  To merge the packages.xml file, we need to
-     really create the file.  This screws up --dry-run but, again, it's
-     temporary."
-    ((Directory name: installDir) name subStrings: $/)
- inject: (Directory name: '/')
- into: [ :old :each || dir |
-    dir := old directoryAt: each.
-    dir exists ifFalse: [ dir := Directory create: dir name ].
-    dir ].
-
-    mode = #dist ifFalse: [
-        | destFile mergeResult |
-        destFile := File name: installDir, '/packages.xml'.
- mergeResult := packages copy.
-        destFile exists ifTrue: [
-    "In this case, we can pass problematic packages through."
-    [ mergeResult addFile: destFile name ]
- on: Kernel.PackageNotAvailable
- do: [ :ex | ex resume ] ].
-
-        destFile withWriteStreamDo: [ :s | mergeResult printOn: s ] ].
-
-    packages do: [ :each || dirs files baseDir |
- files := mode = #dist
-    ifTrue: [ each files ]
-    ifFalse: [ each allFiles ].
-
-        dirs := files collect: [ :file |
-    Directory append: (File pathFor: file) to: each relativeDirectory ].
-
-        dirs asSet asSortedCollection do: [ :dir |
-    destName := Directory append: dir to: installDir.
-    (Directory name: destName) emitMkdir ].
-
- baseDir := Directory append: each relativeDirectory to: installDir.
-        files do: [ :file || srcFile destName |
-    srcFile := File name: (each findPathFor: file).
-    destName := Directory append: file to: baseDir.
-
-            mode = #dist
-        ifTrue: [ srcFile emitSymlink: destName ]
-        ifFalse: [ srcFile emitInstall: destName ] ] ]
+    mode new
+        destDir: destdir installDir: installDir;
+ srcdir: srcdir;
+ addAllFiles: packageFiles;
+ run;
+ listFiles: listFiles
 ]
     on: Error
     do: [ :ex |
- ('gst-package: ', ex messageText) displayOn: stderr.
+ ('gst-package: ', ex messageText, '
+') displayOn: stderr.
  "ex pass." ObjectMemory quit: 1 ].

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