--- a/StandaloneStartup.st Mon May 23 17:33:52 2011 +0200
+++ b/StandaloneStartup.st Tue May 24 17:25:16 2011 +0200
@@ -95,8 +95,184 @@
Verbose := false.
! !
+!StandaloneStartup class methodsFor:'debugging support'!
+
+dumpCoverageInformation
+ "if the --coverage argument was given, dump that information now.
+ This is invoked via an exit block, when smalltalk terminates"
+
+ Stderr nextPutLine:'coverage info...'.
+
+ "Created: / 24-05-2011 / 17:08:46 / cg"
+!
+
+handleCoverageMeasurementOptionsFromArguments:argv
+ "handle the coverage measurement command line argument:
+ --coverage
+ [+/-]package: <package-pattern> ... do / do not measure in package (regex match)
+ [+/-]class: <class-pattern> ... do / do not measure in class (regex match, including nameSpace)
+ [+/-]method: <className>#<methodName> ... do / do not measure in method
+
+ adds instrumentation code to all selected methods.
+ "
+
+ |idx nextArg done doAdd addNames addMethodNames
+ anyItem anyMethodInstrumented checkClass checkMethod coverageAction
+ includedPackageNames excludedPackageNames
+ includedClassNames excludedClassNames
+ includedMethodNames excludedMethodNames|
+
+"
+ self handleCoverageMeasurementOptionsFromArguments:#('foo' '--coverage' '--foo' '+package:' 'expeccoNET:*')
+ self handleCoverageMeasurementOptionsFromArguments:#('foo' '--coverage' '+package:' 'stx:*')
+ self handleCoverageMeasurementOptionsFromArguments:#('foo' '--coverage' '+package:' 'stx:libtool*')
+ self handleCoverageMeasurementOptionsFromArguments:#('foo' '--coverage' '+class:' 'Tools::*' '-class:' 'Tools::StringSearchTool' )
+ self handleCoverageMeasurementOptionsFromArguments:#('foo' '--coverage' '+class:' 'Tools::*Browser*' )
+ self handleCoverageMeasurementOptionsFromArguments:#('foo' '--coverage' '+method:' 'String#at:put:' 'String#at:')
+"
+ includedPackageNames := Set new.
+ excludedPackageNames := Set new.
+ includedClassNames := Set new.
+ excludedClassNames := Set new.
+ includedMethodNames := Dictionary new.
+ excludedMethodNames := Dictionary new.
+
+ (self allowCoverageMeasurementOption) ifFalse:[^ self].
+ idx := argv indexOfAny:#('--coverage').
+ idx == 0 ifTrue:[^ self ].
+
+ addNames := [:collection |
+ [
+ nextArg := argv at:idx ifAbsent:nil.
+ nextArg notNil
+ and:[ ((nextArg startsWith:'+') or:[(nextArg startsWith:'-')]) not
+ and:[ (nextArg endsWith:':') not ]]
+ ] whileTrue:[
+ collection add:nextArg.
+ anyItem := true.
+ idx := idx + 1.
+ ].
+ ].
+
+ addMethodNames := [:collection |
+ |idx2 className selector|
+
+ [
+ nextArg := argv at:idx ifAbsent:nil.
+ nextArg notNil
+ and:[ ((nextArg startsWith:'+') or:[(nextArg startsWith:'-')]) not]
+ ] whileTrue:[
+ idx2 := nextArg indexOf:$#.
+ className := nextArg copyTo:idx2-1.
+ selector := nextArg copyFrom:idx2+1.
+ (collection at:className ifAbsentPut:[Set new]) add:selector.
+ anyItem := true.
+ idx := idx + 1.
+ ].
+ ].
+
+ idx := idx + 1.
+ done := false.
+
+ [
+ nextArg := argv at:idx ifAbsent:nil.
+ done not
+ and:[ nextArg notNil
+ and:[ ((nextArg startsWith:'+') or:[(nextArg startsWith:'-')]) ]]
+ ] whileTrue:[
+ idx := idx + 1.
+ doAdd := nextArg first == $+.
+ nextArg := nextArg copyFrom:2.
+ nextArg = 'package:' ifTrue:[
+ addNames value:(doAdd ifTrue:includedPackageNames ifFalse:excludedPackageNames).
+ ] ifFalse:[
+ nextArg = 'class:' ifTrue:[
+ addNames value:(doAdd ifTrue:includedClassNames ifFalse:excludedClassNames).
+ ] ifFalse:[
+ nextArg = 'method:' ifTrue:[
+ addMethodNames value:(doAdd ifTrue:includedMethodNames ifFalse:excludedMethodNames).
+ ] ifFalse:[
+ done := true
+ ]
+ ].
+ ].
+ ].
+
+ anyItem ifFalse:[ ^ self ].
+ anyMethodInstrumented := false.
+
+ coverageAction := [:aMethod |
+ ((aMethod sends:#subclassResponsibility) not
+ and:[ aMethod hasPrimitiveCode not ]) ifTrue:[
+ Transcript show:'instrumenting '; showCR:aMethod.
+ aMethod mclass recompile:aMethod selector usingCompilerClass:InstrumentingCompiler.
+ anyMethodInstrumented := true.
+ ] ifFalse:[
+ Transcript show:'skipped '; showCR:aMethod.
+ ].
+ ].
+
+ checkMethod := [:someMethod |
+ ((excludedMethodNames at:someMethod mclass name ifAbsent:#()) includes:someMethod selector) ifFalse:[
+ coverageAction value:someMethod
+ ].
+ ].
+
+ checkClass := [:someClass |
+ someClass instAndClassSelectorsAndMethodsDo:[:sel :mthd |
+ checkMethod value:mthd
+ ]
+ ].
+
+ Smalltalk allClassesDo:[:eachClass |
+ (includedPackageNames contains:[:somePackagePattern| somePackagePattern match:(eachClass package)]) ifTrue:[
+ (excludedPackageNames contains:[:somePackagePattern| somePackagePattern match:(eachClass package)]) ifFalse:[
+ (excludedClassNames contains:[:someClassPattern| someClassPattern match:(eachClass name)]) ifFalse:[
+ checkClass value:eachClass
+ ]
+ ]
+ ] ifFalse:[
+ (includedClassNames contains:[:someClassPattern| someClassPattern match:(eachClass name)]) ifTrue:[
+ (excludedClassNames contains:[:someClassPattern| someClassPattern match:(eachClass name)]) ifFalse:[
+ checkClass value:eachClass
+ ]
+ ] ifFalse:[
+ (Array with:eachClass theMetaclass with:eachClass) do:[:clsOrMeta |
+ |selectors|
+
+ selectors := includedMethodNames at:clsOrMeta name ifAbsent:nil.
+ selectors notEmptyOrNil ifTrue:[
+ selectors do:[:eachSelector |
+ coverageAction value:(clsOrMeta compiledMethodAt:eachSelector asSymbol).
+ ].
+ ].
+ ].
+ ].
+ ].
+ ].
+
+ anyMethodInstrumented ifTrue:[
+ Smalltalk addExitBlock:[ self dumpCoverageInformation ].
+ ].
+
+ "Created: / 24-05-2011 / 16:30:54 / cg"
+! !
+
!StandaloneStartup class methodsFor:'defaults'!
+allowCoverageMeasurementOption
+ "enable/disable the --measureCoverage startup options.
+ The default is false, so standAlone apps do not support coverage measurements by default.
+ Can be redefined in subclasses to enable it
+ (but will need the libcomp and possibly the programming/oom packages to be present)"
+
+ "/ ^ true.
+ ^ false
+
+ "Created: / 24-05-2011 / 16:16:15 / cg"
+ "Modified: / 24-05-2011 / 17:25:00 / cg"
+!
+
allowDebugOption
"enable/disable the --debug startup option.
The default is now false, so standAlone apps are closed by default.
@@ -450,6 +626,88 @@
!StandaloneStartup class methodsFor:'startup'!
+handleRCFileOptionsFromArguments:argv
+ "handle rc-file command line arguments:
+ --rcFileName ......... define a startup rc-file
+ "
+
+ |idx nextArg rcFilename|
+
+ idx := argv indexOf:'--rcFileName'.
+ idx ~~ 0 ifTrue:[
+ nextArg := argv at:(idx + 1) ifAbsent:nil.
+ (nextArg notNil and:[ (nextArg startsWith:'-') not ]) ifTrue:[
+ rcFilename := nextArg.
+ argv removeAtIndex:idx+1; removeAtIndex:idx.
+ ]
+ ].
+
+ rcFilename isNil ifTrue:[
+ rcFilename := self startupFilename.
+ ].
+ rcFilename asFilename exists ifTrue:[
+ self verboseInfo:('reading ',rcFilename,'...').
+ rcFilename isAbsolute ifFalse:[
+ rcFilename := OperatingSystem pathOfSTXExecutable asFilename directory constructString:rcFilename.
+ ].
+ Smalltalk secureFileIn:rcFilename
+ ].
+
+ "Created: / 24-05-2011 / 16:13:34 / cg"
+!
+
+handleScriptingOptionsFromArguments:argv
+ "handle scripting command line argument:
+ --scripting portNr ... start a scripting server
+ --allowHost host ..... add host to the allowed scripting hosts
+ "
+
+ |scripting idx nextArg portNr allowedScriptingHosts|
+
+ scripting := false.
+ (self allowScriptingOption) ifTrue:[
+ idx := argv indexOfAny:#('--scripting').
+ idx ~~ 0 ifTrue:[
+ nextArg := argv at:(idx + 1) ifAbsent:nil.
+ (nextArg notNil and:[ (nextArg startsWith:'-') not ]) ifTrue:[
+ portNr := nextArg asInteger.
+ argv removeAtIndex:idx+1.
+ ].
+ argv removeAtIndex:idx.
+
+ scripting := true
+ ].
+
+ allowedScriptingHosts := OrderedCollection new.
+
+ idx := argv indexOfAny:#('--allowHost').
+ [idx ~~ 0] whileTrue:[
+ nextArg := argv at:(idx + 1) ifAbsent:nil.
+ nextArg isNil ifTrue:[
+ self usage.
+ AbortOperationRequest raise.
+ ].
+ allowedScriptingHosts add:nextArg.
+ idx := argv indexOfAny:#('--allowHost').
+ ].
+ ].
+
+ scripting ifTrue:[
+ self verboseInfo:('scripting on').
+ STXScriptingServer notNil ifTrue:[
+ allowedScriptingHosts do:[:eachHost | STXScriptingServer allowHost:eachHost ].
+
+ "/ scripting on port/stdin_out/8008
+ self verboseInfo:('start scripting').
+ STXScriptingServer startAt:portNr
+ ] ifFalse:[
+ self verboseInfo:('missing STXScriptingServer class').
+ ].
+ ].
+
+ "Created: / 24-05-2011 / 16:12:02 / cg"
+!
+
loadPatch:fileName
self verboseInfo:('loading patch: ',fileName baseName).
Smalltalk silentFileIn:fileName pathName.
@@ -529,7 +787,7 @@
--allowHost host ..... add host to the allowed scripting hosts
"
- |idx rcFilename nextArg debugging scripting allowedScriptingHosts portNr|
+ |idx debugging|
"/ Smalltalk beHeadless:true.
"/ OperatingSystem disableSignal:(OperatingSystem sigHUP).
@@ -562,72 +820,19 @@
self setupToolsForNoDebug.
].
- self suppressRCFileReading ifFalse:[
- idx := argv indexOf:'--rcFileName'.
- idx ~~ 0 ifTrue:[
- nextArg := argv at:(idx + 1) ifAbsent:nil.
- (nextArg notNil and:[ (nextArg startsWith:'-') not ]) ifTrue:[
- rcFilename := nextArg.
- argv removeAtIndex:idx+1; removeAtIndex:idx.
- ]
- ].
-
- rcFilename isNil ifTrue:[
- rcFilename := self startupFilename.
- ].
- rcFilename asFilename exists ifTrue:[
- self verboseInfo:('reading ',rcFilename,'...').
- rcFilename isAbsolute ifFalse:[
- rcFilename := OperatingSystem pathOfSTXExecutable asFilename directory constructString:rcFilename.
- ].
- Smalltalk secureFileIn:rcFilename
- ].
+ (self suppressRCFileReading) ifFalse:[
+ self handleRCFileOptionsFromArguments:argv.
].
-
- scripting := false.
(self allowScriptingOption) ifTrue:[
- idx := argv indexOfAny:#('--scripting').
- idx ~~ 0 ifTrue:[
- nextArg := argv at:(idx + 1) ifAbsent:nil.
- (nextArg notNil and:[ (nextArg startsWith:'-') not ]) ifTrue:[
- portNr := nextArg asInteger.
- argv removeAtIndex:idx+1.
- ].
- argv removeAtIndex:idx.
-
- scripting := true
- ].
-
- allowedScriptingHosts := OrderedCollection new.
-
- idx := argv indexOfAny:#('--allowHost').
- [idx ~~ 0] whileTrue:[
- nextArg := argv at:(idx + 1) ifAbsent:nil.
- nextArg isNil ifTrue:[
- self usage.
- AbortOperationRequest raise.
- ].
- allowedScriptingHosts add:nextArg.
- idx := argv indexOfAny:#('--allowHost').
- ].
+ self handleScriptingOptionsFromArguments:argv.
].
-
- scripting ifTrue:[
- self verboseInfo:('scripting on').
- STXScriptingServer notNil ifTrue:[
- allowedScriptingHosts do:[:eachHost | STXScriptingServer allowHost:eachHost ].
-
- "/ scripting on port/stdin_out/8008
- self verboseInfo:('start scripting').
- STXScriptingServer startAt:portNr
- ] ifFalse:[
- self verboseInfo:('missing STXScriptingServer class').
- ].
+ (self allowCoverageMeasurementOption) ifTrue:[
+ self handleCoverageMeasurementOptionsFromArguments:argv.
].
^ true
- "Modified: / 15-11-2010 / 14:17:34 / cg"
+ "Modified: / 24-05-2011 / 16:14:45 / cg"
!
setupToolsForDebug
@@ -735,12 +940,18 @@
self allowDebugOption ifTrue:[
Stderr nextPutLine:' --debug ................. enable Debugger'.
].
+ self allowCoverageMeasurementOption ifTrue:[
+ Stderr nextPutLine:' --coverage .............. turn on coverage measurement'.
+ Stderr nextPutLine:' [+/-]package: pattern ... - include/exclude packages'.
+ Stderr nextPutLine:' [+/-]class: pattern ... - include/exclude classes'.
+ Stderr nextPutLine:' [+/-]method: cls#sel ... - include/exclude methods'.
+ ].
self suppressRCFileReading ifFalse:[
Stderr nextPutLine:' --rcFileName file ....... execute code from file on startup (default: ',self startupFilename,')'.
].
"Created: / 19-09-2006 / 16:37:55 / cg"
- "Modified: / 06-10-2010 / 09:52:18 / cg"
+ "Modified: / 24-05-2011 / 17:23:18 / cg"
! !
!StandaloneStartup class methodsFor:'startup-to be redefined'!
@@ -812,11 +1023,11 @@
!StandaloneStartup class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/StandaloneStartup.st,v 1.60 2011-04-26 09:45:37 stefan Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/StandaloneStartup.st,v 1.61 2011-05-24 15:25:16 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libbasic/StandaloneStartup.st,v 1.60 2011-04-26 09:45:37 stefan Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/StandaloneStartup.st,v 1.61 2011-05-24 15:25:16 cg Exp $'
! !
StandaloneStartup initialize!