"

"

"{ Package: 'stx:libscm/mercurial' }"

StandaloneStartup subclass:#HGInstaller

	instanceVariableNames:'version destination archive'

	classVariableNames:'URLs RunningStandalone SeverityError SeverityWarning SeverityInfo'

	poolDictionaries:''

	category:'SCM-Mercurial-StX-Installer'

!

!HGInstaller class methodsFor:'documentation'!

copyright

"

"

!

documentation

"

    A simple standalone installer for Mercurial support. It downloads

    and installs Mercurial support into Smalltalk/X IDE.

    Usage (command line):

        # install latest stable version

        stx --execute HGInstaller.st 

        # install latest development version                             

        stx --execute HGInstaller.st --version default

        # install Mercurial for manually downloaded archive

        stx --execute HGInstaller.st --archive downloaded-archive.zip

    Usage (workspace)

        # install latest stable version

        HGInstaller install

        # install latest development version                             

        HGInstaller install: #default

   [author:]

        Jan Vrany <jan.vrany@fit.cvut.cz>

    [instance variables:]

    [class variables:]

    [see also:]

"

! !

!HGInstaller class methodsFor:'initialization'!

initialize

    "Invoked at system start or when the class is dynamically loaded."

    Smalltalk loadPackage:#'stx:goodies/communication'.

    self initializeURLs.

    SeverityError := #error.

    SeverityWarning := #warning.

    SeverityInfo := #info.

    (RunningStandalone := Smalltalk commandName endsWith: (self name , '.st')) ifTrue:[

        self start 

    ]

    "Modified: / 09-07-2013 / 01:22:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

initializeURLs

    URLs := Array

                "/ Primary repository

                with: 'https://bitbucket.org/janvrany/stx-libscm/get' asURI     

                "/ Mirros

                with: 'http://swing.fit.cvut.cz/hg/stx.libscm/archive' asURI

    "Created: / 09-07-2013 / 00:27:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller class methodsFor:'instance creation'!

new

    "return an initialized instance"

    ^ self basicNew initialize.

! !

!HGInstaller 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)"

    ^ false

    "Created: / 11-07-2013 / 01:37:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

allowDebugOption

    "enable/disable the --debug startup option.

     Can be redefined in subclasses to enable it"

    ^ true

    "Created: / 07-07-2013 / 18:46:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

allowScriptingOption

    "enable/disable the --scripting startup option.

     Can be redefined in subclasses to enable it"

    ^ true

    "Created: / 07-07-2013 / 18:46:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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"

    ^ true

    "Created: / 07-07-2013 / 18:46:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller class methodsFor:'helpers'!

printInfo:msg

    Transcript 

        show:'[INFO]: ';

        showCR:msg

    "Created: / 07-07-2013 / 18:48:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller class methodsFor:'installer API'!

install

    "Installs latest 'default' version of Mercurial support"

    ^self new install

    "Created: / 07-07-2013 / 10:56:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

install: rev

    "Installs given revision of Mercurial support"

    ^self new install: rev

    "Created: / 07-07-2013 / 10:56:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller class methodsFor:'startup'!

main:argv

    "superclass StandaloneStartup class says that I am responsible to implement this method"

    ^self new main: argv

    "Modified: / 07-07-2013 / 18:26:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 07-07-2013 / 22:00:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

usage

    Stderr nextPutLine:'stx:libscm installation script'; cr.

    Stderr nextPutLine:'usage: stx --execute HGInstaller.st [options...]'.

    Stderr nextPutLine:'  --version REV ........... specifies which version to install. REV can be'.

    Stderr nextPutLine:'                            branch, tag or commit id.'.

    Stderr nextPutLine:'  --archive FILE .......... specifies an archive file to install. If ommited'.

    Stderr nextPutLine:'                            archive is donwloaded'.

    Stderr nextPutLine:'  --help .................. output this message'.

"/    Stderr nextPutLine:'  --verbose ............... verbose startup'.

"/    Stderr nextPutLine:'  --noBanner .............. no splash screen'.

"/    Stderr nextPutLine:'  --newAppInstance ........ start as its own application process (do not reuse a running instance)'.

"/    self allowScriptingOption ifTrue:[

