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

Object subclass:#HGCommand

	instanceVariableNames:'workingDirectory'

	classVariableNames:'HGExecutable HGVersion Debugging'

	poolDictionaries:''

	category:'SCM-Mercurial-Internal'

!

HGCommand subclass:#add

	instanceVariableNames:'paths'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#branches

	instanceVariableNames:'active closed'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#cat

	instanceVariableNames:'path revision'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#clone

	instanceVariableNames:'url path update'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#commit

	instanceVariableNames:'message files'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#heads

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#locate

	instanceVariableNames:'revision'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#log

	instanceVariableNames:'start stop'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#mv

	instanceVariableNames:'source destination'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#pull

	instanceVariableNames:'url'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#push

	instanceVariableNames:'url force'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#remove

	instanceVariableNames:'paths'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#status

	instanceVariableNames:'path'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#update

	instanceVariableNames:'revision'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

HGCommand subclass:#version

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommand

!

!HGCommand class methodsFor:'documentation'!

documentation

"

    A wrapper for hg command line tool. Individual commands are wrapped in 

    my private classes. 

    HGCommand is part of internal implementation and subject to change. 

    Therefore it should not be used by user code. Use classed and APIs in 

    SCM-Mercurial-Core instead.

    [author:]

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

    [instance variables:]

    [class variables:]

    [see also:]

"

! !

!HGCommand class methodsFor:'initialization'!

initialize

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

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

    "/ HGExecutable := nil.

    Debugging := OperatingSystem getLoginName = 'jv'.

    "Modified: / 12-11-2012 / 22:42:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommand class methodsFor:'accessing'!

