"

 COPYRIGHT (c) 2006 by eXept Software AG

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libbasic' }"

Object subclass:#StandaloneStartup

	instanceVariableNames:''

	classVariableNames:'Verbose CommandLineArguments'

	poolDictionaries:''

	category:'System-Support'

!

StandaloneStartup class instanceVariableNames:'MutexHandle'

"

 No other class instance variables are inherited by this class.

"

!

!StandaloneStartup class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 2006 by eXept Software AG

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    a subclassable template class for a standalone GUI-application's startup;

    For your own stand alone programs, define a subclass of this, 

    and redefine the #main: method there.

    (of course, the other methods can also be redefined.)

    [author:]

        Claus Gittinger

    [start with:]

        <yourNamehere>Startup start

    [see also:]

        Smalltalk

        GetOpt

        ReadEvalPrintLoop

"

!

howToDealWithMultipleApplicationInstances

"

    please read the comment in the corresponding ApplicationModel class-documentation method.

"

!

whichMethodsToRedefine

"

    main:argv

        thats the actual program.

    suppressRCFileReading

        false here; redefine to return true, to disable the rc-file reading.

        you loose the chance of configuration, but lock the user out from any access to any smalltalk

        (if you have a user-phobia)

    allowDebugOption

        false here; redefine to return true, to enable the --debug startup option.

        if disabled, you loose the chance of debugging, but lock the user out from any access to any smalltalk

    allowScriptingOption

        false here; redefine to return true, to enable the --scripting startup option.

        if disabled, you loose the chance of remote control, but lock the user out from any access to any smalltalk

"

! !

!StandaloneStartup class methodsFor:'initialization'!

