[Help-smalltalk] [PATCH] Support test subpackages

[Paolo Bonzini]

This patch adds support for anonymous subpackages specified with <test> 
inside a <package> tag.  This includes a lot of boring stuff: more 
refactoring of the XML parser (I should really use naiveXML...) so that 
parsing the body of <package> or <test> is done on the instance side of 
Package; support for printing nested packages nicely; support for 
name-less packages.

The nice part of this is how nicely it fits with the rewrite of gst-load 
as a shell script a while ago.  Now, doit

  gst-load --test MD5

will load the testing subpackage to run the tests, but will not load the 
testing subpackage in the final image.  I may provide a --load-tests 
option to gst-load in the future (patches are welcome of course).

Paolo

--- orig/kernel/Collection.st
+++ mod/kernel/Collection.st
@@ -252,10 +252,10 @@ do: aBlock separatedBy: separatorBlock
     | first |
     first := true.
     self do: [ :each |
-       aBlock value: each.
        first
            ifTrue: [ first := false ]
-           ifFalse: [ separatorBlock value ]
+           ifFalse: [ separatorBlock value ].
+       aBlock value: each.
     ]
 !
 


--- orig/kernel/PkgLoader.st
+++ mod/kernel/PkgLoader.st
@@ -95,7 +95,7 @@ XML.'!
 Namespace current: Smalltalk!
 
 Kernel.PackageInfo subclass: #Package
-       instanceVariableNames: 'features prerequisites builtFiles files fileIns 
directory libraries modules callouts namespace sunitScripts'
+       instanceVariableNames: 'features prerequisites builtFiles files fileIns 
directory libraries modules callouts namespace sunitScripts test'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Language-Packaging'
@@ -128,7 +128,12 @@ printOn: aStream
     "Print the XML source code for the information that the PackageLoader
      holds on aStream."
     aStream nextPutAll: '<packages>'; nl.
-    self do: [ :each | each printOn: aStream ].
+    self
+       do: [ :each |
+           aStream space: 2.
+           each printOn: aStream tag: 'package' indent: 2.
+           aStream nl ]
+       separatedBy: [ aStream nl ].
     aStream nextPutAll: '</packages>'
 ! !
 
@@ -146,6 +151,12 @@ do: aBlock
     self keys do: [ :each | aBlock value: (self at: each) ]
 !
 
+do: aBlock separatedBy: sepBlock
+    self keys
+       do: [ :each | aBlock value: (self at: each) ]
+       separatedBy: sepBlock
+!
+
 keys
     self subclassResponsibility
 !
@@ -364,9 +375,15 @@ parse: file baseDirectories: baseDirs
 
 fileIn
     "File in the given package and its dependencies."
-    PackageLoader fileInPackage: self name!
+    self name isNil
+       ifTrue: [
+           "Other packages cannot be dependent on this one."
+           PackageLoader fileInPackages: self prerequisites.
+           self primFileIn ]
+       ifFalse: [
+           PackageLoader fileInPackage: self name ]!
 
-printXmlOn: aStream collection: aCollection tag: aString
+printXmlOn: aStream collection: aCollection tag: aString indent: indent
     "Private - Print aCollection on aStream as a sequence of aString
      tags."
     aCollection do: [ :each |
@@ -374,78 +391,101 @@ printXmlOn: aStream collection: aCollect
             nextPutAll: '  <'; nextPutAll: aString; nextPut: $>;
             nextPutAll: each;
             nextPutAll: '</'; nextPutAll: aString; nextPut: $>;
-            nl
+            nl; space: indent
     ]!
 
 printOn: aStream
+    self printOn: aStream tag: 'package' indent: 0
+!
+
+printOn: aStream tag: tag indent: indent
     "Print a representation of the receiver on aStream (it happens
      to be XML."
 
-    aStream nextPutAll: '<package>
-  <name>'; nextPutAll: self name; nextPutAll: '</name>'; nl.
+    aStream
+       nextPut: $<;
+       nextPutAll: tag;
+       nextPut: $>;
+       nl; space: indent.
+
+    self name isNil ifFalse: [
+       aStream
+           nextPutAll: '  <name>';
+           nextPutAll: self name;
+           nextPutAll: '</name>';
+           nl; space: indent.
+    ].
 
     self namespace isNil ifFalse: [
        aStream
            nextPutAll: '  <namespace>';
            nextPutAll: self namespace;
            nextPutAll: '</namespace>';
-           nl.
+           nl; space: indent.
     ].
 
+    self test isNil ifFalse: [
+       aStream space: 2.
+       self test printOn: aStream tag: 'test' indent: indent + 2.
+       aStream nl; space: indent ].
+
     self
        printXmlOn: aStream
        collection: self features asSortedCollection
-       tag: 'provides'.
-
+       tag: 'provides'
+       indent: indent.
     self
        printXmlOn: aStream
        collection: self prerequisites asSortedCollection
-       tag: 'prereq'.
-
+       tag: 'prereq'
+       indent: indent.
     self
        printXmlOn: aStream
        collection: self sunitScripts
-       tag: 'sunit'.
-
+       tag: 'sunit'
+       indent: indent.
     self
        printXmlOn: aStream
        collection: self callouts asSortedCollection
-       tag: 'callout'.
-
+       tag: 'callout'
+       indent: indent.
     self
        printXmlOn: aStream
        collection: self fileIns
-       tag: 'filein'.
-
+       tag: 'filein'
+       indent: indent.
     self
        printXmlOn: aStream
        collection: self libraries asSortedCollection
-       tag: 'library'.
-
+       tag: 'library'
+       indent: indent.
     self
        printXmlOn: aStream
        collection: self modules asSortedCollection
-       tag: 'module'.
-
+       tag: 'module'
+       indent: indent.
     self directory isNil
        ifFalse: [
-           self
-               printXmlOn: aStream
-               collection: { self directory }
-               tag: 'directory' ].
+           aStream
+               nextPutAll: '  <directory>';
+               nextPutAll: self directory;
+               nextPutAll: '</directory>';
+               nl; space: indent ].
+
+    self files size + self builtFiles size > 1
+       ifTrue: [ aStream nl; space: indent  ].
 
-    self files size + self builtFiles size > 1 ifTrue: [ aStream nl ].
     self
        printXmlOn: aStream
        collection: self files
-       tag: 'file'.
-
+       tag: 'file'
+       indent: indent.
     self
        printXmlOn: aStream
        collection: self builtFiles
-       tag: 'built-file'.
-
-    aStream nextPutAll: '</package>'; nl!
+       tag: 'built-file'
+       indent: indent.
+    aStream nextPutAll: '</'; nextPutAll: tag; nextPut: $>!
 
 name
     "Answer the name of the package."
@@ -618,60 +658,42 @@ loadedPackage
 !Package class methodsFor: 'instance creation'!
 
 parse: file
-    | stack cdata ch tag package |
-    stack := OrderedCollection new.
+    | ch tag |
     [
-       [ cdata := cdata isNil
-           ifTrue: [ file upTo: $< ]
-           ifFalse: [ cdata, (file upTo: $<) ].
-
-           file atEnd ] whileFalse: [
-           ch := file peek.
-           ch == $! ifTrue: [ file skipTo: $> ].
-           ch == $/ ifTrue: [
-               tag := stack removeLast.
-               file next.
-               (file upTo: $>) = tag ifFalse: [
-                   ^self error: 'error in packages file: unmatched end tag ', 
tag
-               ].
+       (file upTo: $<) trimSeparators isEmpty ifFalse: [
+           self error: 'unexpected cdata' ].
+       file atEnd ifTrue: [
+           self error: 'expected start tag' ].
 
-               "I tried to put these from the most common to the least common"
+       ch := file peek.
+       ch == $! ifTrue: [ file skipTo: $> ].
+       ch == $/ ifTrue: [ self error: 'unexpected end tag ' ].
 
-               tag = 'file' ifTrue: [ package files add: cdata ] ifFalse: [
-               tag = 'filein' ifTrue: [ package fileIns add: cdata ] ifFalse: [
-               tag = 'prereq' ifTrue: [ package prerequisites add: cdata ] 
ifFalse: [
-               tag = 'provides' ifTrue: [ package features add: cdata ] 
ifFalse: [
-               tag = 'module' ifTrue: [ package modules add: cdata ] ifFalse: [
-               tag = 'directory' ifTrue: [ package directory: cdata ] ifFalse: 
[
-               tag = 'name' ifTrue: [ package name: cdata ] ifFalse: [
-               tag = 'namespace' ifTrue: [ package namespace: cdata ] ifFalse: 
[
-               tag = 'library' ifTrue: [ package libraries add: cdata ] 
ifFalse: [
-               tag = 'package' ifTrue: [ ^package ] ifFalse: [
-               tag = 'disabled-package' ifTrue: [ ^nil ] ifFalse: [
-               tag = 'built-file' ifTrue: [ package builtFiles add: cdata ] 
ifFalse: [
-               tag = 'sunit' ifTrue: [ package sunitScripts add: cdata ] 
ifFalse: [
-               tag = 'callout' ifTrue: [ package callouts add: cdata 
]]]]]]]]]]]]]].
-               cdata := nil.
-           ].
-           ch isAlphaNumeric ifTrue: [
-               tag := file upTo: $>.
-               tag = 'package' ifTrue: [ package := Package new ].
-               tag = 'disabled-package' ifTrue: [ package := Package new ].
-               (stack isEmpty and: [ package isNil ])
-                   ifTrue: [ self error: 'expected package tag' ].
-               stack addLast: tag.
-               cdata := nil
-           ].
+       ch isAlphaNumeric ifTrue: [
+           tag := file upTo: $>.
+           tag = 'package' ifTrue: [ ^Package new parse: file tag: tag ].
+           tag = 'disabled-package' ifTrue: [ Package new parse: file tag: 
tag. ^nil ].
         ]
-    ] ensure: [
-        stack isEmpty ifFalse: [
-           self error: 'error in packages file: unmatched start tags',
-               stack asArray printString ]
-    ]
+    ] repeat
 ! !
 
 !Package methodsFor: 'accessing'!
 
+test
+    "Answer the test sub-package."
+    ^test!
+
+test: aPackage
+    "Set the test sub-package to be aPackage."
+    aPackage test isNil ifFalse: [
+       self error: 'test packages must not be nested' ].
+    aPackage name isNil ifFalse: [
+       self error: 'test package must not have names' ].
+    aPackage prerequisites add: 'SUnit'; add: self name.
+    aPackage directory isNil ifTrue: [
+        aPackage directory: self directory ].
+    test := aPackage!
+
 namespace
     "Answer the namespace in which the package is loaded."
     ^namespace!
@@ -751,6 +773,9 @@ baseDirectories: baseDirectories
     fileIns := self findBaseDirs: baseDirectories for: self fileIns.
     builtFiles := self findBaseDirs: baseDirectories for: self builtFiles.
 
+    (self test notNil and: [ (self test baseDirectories: baseDirectories) not 
])
+       ifTrue: [ ^false ].
+
     files isNil | fileIns isNil | builtFiles isNil ifTrue: [ ^false ].
 
     self directory isNil ifFalse: [
@@ -808,18 +833,15 @@ createNamespace
     ].
     ^ns!
 
+loaded
+    ^self name notNil and: [ Smalltalk hasFeatures: self name ]!
+
 primFileIn
     "Private - File in the given package without paying attention at
      dependencies and C callout availability"
     | dir namespace |
 
-    (Smalltalk hasFeatures: self name) ifTrue: [ ^self ].
-    OutputVerbosity > 0 ifTrue: [
-        Transcript
-           nextPutAll: 'Loading package ', self name;
-           nl
-    ].
-
+    self loaded ifTrue: [ ^self ].
     [
         dir := Directory working.
         namespace := Namespace current.
@@ -834,12 +856,67 @@ primFileIn
                     ifFalse: [ ^self error: 'C callout not available: ', func 
]]].
 
         self fileIns do: [ :each | FileStream fileIn: each ].
-        Smalltalk addFeature: self name.
+        self name isNil ifFalse: [ Smalltalk addFeature: self name ].
         self features do: [ :each | Smalltalk addFeature: each ].
     ] ensure: [
         Directory working: dir.
         Namespace current: namespace.
     ]
+!
+
+parse: file tag: openingTag
+    | stack cdata ch tag |
+    stack := OrderedCollection new.
+    stack addLast: openingTag.
+    [
+       [ cdata := cdata isNil
+           ifTrue: [ file upTo: $< ]
+           ifFalse: [ cdata, (file upTo: $<) ].
+
+           file atEnd ] whileFalse: [
+           ch := file peek.
+           ch == $! ifTrue: [ file skipTo: $> ].
+           ch == $/ ifTrue: [
+               tag := stack removeLast.
+               file next.
+               (file upTo: $>) = tag ifFalse: [
+                   ^self error: 'error in packages file: unmatched end tag ', 
tag
+               ].
+
+               "I tried to put these from the most common to the least common"
+               tag = 'file' ifTrue: [ self files add: cdata ] ifFalse: [
+               tag = 'filein' ifTrue: [ self fileIns add: cdata ] ifFalse: [
+               tag = 'prereq' ifTrue: [ self prerequisites add: cdata ] 
ifFalse: [
+               tag = 'provides' ifTrue: [ self features add: cdata ] ifFalse: [
+               tag = 'module' ifTrue: [ self modules add: cdata ] ifFalse: [
+               tag = 'directory' ifTrue: [ self directory: cdata ] ifFalse: [
+               tag = 'name' ifTrue: [ self name: cdata ] ifFalse: [
+               tag = 'namespace' ifTrue: [ self namespace: cdata ] ifFalse: [
+               tag = 'library' ifTrue: [ self libraries add: cdata ] ifFalse: [
+               tag = 'built-file' ifTrue: [ self builtFiles add: cdata ] 
ifFalse: [
+               tag = 'sunit' ifTrue: [ self sunitScripts add: cdata ] ifFalse: 
[
+               tag = 'callout' ifTrue: [ self callouts add: cdata ] ifFalse: [
+               tag = openingTag ifTrue: [ ^self ] ifFalse: [
+                   self error: 'invalid tag ', tag ]]]]]]]]]]]]].
+               cdata := nil.
+           ].
+           ch isAlphaNumeric ifTrue: [
+               tag := file upTo: $>.
+               tag = 'test'
+                   ifTrue: [ self test: (Package new parse: file tag: tag) ]
+                   ifFalse: [ stack addLast: tag ].
+
+               cdata trimSeparators isEmpty ifFalse: [
+                   ^self error: 'unexpected character data' ].
+
+               cdata := nil
+           ].
+        ]
+    ] ensure: [
+        stack isEmpty ifFalse: [
+           self error: 'error in packages file: unmatched start tags',
+               stack asArray printString ]
+    ]
 ! !
 
 
@@ -973,7 +1050,10 @@ fileInPackages: packagesList
        extractDependenciesFor: packagesList
        ifMissing: [ :name | ^self error: 'package not available: ', name ].
        
-    toBeLoaded do: [ :each | (self packageAt: each) primFileIn ]
+    toBeLoaded do: [ :each |
+        OutputVerbosity > 0 ifTrue: [
+            Transcript nextPutAll: 'Loading package ', each; nl ].
+       (self packageAt: each) primFileIn ]
 ! !
 
 


--- orig/packages.xml.in
+++ mod/packages.xml.in
@@ -240,9 +240,6 @@
   <name>DhbNumericalMethods</name>
   <namespace>Dhb</namespace>
 
-  <tests>Dhb.DhbTestCase*</tests>
-  <prereq>SUnit</prereq>
-
   <filein>Basic.st</filein>
   <filein>Statistics.st</filein>
   <filein>RNG.st</filein>
@@ -252,10 +249,14 @@
   <filein>Optimization.st</filein>
   <filein>Distributions.st</filein>
   <filein>Integration.st</filein>
-  <filein>NumericsTests.st</filein>
   <filein>NumericsAdds.st</filein>
   <directory>numerics</directory>
 
+  <test>
+    <sunit>Dhb.DhbTestCase*</sunit>
+    <filein>NumericsTests.st</filein>
+  </test>
+
   <file>NumericsTests.st</file>
   <file>Approximation.st</file>
   <file>Basic.st</file>
@@ -271,15 +272,16 @@
 
 <package>
   <name>GDBM</name>
-  <sunit>GDBMTest</sunit>
-  <prereq>SUnit</prereq>
-
   <filein>gdbm-c.st</filein>
   <filein>gdbm.st</filein>
-  <filein>gdbmtests.st</filein>
   <module>gdbm</module>
   <directory>examples</directory>
 
+  <test>
+    <sunit>GDBMTest</sunit>
+    <filein>gdbmtests.st</filein>
+  </test>
+
   <file>gdbm.st</file>
   <file>gdbm-c.st</file>
   <file>gdbmtests.st</file>
@@ -296,15 +298,16 @@
 
 <package>
   <name>ZLib</name>
-  <sunit>ZlibStreamTest</sunit>
-  <prereq>SUnit</prereq>
-
   <filein>PipeStream.st</filein>
   <filein>zlib.st</filein>
-  <filein>zlibtests.st</filein>
   <module>zlib</module>
   <directory>examples</directory>
 
+  <test>
+   <sunit>ZlibStreamTest</sunit>
+   <filein>zlibtests.st</filein>
+  </test>
+
   <file>PipeStream.st</file>
   <file>zlib.st</file>
   <file>zlibtests.st</file>
@@ -312,14 +315,15 @@
 
 <package>
   <name>MD5</name>
-  <sunit>MD5Test</sunit>
-  <prereq>SUnit</prereq>
-
   <filein>md5.st</filein>
-  <filein>md5tests.st</filein>
   <module>md5</module>
   <directory>examples</directory>
 
+  <test>
+   <sunit>MD5Test</sunit>
+   <filein>md5tests.st</filein>
+  </test>
+
   <file>md5.st</file>
   <file>md5tests.st</file>
 </package>
@@ -379,8 +383,6 @@
 
 <package>
   <name>Parser</name>
-  <sunit>STInST.Tests.TestStandardRewrites</sunit>
-  <prereq>SUnit</prereq>
 
   <namespace>STInST</namespace>
   <filein>RBToken.st</filein>
@@ -399,7 +401,10 @@
   <filein>SqueakParser.st</filein>
   <filein>Exporter.st</filein>
 
-  <filein>RewriteTests.st</filein>
+  <test>
+   <sunit>STInST.Tests.TestStandardRewrites</sunit>
+   <filein>RewriteTests.st</filein>
+  </test>
 
   <directory>compiler</directory>
 
@@ -426,15 +431,18 @@
 
 <package>
   <name>SUnit</name>
-  <sunit>SUnitTest</sunit>
-  <sunit>TestSuitesScriptTest</sunit>
 
   <filein>SUnitPreload.st</filein>
   <filein>SUnit.st</filein>
-  <filein>SUnitTests.st</filein>
   <filein>SUnitScript.st</filein>
   <directory>sunit</directory>
 
+  <test>
+    <sunit>SUnitTest</sunit>
+    <sunit>TestSuitesScriptTest</sunit>
+    <filein>SUnitTests.st</filein>
+  </test>
+
   <file>SUnit.st</file>
   <file>SUnitPreload.st</file>
   <file>SUnitTests.st</file>


--- orig/scripts/Test.st
+++ mod/scripts/Test.st
@@ -75,8 +75,11 @@ Smalltalk
        [
            | pkg |
            pkg := PackageLoader packageAt: arg.
-           pkg fileIn.
-           script := script, ' ', pkg sunitScript ]
+           script := script, ' ', pkg sunitScript.
+           pkg test notNil ifTrue: [
+               pkg := pkg test.
+               script := script, ' ', pkg sunitScript ].
+           pkg fileIn ]
            ifCurtailed: [ ObjectMemory quit: 2 ] ].
 
     opt = 'file' ifTrue: [