hgCommand

    | h |

    HGExecutable notNil ifTrue:[

        ^ HGExecutable

    ].

    HGExecutable := UserPreferences current hgCommand.

    HGExecutable isNil ifTrue:[

        OperatingSystem isMSWINDOWSlike ifTrue:[

            "/        h := Win32OperatingSystem registryEntry 

            "/                key:'HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\App Paths\svn.exe'.

            "/        h notNil ifTrue:[HGExecutable := h valueNamed:''].

            "/        HGExecutable notEmptyOrNil ifTrue:[^HGExecutable]

            HGExecutable := OperatingSystem pathOfCommand:'hg'.

        ] ifFalse:[

            OperatingSystem isUNIXlike ifTrue:[

                HGExecutable := OperatingSystem pathOfCommand:'hg'.

            ]

        ].

    ].

    HGExecutable isNil ifTrue:[

        self error:'''hg'' executable not found!!'.

    ].

    ^ HGExecutable

    "

     HGExecutable := nil.

     self basicNew executable"

    "Created: / 19-11-2012 / 21:48:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 19-11-2012 / 23:21:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

hgCommand: command

    HGExecutable := command

    "Created: / 19-11-2012 / 21:49:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

hgVersion

    "Return mercurial version installed on this compiter"

    HGVersion isNil ifTrue:[

        HGVersion := version new execute

    ].

    ^ HGVersion

    "

     HGCommand mercurialVersion"

    "Created: / 19-11-2012 / 20:14:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

hgVersionIsSupported

    ^ self hgVersionIsSupported:self hgVersion

    "

     HGCommand mercurialVersionIsSupported"

    "Created: / 19-11-2012 / 20:34:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

hgVersionIsSupported:version 

    ^ self hgVersionsSupported 

        anySatisfy:[:vsn | 

            ((vsn at:1) == #'*' or:[ (vsn at:1) == (version at:1) ]) 

                and:[

                    ((vsn at:2) == #'*' or:[ (vsn at:2) == (version at:2) ]) 

                        and:[ ((vsn at:3) == #'*' or:[ (vsn at:1) == (version at:3) ]) ]

                ]

        ].

    "

     HGCommand mercurialVersionIsSupported: #(2 3 2)

     HGCommand mercurialVersionIsSupported: #(2 0 1)

     HGCommand mercurialVersionIsSupported: #(1 9 1)

     HGCommand mercurialVersionIsSupported: #(1 0 0)

     HGCommand mercurialVersionIsSupported: #(2 4 nil)"

    "Created: / 19-11-2012 / 20:31:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

hgVersionsSupported

    "Return a list of mercurial version supported bu this

     implementation"

    ^ #( #(1 9 #'*')

     #(2 #'*' #'*') )

    "Created: / 19-11-2012 / 20:26:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

verbose

    ^ UserPreferences current hgVerbose

    "Created: / 19-03-2008 / 12:29:47 / janfrog"

    "Modified: / 19-03-2009 / 14:00:50 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified (format): / 27-12-2011 / 16:00:06 / dundee"

    "Modified: / 17-10-2012 / 13:05:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

verbose:aBoolean

    UserPreferences current hgVerbose:aBoolean

    "Created: / 19-03-2008 / 12:29:59 / janfrog"

    "Modified: / 19-03-2009 / 14:00:59 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified (format): / 27-12-2011 / 16:00:13 / dundee"

    "Modified: / 17-10-2012 / 13:05:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommand class methodsFor:'commands'!

add

    ^add new

    "Created: / 15-11-2012 / 00:06:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

branches

    ^branches new

    "Created: / 27-11-2012 / 19:56:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

cat

    ^cat new

    "Created: / 17-11-2012 / 00:16:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

clone

    ^clone new

    "Created: / 01-10-2012 / 00:09:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

commit

    ^commit new

    "Created: / 12-11-2012 / 22:40:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

heads

    ^heads new

    "Created: / 27-11-2012 / 21:32:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

locate

    ^locate new

    "Created: / 16-11-2012 / 22:36:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

log

    ^log new

    "Created: / 13-11-2012 / 09:00:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

mv

    ^mv new

    "Created: / 15-11-2012 / 00:22:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

pull

    ^pull new

    "Created: / 27-11-2012 / 23:30:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

push

    ^push new

    "Created: / 30-09-2012 / 23:46:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

remove

    ^remove new

    "Created: / 15-11-2012 / 00:06:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

status

    ^status new

    "Created: / 23-10-2012 / 11:10:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

update

    ^update new

    "Created: / 21-11-2012 / 00:23:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommand class methodsFor:'commands-shortcuts'!

clone: url to: stringOfFilename

    self clone

        url: url;

        path: stringOfFilename asFilename asAbsoluteFilename pathName;

        execute

    "Created: / 01-10-2012 / 00:06:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommand methodsFor:'accessing'!

workingDirectory

    ^workingDirectory notNil ifTrue:[

        workingDirectory

    ] ifFalse: [

        Filename currentDirectory pathName

    ]

    "Created: / 11-05-2011 / 08:26:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 27-12-2011 / 15:54:08 / dundee"

    "Modified: / 01-10-2012 / 14:38:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

workingDirectory:aStringOrFilename

    aStringOrFilename asFilename isDirectory ifFalse:[

        self error:'Working directory does not exist'.

        ^self.

    ].    

    workingDirectory := aStringOrFilename asString.

    "Modified: / 01-10-2012 / 14:38:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommand methodsFor:'executing'!

execute

    | pipe output pid environment sema status retval args |

    pipe := NonPositionableExternalStream makePipe.

    output := pipe first.

    OperatingSystem isUNIXlike ifTrue:[

        environment := OperatingSystem getEnvironment copy.

    ] ifFalse:[

        environment := Dictionary new.

    ].

    environment at:'LANG' put:'C'.

    args := self arguments.

    OperatingSystem isMSWINDOWSlike ifTrue:[

        args := String streamContents:[:s|

            args 

                do:[:each | s nextPut:$"; nextPutAll: each; nextPut: $"]

                separatedBy: [ s space ]

        ]

    ].

    sema := Semaphore new name: 'Waiting for hg command to finish'.

    Processor monitor:[

        pid := OperatingSystem exec:(self executable) withArguments:args

            environment:environment

            fileDescriptors:{0 . pipe second fileDescriptor . pipe second fileDescriptor}

            fork:true 

            newPgrp:false 

            inDirectory:self workingDirectory

    ] action:[:stat |

        status := stat.

        sema signal.

    ].

    pipe second close.

    pid isNil ifTrue:[

        HGCommandError raiseErrorString: 'cannot execute hg command'.

        output close.

        ^ self.

    ].

    (Debugging and:[OperatingSystem isUNIXlike]) ifTrue:[

        output := output contents asString readStream

    ].

    retval := self parse: output.

    sema wait.

    ^self status: status result: retval

    "

        SVNv2::Command info: 'https://swing.fit.cvut.cz/svn/stx/libsvn'

    "

    "Created: / 11-05-2011 / 07:45:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 17-12-2011 / 19:22:00 / dundee"

    "Modified (format): / 27-12-2011 / 15:53:54 / dundee"

    "Modified: / 14-11-2012 / 13:41:57 / jv"

    "Modified: / 22-11-2012 / 23:55:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommand methodsFor:'private'!

arguments

    ^ OrderedCollection streamContents:[:s |

        s nextPut:self executable.

        self argumentsGlobalOn:s.

        s nextPut:self command.

        self argumentsCommandOn:s.

    ].

    "Created: / 11-05-2011 / 07:58:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 27-12-2011 / 15:47:23 / dundee"

!

argumentsCommandOn:stream

    "Called to get command specific options"

    self subclassResponsibility

    "Created: / 11-05-2011 / 07:58:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 27-12-2011 / 15:46:59 / dundee"

    "Modified: / 16-11-2012 / 22:31:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

argumentsGlobalOn:arg

    "Called to get global options"

    "Created: / 11-05-2011 / 07:58:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 27-12-2011 / 15:47:10 / dundee"

    "Modified: / 30-09-2012 / 23:43:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

command

    "Returns the git 'command' option, i.e. commit,

     push, pull, ..."

    ^self class nameWithoutPrefix

    "

        HGCommand::push basicNew command

    "

    "Created: / 11-05-2011 / 07:58:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 27-12-2011 / 15:47:17 / dundee"

    "Modified: / 30-09-2012 / 23:37:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (comment): / 17-10-2012 / 13:25:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

executable

    ^ self class hgCommand

    "Modified: / 19-11-2012 / 21:48:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

parse: stream

    "Parses output of 'hg' command, i.e. commit, log, update, checkout, 

     etc."