"/        Stderr nextPutLine:'  --scripting portNr ...... enable scripting via port (or stdin/stdOut, if 0)'.

"/    ].

    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,')'.

    ].

    Stderr cr.

    Stderr nextPutLine:'For more information see wiki:'.

    Stderr nextPutLine:'  https://bitbucket.org/janvrany/stx-libscm/wiki/Installation'.

    Stderr cr.

    Smalltalk exit: 0

    "Created: / 11-07-2013 / 01:36:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller class methodsFor:'startup-private'!

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

    ^ #(libscm mercurial installer)

    "Modified: / 07-07-2013 / 18:24:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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

    ^ UUID fromString:'132746c0-e72a-11e2-85f0-606720e43e2c'

    "Modified: / 07-07-2013 / 18:24:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller methodsFor:'initialization'!

initialize

    "Invoked when a new instance is created."

    "/ please change as required (and remove this comment)

    version := 'default'.

    "/ super initialize.   -- commented since inherited method does nothing

    "Modified: / 07-07-2013 / 11:11:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller methodsFor:'installation'!

install

    self doPrepare.

    self doDownload.

    self doExtract.

    self doCompile.

    self doConfigure.

    "Created: / 07-07-2013 / 11:07:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 07-07-2013 / 19:06:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

install: ver

    version := ver.

    self install.

    "Created: / 07-07-2013 / 11:08:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller methodsFor:'installation-private'!

