# HG changeset patch # User Claus Gittinger # Date 1306250716 -7200 # Node ID 921f77dd800d9d11784d3fe4d8896702f6de3384 # Parent 201a2a38899f83266e0eb459990281aac04c5f7e coverage support diff -r 201a2a38899f -r 921f77dd800d StandaloneStartup.st --- 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: ... do / do not measure in package (regex match) + [+/-]class: ... do / do not measure in class (regex match, including nameSpace) + [+/-]method: # ... 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!