initialize

    "/ Verbose := true.

    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"

    "/ count instrumented vs. non-instrumented classes

    |nClasses nMethods 

     locOverall locExecuted locUnexecuted locInstrumented locUninstrumented

     locCovered locUncovered

     nInstrumentedClasses nUninstrumentedClasses nPartiallyInstrumentedClasses

     nInstrumentedMethods nUninstrumentedMethods 

     nClassesCompletelyCovered nClassesPartiallyCovered nClassesUncovered

     nMethodsCompletelyCovered nMethodsPartiallyCovered nMethodsUncovered|

    nInstrumentedClasses := nUninstrumentedClasses := nPartiallyInstrumentedClasses := 0.

    nInstrumentedMethods := nUninstrumentedMethods := 0.

    nClasses := nMethods := 0.

    locOverall := locCovered := locUncovered := 0.

    locInstrumented := locUninstrumented := 0.

    locExecuted := locUnexecuted := 0.

    nClassesCompletelyCovered := nClassesPartiallyCovered := nClassesUncovered := 0.

    nMethodsCompletelyCovered := nMethodsPartiallyCovered := nMethodsUncovered := 0.

    Smalltalk allClassesDo:[:eachClass |

        |nInstrumentedMethodsInClass nUninstrumentedMethodsInClass

         nMethodsCompletelyCoveredInClass nMethodsPartiallyCoveredInClass nMethodsUncoveredInClass

         locInstrumentedMethodsInClass locUninstrumentedMethodsInClass

         locExecutedInClass locUnexecutedInClass locPartiallyExecutedInClass|

        nMethodsCompletelyCoveredInClass := nMethodsPartiallyCoveredInClass := nMethodsUncoveredInClass := 0.

        nInstrumentedMethodsInClass := nUninstrumentedMethodsInClass := 0.

        locInstrumentedMethodsInClass := locUninstrumentedMethodsInClass := 0.

        eachClass instAndClassMethodsDo:[:mthd |

            |locMethod|

            nMethods := nMethods + 1.

            locMethod := 0. "/ mthd source asCollectionOfLines size.

            mthd isInstrumented ifTrue:[

                nInstrumentedMethodsInClass := nInstrumentedMethodsInClass + 1.

                locInstrumentedMethodsInClass := locInstrumentedMethodsInClass + locMethod.

                mthd hasBeenCalled ifTrue:[

                    mthd haveAllBlocksBeenExecuted ifTrue:[

                        "/ fully covered

                        nMethodsCompletelyCoveredInClass := nMethodsCompletelyCoveredInClass + 1

                    ] ifFalse:[

                        "/ partially covered

                        nMethodsPartiallyCoveredInClass := nMethodsPartiallyCoveredInClass + 1

                    ]

                ] ifFalse:[

                    "/ completely uncovered

                    nMethodsUncoveredInClass := nMethodsUncoveredInClass + 1

                ].

            ] ifFalse:[

                nUninstrumentedMethodsInClass := nUninstrumentedMethodsInClass + 1.

                locUninstrumentedMethodsInClass := locUninstrumentedMethodsInClass + locMethod.

            ].

        ].

        nInstrumentedMethods := nInstrumentedMethods + nInstrumentedMethodsInClass.

        nUninstrumentedMethods := nUninstrumentedMethods + nUninstrumentedMethodsInClass.

        nMethodsCompletelyCovered := nMethodsCompletelyCovered + nMethodsCompletelyCoveredInClass.

        nMethodsUncovered := nMethodsUncovered + nMethodsUncoveredInClass.

        nMethodsPartiallyCovered := nMethodsPartiallyCovered + nMethodsPartiallyCoveredInClass.

        nClasses := nClasses + 1.

        nInstrumentedMethodsInClass == 0 ifTrue:[

            nUninstrumentedMethodsInClass == 0 ifTrue:[

                "/ empty class - do not count

            ] ifFalse:[

                "/ completely uninstrumented

                nUninstrumentedClasses := nUninstrumentedClasses + 1.

            ].

        ] ifFalse:[

            nUninstrumentedMethodsInClass == 0 ifTrue:[

                "/ completely instrumented

                nInstrumentedClasses := nInstrumentedClasses + 1.

            ] ifFalse:[

                "/ part/part

                nPartiallyInstrumentedClasses := nPartiallyInstrumentedClasses + 1.

            ].

        ].

        nMethodsCompletelyCoveredInClass > 0 ifTrue:[

            nClassesCompletelyCovered := nClassesCompletelyCovered + 1.

        ] ifFalse:[

            nMethodsPartiallyCoveredInClass > 0 ifTrue:[

                nClassesPartiallyCovered := nClassesPartiallyCovered + 1.

            ] ifFalse:[

                nClassesUncovered := nClassesUncovered + 1.

            ].

        ].

    ].

    Stderr nextPutLine:'Coverage info:'.

    Stderr nextPutLine:('  Classes, overall: %1' bindWith:nClasses).

    Stderr nextPutLine:('  Classes, instrumented: %1 (%2%%)' bindWith:nInstrumentedClasses with:((nInstrumentedClasses / nClasses * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Classes, uninstrumented: %1 (%2%%)' bindWith:nUninstrumentedClasses with:((nUninstrumentedClasses / nClasses * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Classes, partially instrumented: %1 (%2%%)' bindWith:nPartiallyInstrumentedClasses with:((nPartiallyInstrumentedClasses / nClasses * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Classes, covered: %1 (%2%%)' bindWith:nClassesCompletelyCovered with:((nClassesCompletelyCovered / nClasses * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Classes, partially covered: %1 (%2%%)' bindWith:nClassesPartiallyCovered with:((nClassesPartiallyCovered / nClasses * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Classes, uncovered: %1 (%2%%)' bindWith:nClassesUncovered with:((nClassesUncovered / nClasses * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Methods, overall: %1' bindWith:nMethods).

    Stderr nextPutLine:('  Methods, instrumented: %1 (%2%%)' bindWith:nInstrumentedMethods with:((nInstrumentedMethods / nMethods * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Methods, uninstrumented: %1 (%2%%)' bindWith:nUninstrumentedMethods with:((nUninstrumentedMethods / nMethods * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Methods, covered: %1 (%2%%)' bindWith:nMethodsCompletelyCovered with:((nMethodsCompletelyCovered / nMethods * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Methods, partially covered: %1 (%2%%)' bindWith:nMethodsPartiallyCovered with:((nMethodsPartiallyCovered / nMethods * 100) asFixedPoint:1)).

    Stderr nextPutLine:('  Methods, uncovered: %1 (%2%%)' bindWith:nMethodsUncovered with:((nMethodsUncovered / nMethods * 100) asFixedPoint:1)).

    "

     self dumpCoverageInformation

    "

    "Created: / 24-05-2011 / 17:08:46 / cg"

    "Modified: / 25-05-2011 / 00:10:51 / 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 nMethodsInstrumented checkClass checkMethod coverageAction

     includedPackageNames excludedPackageNames 

     includedClassNames excludedClassNames 

     includedMethodNames excludedMethodNames|

"

 self handleCoverageMeasurementOptionsFromArguments:#('foo' '--coverage' '+package:' 'expeccoNET:*' '-class:' 'ExpeccoNET::ML' 'ExpeccoNET::LicenseString'  )

 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.

    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 ].

    nMethodsInstrumented := 0.

    coverageAction := [:aMethod |

            ((aMethod sends:#subclassResponsibility) not

            and:[ aMethod hasPrimitiveCode not ]) ifTrue:[

                Transcript show:'instrumenting '; showCR:aMethod.

                aMethod mclass recompile:aMethod selector usingCompilerClass:InstrumentingCompiler.

                nMethodsInstrumented := nMethodsInstrumented + 1.

            ] 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).

                        ].

                    ].

                ].

            ].

        ].

    ].

    nMethodsInstrumented ifTrue:[

        Transcript show:('%1 methods instrumented' bindWith:nMethodsInstrumented).

        Smalltalk addExitBlock:[ self dumpCoverageInformation ].

    ].

    "Created: / 24-05-2011 / 16:30:54 / cg"

    "Modified: / 24-05-2011 / 18:16:29 / 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)"

    ^ Smalltalk isStandAloneApp not

    "Created: / 24-05-2011 / 16:16:15 / cg"

    "Modified: / 25-05-2011 / 00:21:18 / cg"

!

allowDebugOption

    "enable/disable the --debug startup option.

     Can be redefined in subclasses to enable it"

    ^ false

!

allowScriptingOption

    "enable/disable the --scripting startup option.

     Can be redefined in subclasses to enable it"

    ^ false

!

suppressRCFileReading

    "enable/disable the rc-file reading (and also the --rcFileName option).

     If suppressed, there is no chance to interfere with the startup.

     Can be redefined in subclasses to disable it"

    ^ false

! !

!StandaloneStartup class methodsFor:'helpers'!

printInfo:msg

    Transcript 

        show:('%1 [info]: ' bindWith:(self applicationName));

        showCR:msg

!

redirectStandardStreams

    Stdout := Stderr.

    Transcript := Stderr.

!

verbose

    ^ Verbose == true

    "Created: / 01-02-2011 / 15:52:47 / cg"

!

verboseInfo:msg

    Verbose == true ifFalse:[^ self].

    self printInfo:msg

    "Modified: / 19-09-2006 / 16:30:27 / cg"

! !

!StandaloneStartup class methodsFor:'multiple applications support'!

applicationRegistryPath

    "the key under which this application stores its process ID in the registry

     as a collection of path-components.

     i.e. if #('foo' 'bar' 'baz') is returned here, the current applications ID will be stored

     in HKEY_CURRENT_USER\Software\foo\bar\baz\CurrentID.

     (would also be used as a relative path for a temporary lock file under unix).

     Used to detect if another instance of this application is already running."

    self subclassResponsibility

!

applicationUUID

    "answer an application-specific unique uuid.

     This is used as the name of some exclusive OS-resource, which is used to find out,

     if another instance of this application is already running.

     Under win32, a mutex is used; under unix, an exclusive file in the tempDir could be used.

     If redefined, please return a real UUID (i.e. UUID fromString:'.....') and not a string or 

     similar possibly conflicting identifier.

     You can paste a fresh worldwide unique id via the editor's more-misc-paste UUID menuFunction."

    self subclassResponsibility

    "Modified (comment): / 19-08-2011 / 01:54:39 / cg"

!

shouldReuseRunningApplication

    "answer true, if an already running application instance should be re-used"

    ^ false

! !

!StandaloneStartup class methodsFor:'multiple applications support-helpers'!

applicationRegistryEntry

    "retrieve the registry entry in which (if present), any currently running application

     has left its process ID"

    |path relPathName applicationEntry softwareEntry|

    path := self applicationRegistryPath.

    relPathName := path asStringWith:$\.

    applicationEntry := Win32OperatingSystem registryEntry key:'HKEY_CURRENT_USER\Software\',relPathName.

    applicationEntry isNil ifTrue:[

        softwareEntry := Win32OperatingSystem registryEntry key:'HKEY_CURRENT_USER\Software'.

        softwareEntry isNil ifTrue:[

            Transcript showCR: 'Failed to get Software entry in registry'.

            ^ nil.

        ].

        path do:[:subKey |

            |subEntry|

            subEntry := softwareEntry createSubKeyNamed:subKey.

            subEntry isNil ifTrue:[

                Transcript showCR: 'Failed to create ',subKey,' entry in registry'.

                ^ nil.

            ].

            softwareEntry := subEntry.

        ].

        applicationEntry := softwareEntry.

    ].

    ^ applicationEntry

!