doCompile

    | cmd |

    cmd := OperatingSystem isMSWINDOWSlike ifTrue:[ 'bmake.bat'] ifFalse:['make'].

    ( destination directory / 'stc' ) exists ifTrue:[

        | log |

        log := Filename newTemporaryIn: Filename tempDirectory nameTemplate:'compile-%1-%2.log'.            

        log writingFileDo:[:logs|

            Transcript nextPutAll: 'Compiling...'; cr.

            (OperatingSystem executeCommand: cmd outputTo: logs errorTo: logs inDirectory: destination pathName) ifFalse:[

                self log: 

                        'Compilation failed' 

                     details:

                        'This is not fatal, but the package will be loaded from source

                         instead of from binary class library, which is slower. 

                         You may want to check the compilation log in:

                         ', log pathName

                    severity: SeverityWarning.

            ].

            (OperatingSystem executeCommand: (cmd , ' clean') outputTo: logs errorTo: logs inDirectory: destination pathName) ifFalse:[

                self log: 

                        'Compilation failed' 

                     details:

                        'This is not fatal, but the package will be loaded from source

                         instead of from binary class library, which is slower. 

                         You may want to check the compilation log in:

                         ', log pathName

                    severity: SeverityWarning.    

             ].

        ]

    ].

    "Created: / 07-07-2013 / 18:50:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 09-07-2013 / 01:30:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doConfigure

    | top rcd |

    Transcript nextPutLine: 'Configuring...'.

    top := (Smalltalk getPackageDirectoryForPackage: Object package) directory directory.

    rcd := top / 'stx'/ 'projects' / 'smalltalk' / 'rc.d'.

    rcd isDirectory ifTrue:[

        (rcd / '50_mercurial.rc') writingFileDo:[:s|

            s nextPutLine:'"/ Load Mercurial support'.

            top = destination directory directory ifFalse:[

                s nextPutLine: ('Smalltalk packagePath: (Smalltalk packagePath: %1).' bindWith: destination directory directory pathName).        

            ].

            s nextPutAll:'Smalltalk loadPackage: ''stx:libscm/mercurial''.'.    

        ].            

    ] ifFalse:[

    ].

    "Created: / 07-07-2013 / 11:19:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 11-07-2013 / 01:41:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doDownload

    | urls1 urls2 |

    archive notNil ifTrue:[ ^ self ].

    archive := Filename newTemporary.

    Transcript nextPutAll:'Downloading...'; cr.

    urls1 := URLs select: [:url|url scheme = 'http'].

    urls2 := URLs reject: [:url|url scheme = 'http'].

    (( urls1 , urls2 )  anySatisfy:[:base|

        | downloaded url|

        url := base / (version , '.zip').

        Transcript nextPutAll:'  '; nextPutAll: url asString; nextPutAll: '...'.

        downloaded := self doDownload: url.

        Transcript nextPutAll: (downloaded ifTrue:['OK'] ifFalse:['FAILED']); cr.

        downloaded                        

    ]) ifFalse:[

        self error:'Failed to download archive!!'.

    ].

    (ZipArchive isZipArchive: archive) ifFalse:[

        self error: ('Downloaded file (%1) is not a .zip archive!!' bindWith: archive pathName).

    ].  

    "/    ]

    "Created: / 07-07-2013 / 11:19:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 11-07-2013 / 01:40:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doDownload: url

    "Download a given file and save it into `archive` 

     Return true, if the file has been downloaded, false otherwise"

    (url scheme = 'http' and:[HTTPInterface notNil]) ifTrue:[

        | client response |

        client := HTTPInterface connectTo: url host port: (url port ? 80).

        client destinationFile: archive.

        response := client requestGET: url asString.

        ^response isErrorResponse not 

            and:[response isFileErrorResponse not 

            and:[response isMovedResponse not]]

    ].

    (url scheme = 'https' or:[HTTPInterface isNil]) ifTrue:[    

        | cmd |

        (OperatingSystem canExecuteCommand:'curl') ifTrue:[

            cmd := 'curl -s -o %1 %2' bindWith:archive pathName with:url.

        ] ifFalse:[

            (OperatingSystem canExecuteCommand:'wget') ifTrue:[

                cmd := 'wget -s -o %1 %2' bindWith:archive pathName with:url.

            ] ifFalse:[

                ^false.

            ].

        ].

        ^ OperatingSystem executeCommand:cmd

    ].

    ^false "Unssuported protocol"

    "Created: / 09-07-2013 / 00:23:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doExtract

    | zar |

    [

        destination recursiveMakeDirectory.

    ] on:Error

            do:[:ex | 

        self 

            error:'Cannot make destination directory ' , destination pathName , ': ' 

                    , ex description

    ].

    zar := ZipArchive oldFileNamed:archive pathName.

    zar members do:[:zmemb | 

        | i  src  dst  dstd skipIt |

        src := zmemb fileName.

        i := src indexOf:$/.

        i ~~ 0 ifTrue:[

            src := src copyFrom:i + 1.

        ].

        skipIt ifFalse:[

           dst := OperatingSystem isMSWINDOWSlike 

                   ifTrue:[destination / (src copyReplaceAll:$/ with:Filename separator)]

                   ifFalse:[destination / src].

           (dstd := dst directory) exists ifFalse:[

               dstd recursiveMakeDirectory

           ].

           dst writingFileDo:[:f | 

               zar extract:zmemb fileName intoStream:f 

           ].

        ].

    ].

    "Created: / 07-07-2013 / 11:19:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doPrepare

    | pp |

    pp := Smalltalk getPackageDirectoryForPackage:'stx:libscm'.

    pp isNil ifTrue:[

        pp := Smalltalk getPackageDirectoryForPackage:'stx:libbasic'.

    ].

    destination := pp directory isWritable 

                    ifTrue:[pp directory / 'libscm']

                    ifFalse:[Filename homeDirectory / '.stx' / 'packages' / 'stx' / 'libscm'].

    Transcript nextPutLine: 'Installing version ', version , ' to ', destination pathName.

    "Created: / 07-07-2013 / 19:06:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGInstaller methodsFor:'logging'!

log:message details: details severity:severity 

    | stream |

    (severity == SeverityInfo and:[Verbose not]) ifTrue:[ ^ self ].

    stream := RunningStandalone ifTrue:[Stderr] ifFalse:[Transcript].

    stream

        nextPut:$[;

        nextPutAll:severity asUppercase;

        nextPutAll:']: ';

        nextPutLine:message.

    details notNil ifTrue:[

        details asStringCollection do:[:line | 

            stream

                nextPutAll:'  ';

                nextPutLine:line trimSeparators.

        ]

    ].

    severity == SeverityError ifTrue:[

        RunningStandalone ifTrue:[

            Smalltalk exit:1.

        ] ifFalse:[

            self error:message

        ]

    ].

    "Created: / 07-07-2013 / 23:23:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 08-07-2013 / 00:27:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

log:message severity:severity 

    self log:message details: nil severity:severity

    "Created: / 07-07-2013 / 23:34:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !