help-smalltalk
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Help-smalltalk] [PATCH] Improve gst-load/gst-sunit scripts


From: Paolo Bonzini
Subject: [Help-smalltalk] [PATCH] Improve gst-load/gst-sunit scripts
Date: Sun, 20 May 2007 13:53:06 +0200
User-agent: Thunderbird 2.0.0.0 (Macintosh/20070326)

This patch improves the installed scripts gst-load and gst-sunit. It is best to show the help messages:


Usage:
    gst-sunit [ flag ... ] class.tests ...

Options:
    -q --quiet            hide the output
    -v --verbose          show passed tests
    -f --file=FILE        load file before running subsequent tests
    -p --package=PACKAGE  load package and run its tests
    -h --help             show this message


Usage:
    gst-load [ flag ... ] package ...

Options:
    -q --quiet            hide the output
    -v --verbose          show loaded files
    -f --force            reload package if already loaded
    -n --dry-run          don't save the image after loading
    -h --help             show this message


The XML package description file is grown another tag, <sunit>, which specifies a SUnit script to be executed by "gst-sunit -p". For now, only "gst-sunit -p SUnit" works but I'll add support for more packages soon (unless someone beats me and sends patches, of course!). This also simplifies testing external packages upon "make check".

I *think* I'll apply this to 2.3 as well, but I'm not sure. Opinions are welcome.

Paolo
2007-05-18  Paolo Bonzini  <address@hidden>
 
        * scripts/Load.st: Rewrite.
        * scripts/Test.st: Rewrite.
        * scripts/Reload.st: Replace with...
        * scripts/gst-reload.sh: ... this script.


--- orig/Makefile.am
+++ mod/Makefile.am
@@ -56,7 +56,7 @@ pkglib_DATA = libc.la
 noinst_DATA = gst.im
 dist_noinst_DATA += smalltalk-mode.el.in gst-mode.el.in .gdbinit \
        kernel/stamp-classes blox-tk/stamp-classes tcp/stamp-classes \
-       i18n/stamp-classes scripts/Load.st scripts/Reload.st \
+       i18n/stamp-classes scripts/Load.st scripts/gst-reload.sh \
        scripts/Test.st scripts/Finish.st scripts/GenLibDoc.st \
        scripts/GenBaseDoc.st gsticon.ico
 
@@ -83,7 +83,7 @@ install-exec-hook:
        $(SED) -e "s,@\(bindir\)@,$(bindir)," $(srcdir)/scripts/Load.st \
          > $(DESTDIR)$(bindir)/gst-load
        chmod +x $(DESTDIR)$(bindir)/gst-load
-       $(SED) -e "s,@\(bindir\)@,$(bindir)," $(srcdir)/scripts/Reload.st \
+       $(SED) -e "s,@\(bindir\)@,$(bindir)," $(srcdir)/scripts/gst-reload.sh \
          > $(DESTDIR)$(bindir)/gst-reload
        chmod +x $(DESTDIR)$(bindir)/gst-reload
        $(SED) -e "s,@\(bindir\)@,$(bindir)," $(srcdir)/scripts/Test.st \


--- orig/kernel/PkgLoader.st
+++ mod/kernel/PkgLoader.st
@@ -32,7 +32,7 @@
 
 
 Object subclass: #Package
-       instanceVariableNames: 'name features prerequisites builtFiles files 
fileIns directory libraries modules callouts namespace'
+       instanceVariableNames: 'name features prerequisites builtFiles files 
fileIns directory libraries modules callouts namespace sunitScripts'
        classVariableNames: ''
        poolDictionaries: ''
        category: 'Language-Packaging'
@@ -101,6 +101,11 @@ printOn: aStream
 
     self
        printXmlOn: aStream
+       collection: self sunitScripts
+       tag: 'sunit'.
+
+    self
+       printXmlOn: aStream
        collection: self callouts asSortedCollection
        tag: 'callout'.
 
@@ -200,6 +205,18 @@ modules
     modules isNil ifTrue: [ modules := Set new ].
     ^modules!
 
+sunitScript
+    "Answer a String containing a SUnit script that
+     describes the package's test suite."
+    self sunitScripts isEmpty ifTrue: [ ^'' ].
+    ^self sunitScripts fold: [ :a :b | a, ' ', b ]!
+
+sunitScripts
+    "Answer a (modifiable) OrderedCollection of SUnit scripts that
+     compose the package's test suite."
+    sunitScripts isNil ifTrue: [ sunitScripts := OrderedCollection new ].
+    ^sunitScripts!
+
 callouts
     "Answer a (modifiable) Set of call-outs that are required to load
      the package.  Their presence is checked after the libraries and
@@ -340,6 +357,12 @@ fileInsFor: package
     ^(self packageAt: package) fileIns.
 !
 
+sunitScriptFor: package
+    "Answer a Strings containing a SUnit script that describes the package's
+     test suite."
+    ^(self packageAt: package) sunitScript.
+!
+
 calloutsFor: package
     "Answer a Set of Strings containing the filenames of the given package's
      required callouts (relative to the directory answered by #directoryFor:)"
@@ -592,7 +615,8 @@ processPackageFile: fileName baseDirecto
                (package baseDirs: baseDirs)
                    ifTrue: [ packages at: package name put: package ]] 
ifFalse: [
            tag = 'built-file' ifTrue: [ package builtFiles add: cdata ] 
ifFalse: [
-           tag = 'callout' ifTrue: [ package callouts add: cdata ]]]]]]]]]]]].
+           tag = 'sunit' ifTrue: [ package sunitScripts add: cdata ] ifFalse: [
+           tag = 'callout' ifTrue: [ package callouts add: cdata ]]]]]]]]]]]]].
            cdata := nil.
        ].
        ch isAlphaNumeric ifTrue: [


--- orig/packages.xml.in
+++ mod/packages.xml.in
@@ -398,6 +398,9 @@
 
 <package>
   <name>SUnit</name>
+  <sunit>SUnitTest.*</sunit>
+  <sunit>TestSuitesScriptTest.*</sunit>
+
   <filein>SUnitPreload.st</filein>
   <filein>SUnit.st</filein>
   <filein>SUnitTests.st</filein>


--- orig/scripts/Load.st
+++ mod/scripts/Load.st
@@ -30,15 +30,59 @@
 |
  ======================================================================"
 
-| ok verbose |
-ok := false.
-verbose := FileStream verbose: true.
-[
-    PackageLoader fileInPackages: Smalltalk arguments.
-    ok := true
-] valueWithUnwind.
+Smalltalk arguments isEmpty ifTrue: [ ObjectMemory quit ]!
+
+| helpString verbose snapshot force |
+snapshot := true.
+force := false.
+verbose := FileStream verbose: false.
+
+helpString :=
+'Usage:
+    gst-load [ flag ... ] package ...
+
+Options:
+    -q --quiet            hide the output
+    -v --verbose          show loaded files
+    -f --force            reload package if already loaded
+    -n --dry-run          don''t save the image after loading
+    -h --help             show this message
+'.
+
+"Parse the command-line arguments."
+Smalltalk
+    arguments: '-h|--help -q|--quiet -v|-V|--verbose -n|--dry-run -f|--force'
+    do: [ :opt :arg |
+
+    opt = 'help' ifTrue: [
+       helpString displayOn: stderr.
+       ObjectMemory quit: 0 ].
+
+    opt = 'quiet' ifTrue: [
+       OutputVerbosity := 0.
+       FileStream verbose: false ].
+
+    opt = 'verbose' ifTrue: [
+       OutputVerbosity := 1.
+       FileStream verbose: true ].
+
+    opt = 'force' ifTrue: [
+       force := true ].
+
+    opt = 'dry-run' ifTrue: [
+       snapshot := false ].
+
+    opt isNil ifTrue: [
+       [
+           force ifTrue: [ Smalltalk removeFeature: arg asSymbol ].
+           PackageLoader fileInPackage: arg ]
+           ifCurtailed: [ ObjectMemory quit: 1 ] ] ]
+
+    ifError: [
+       helpString displayOn: stderr.
+       ObjectMemory quit: 1 ].
+
 FileStream verbose: verbose.
 
-ok ifFalse: [ ObjectMemory quit: 1 ]!
-ObjectMemory snapshot!
+snapshot ifTrue: [ ObjectMemory snapshot ]!
 


--- orig/scripts/Test.st
+++ mod/scripts/Test.st
@@ -10,7 +10,7 @@
 
 "======================================================================
 |
-| Copyright 2003 Free Software Foundation, Inc.
+| Copyright 2003, 2007 Free Software Foundation, Inc.
 | Written by Paolo Bonzini.
 |
 | This file is part of GNU Smalltalk.
@@ -30,27 +30,97 @@
 |
  ======================================================================"
 
-(Smalltalk includesKey: #TestSuitesScripter)
-    ifFalse: [
-       Transcript show: 'SUnit not loaded.'; nl.
-       ObjectMemory quit: 1 ]!
-
-| suite script result |
-Smalltalk arguments isEmpty ifTrue: [ ^self ].
-script := Smalltalk arguments fold: [ :a :b | a, ' ', b ].
+Smalltalk arguments isEmpty ifTrue: [ ObjectMemory quit ]!
+
+| helpString verbose script suite result quiet |
+quiet := false.
+verbose := false.
+FileStream verbose: true.
+script := ''.
+
+helpString :=
+'Usage:
+    gst-sunit [ flag ... ] class.tests ...
+
+Options:
+    -q --quiet            hide the output
+    -v --verbose          show passed tests
+    -f --file=FILE        load file before running subsequent tests
+    -p --package=PACKAGE  load package and run its tests
+    -h --help             show this message
+'.
+
+"Parse the command-line arguments."
+Smalltalk
+    arguments: '-h|--help -q|--quiet -v|-V|--verbose -f|--file: -p|--package:'
+    do: [ :opt :arg |
+
+    opt = 'help' ifTrue: [
+       helpString displayOn: stderr.
+       ObjectMemory quit: 0 ].
+
+    opt = 'verbose' ifTrue: [
+        OutputVerbosity := 1.
+       quiet := false.
+       verbose := true.
+       FileStream verbose: true ].
+
+    opt = 'quiet' ifTrue: [
+        OutputVerbosity := 0.
+       quiet := true.
+       verbose := false.
+       FileStream verbose: false ].
+
+    opt = 'package' ifTrue: [
+       [
+           | pkg |
+           pkg := PackageLoader packageAt: arg.
+           pkg fileIn.
+           script := script, ' ', pkg sunitScript ]
+           ifCurtailed: [ ObjectMemory quit: 2 ] ].
+
+    opt = 'file' ifTrue: [
+       [ FileStream fileIn: arg ]
+           ifCurtailed: [ ObjectMemory quit: 2 ] ].
+
+    opt isNil ifTrue: [
+       script := script, ' ', arg ] ]
+
+    ifError: [
+       helpString displayOn: stderr.
+       ObjectMemory quit: 1 ].
+
+script isEmpty ifTrue: [ ^self ].
+
+FileStream verbose: false.
+PackageLoader fileInPackage: #SUnit.
 suite := TestSuitesScripter run: script.
+
+"Set log policy to write to stdout."
+quiet
+    ifTrue: [ suite logPolicy: TestLogPolicy null ].
+verbose
+    ifTrue: [ suite logPolicy: (TestVerboseLog on: stdout) ].
+(quiet or: [ verbose ])
+    ifFalse: [ suite logPolicy: (TestCondensedLog on: stdout) ].
+
 result := suite run.
-result printNl.
 
-result errorCount > 0 ifTrue: [
-    Transcript show: 'Errors:'; nl.
-    (result errors asSortedCollection: [ :a :b | a printString <= b 
printString ])
-       do: [ :each | Transcript show: '    '; print: each; nl ] ].
-
-result failureCount > 0 ifTrue: [
-    Transcript show: 'Failures:'; nl.
-    (result failures asSortedCollection: [ :a :b | a printString <= b 
printString ])
-       do: [ :each | Transcript show: '    '; print: each; nl ] ].
+"Print result depending on verboseness."
+quiet ifFalse: [
+    result runCount < result passedCount
+        ifTrue: [ stdout nl ].
+
+    result printNl.
+    result errorCount > 0 ifTrue: [
+        aStream nextPutAll: 'Errors:'; nl.
+        (result errors asSortedCollection: [ :a :b | a printString <= b 
printString ])
+            do: [ :each | aStream nextPutAll: '    '; print: each; nl ] ].
+
+    result failureCount > 0 ifTrue: [
+        aStream nextPutAll: 'Failures:'; nl.
+        (result failures asSortedCollection: [ :a :b | a printString <= b 
printString ])
+            do: [ :each | aStream nextPutAll: '    '; print: each; nl ] ] ].
 
-result runCount = result passedCount ifFalse: [
-    ObjectMemory quit: 1 ]!
+result runCount = result passedCount
+    ifFalse: [ ObjectMemory quit: 1 ]!


--- orig/sunit/SUnit.st
+++ mod/sunit/SUnit.st
@@ -140,6 +140,13 @@ defaultResources
                        addAll: testCase resources;
                        yourself]!
 
+isLogging
+    ^true!
+
+logPolicy: aLogPolicy
+    self tests do: [ :each |
+       each isLogging ifTrue: [ each logPolicy: aLogPolicy ] ]!
+
 name
     ^name!
 


--- orig/sunit/SUnitScript.st
+++ mod/sunit/SUnitScript.st
@@ -201,4 +201,3 @@ testTwoCommentsScript
     self assert: suite tests size = 1
 ! !
 
-(TestSuitesScriptTest->TestSuitesScriptTest buildSuite run) printNl!


--- orig/sunit/SUnitTests.st
+++ mod/sunit/SUnitTests.st
@@ -434,5 +434,3 @@ testResourcesCollection
     collection := self resources.
     self assert: collection size = 1! !
 
-(SUnitTest -> SUnitTest buildSuite run) printNl!
-



* added files

--- /dev/null
+++ 
/Volumes/disk0s8/devel/gst/,,address@hidden/new-files-archive/./scripts/.arch-ids/gst-reload.sh.id
@@ -0,0 +1 @@
+Paolo Bonzini <address@hidden> Sat May 19 18:21:55 2007 6838.0
--- /dev/null
+++ 
/Volumes/disk0s8/devel/gst/,,address@hidden/new-files-archive/./scripts/gst-reload.sh
@@ -0,0 +1,3 @@
+#! /bin/sh
+
address@hidden@/gst-load --force ${1+"$@"}


reply via email to

[Prev in Thread] Current Thread [Next in Thread]