"

 COPYRIGHT (c) 2012-2013 by Jan Vrany

              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:libscm/mercurial' }"

Object subclass:#HGCommandServer

	instanceVariableNames:'repositoryPath pid input output state readerwriter encoder

		channel_o channel_e channel_r channel_d channel_I channel_L

		channel_M command'

	poolDictionaries:''

	category:'SCM-Mercurial-Internal'

!

ReadStream subclass:#InputChannel

	instanceVariableNames:'server id lock rlock binary closed'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommandServer

!

WriteStream subclass:#OutputChannel

	instanceVariableNames:'server id lock rlock'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGCommandServer

!

!HGCommandServer class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 2012-2013 by Jan Vrany

              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.

"

! !

!HGCommandServer class methodsFor:'initialization'!

initialize

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

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

    Tracing := true.

! !

!HGCommandServer class methodsFor:'instance creation'!

new

    "return an initialized instance"

    ^ self basicNew initialize.

! !

!HGCommandServer class methodsFor:'* uncategorized *'!

trace

    ^Tracing

    "Created: / 03-03-2013 / 17:20:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer methodsFor:'accessing'!

repository:anHGRepository

    repositoryPath := anHGRepository pathName.

    "Modified: / 04-03-2013 / 10:03:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer methodsFor:'executing'!

execute: anHGCommand

    "Executes an HG command"

    | spin status blocker |

    command := anHGCommand.

    anHGCommand initialize.

    blocker := command blocker.

    anHGCommand workingDirectoryOrNil isNil ifTrue:[

        anHGCommand workingDirectory: repositoryPath 

    ].

    self runcommand: command.

    anHGCommand spawn: [ 

        status := OperatingSystem osProcessStatusClass pid:nil status: #exit code: channel_r nextLongNet core:false.

        channel_e close.

        channel_o close.

        command outputReader isNil ifTrue:[

            blocker signal

        ].

        command errorReader isNil ifTrue:[

            blocker signal

        ].

        Tracing ifTrue:[

            Logger log: 'cmdsrv: command finished' severity: #trace facility: 'HG'.

        ].

    ] name: 'command server result reader'.

    spin := SemaphoreSet with: blocker with: anHGCommand errors readSemaphore.

    [

        [ spin wait ~~ blocker ] whileTrue:[ anHGCommand signal ]

    ] ensure:[

        channel_e reset.

        channel_o reset.

    ].

    anHGCommand signal.

    command := nil.

    ^anHGCommand status: status result: anHGCommand result

    "Created: / 24-02-2013 / 15:10:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer methodsFor:'initialization'!

initialize

    "Invoked when a new instance is created."

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

    "/ repository := nil.

    "/ pid := nil.

    "/ input := nil.

    "/ output := nil.

    state := #disconnected.

    "/ readerwriter := nil.

    "/ encoder := nil.

    "/ channel_o := nil.

    "/ channel_e := nil.

    "/ channel_r := nil.

    "/ channel_d := nil.

    "/ channel_I := nil.

    "/ channel_L := nil.

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

    "Modified: / 24-02-2013 / 14:55:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer methodsFor:'private'!

arguments

    ^{

        HGCommand hgCommand .

"/        '--debug' . '--verbose'.

        '--cwd' . repositoryPath  .

        '--config' . 'ui.interactive=True' .

        'serve' .

        '--cmdserver' . 'pipe' .

    }

    "Created: / 24-02-2013 / 12:02:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 04-03-2013 / 10:05:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

channelWithId: channelId

    channelId == $o codePoint ifTrue:[

        ^ channel_o

    ].

    channelId == $e codePoint ifTrue:[

        ^ channel_e

    ].

    channelId == $r codePoint ifTrue:[

        ^ channel_r

    ].

    channelId == $d codePoint ifTrue:[

        ^ channel_d

    ].

    channelId == $I codePoint  ifTrue:[

        ^ channel_I

    ] .

    channelId == $L codePoint  ifTrue:[

        ^ channel_L

    ].

    channelId == $M codePoint ifTrue:[

        ^ channel_M

    ].

    self error: 'Invalid channel: ', channelId

    "Created: / 24-02-2013 / 12:59:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 03-03-2013 / 14:14:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

connect

    | label |

    state := #connecting.

    Tracing ifTrue:[

        Logger log: 'cmdsrv: connecting...' severity: #trace facility: 'HG'.

    ].

    label := channel_o next: 13.

    label = 'capabilities:' ifFalse:[

        HGCommandError raiseErrorString: 'Invalid hello message: ', label.

    ].

    channel_o nextLine.

    label := channel_o next: 9.

    label = 'encoding:' ifFalse:[

        HGCommandError raiseErrorString: 'Expected ''encoding:'' message, got: ''', label , ''''.

    ].

    encoder := CharacterEncoder encoderFor: (channel_o nextAvailable: 1000).

    state := #connected.

    Tracing ifTrue:[

        Logger log: 'cmdsrv: connected...' severity: #trace facility: 'HG'.

    ].

    "Created: / 24-02-2013 / 12:19:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 03-03-2013 / 23:25:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

runcommand: anHGCommand

    "Issue runcommand command to the server"

    | args argslen |

    args := OrderedCollection streamContents:[:s|

        anHGCommand workingDirectory notNil ifTrue:[

            s nextPut: '--cwd'; nextPut: anHGCommand workingDirectory.

        ].

        anHGCommand argumentsGlobalOn:s.

        s nextPut:anHGCommand command.

        anHGCommand argumentsCommandOn:s.

    ].

    argslen := args inject: -1 into: [:l :a|l + a size + 1].

    output 

        nextPutLine:'runcommand';

        nextPutLongNet: argslen.

    Tracing ifTrue:[

            Logger log: 'cmdsrv: runcommand: ' , (args asStringWith:Character space)  severity: #trace facility: 'HG'.

    ].

    args 

        do:[:e|output nextPutAll: (encoder encodeString: e)]

        separatedBy:[output nextPut: (Character codePoint: 0)].

    "Created: / 03-03-2013 / 16:38:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 03-03-2013 / 23:46:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

startReaderWriter

    "Initialize channels"

    channel_o := InputChannel id: $o server: self.

    channel_e := InputChannel id: $e server: self.

    channel_r := InputChannel id: $r server: self.

    channel_r binary.

    channel_d := InputChannel id: $d server: self.

    channel_I := OutputChannel id: $I server: self.

    channel_L := OutputChannel id: $L server: self.

    channel_M := OutputChannel id: $M server: self.

    readerwriter := [

            ].

        ].

    ] newProcess.

    readerwriter addExitAction:[

        readerwriter := nil.

        state := #disconnected.

    ].

    readerwriter name: 'HG Reader/Writer: ', repositoryPath .

    readerwriter resume.

    "Created: / 24-02-2013 / 12:47:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

update

    "Reads from input stream and updates corresponding channel"

    | channel len data id |

    input readWait.

    id := input next.

    channel := self channelWithId: id.

    (channel == channel_I or:[channel == channel_L]) ifTrue:[

        self shouldImplement.

    ].

    len := input nextUnsignedLongNet.

    data := input next: len.

    channel update: data encoder: encoder.

    command notNil ifTrue:[

        channel == channel_o ifTrue:[

            command spawnOutputReaderOn: channel_o

        ] ifFalse:[channel == channel_e ifTrue:[

            command spawnErrorReaderOn: channel_e

        ]].

    ].

    "Created: / 24-02-2013 / 14:06:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 04-03-2013 / 00:02:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer methodsFor:'start & stop'!

start

    "Starts the server and returns"

    | inputPipe outputPipe environment args |

    state := #starting.

    inputPipe := NonPositionableExternalStream makePipe.

    input := inputPipe first.

    input binary.

    outputPipe := NonPositionableExternalStream makePipe.

    output := outputPipe second.

"/    output binary.

    args := self arguments.

    OperatingSystem isMSWINDOWSlike ifTrue:[

        args := String streamContents:[:s|

            args

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

                separatedBy: [ s space ]

        ]

    ].

    environment := OperatingSystem isUNIXlike

                    ifTrue:[OperatingSystem getEnvironment copy]

                    ifFalse:[environment := Dictionary new].

    environment at: 'HGEDITOR' put: 'true'.

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

    Processor monitor:[

        pid := OperatingSystem exec:(HGCommand hgCommand) withArguments: args

                environment:environment

                fileDescriptors:{outputPipe first fileDescriptor . inputPipe second fileDescriptor . 3}

                fork:true

                newPgrp:false

                inDirectory: Filename currentDirectory pathName.

        Tracing ifTrue:[

            Logger log: 'cmdsrv: server started' severity: #trace facility: 'HG'.

        ].

        pid.

    ] action:[:stat |

        Tracing ifTrue:[

            Logger log: 'cmdsrv: server terminated' severity: #trace facility: 'HG'.

        ].

    ].

    inputPipe second close.

    outputPipe first close.

    pid isNil ifTrue:[

        HGCommandError raiseErrorString: 'Cannot start command server'.

        input close.

        output close.

        ^ self.

    ].

    encoder := CharacterEncoder encoderFor:#ascii.

    self startReaderWriter.

    self connect.

    "Created: / 24-02-2013 / 11:40:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

stop

    state == #disconnected ifFalse:[

        Tracing ifTrue:[

        ].

        state := #disconnecting.

        readerwriter terminate.

        input close.

        output close.

    ].

    "Created: / 24-02-2013 / 14:20:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer::InputChannel class methodsFor:'documentation'!

documentation

"

    An input channel (hg serve --> smalltalk)

    [author:]

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

    [instance variables:]

    [class variables:]

    [see also:]

"

! !

!HGCommandServer::InputChannel class methodsFor:'instance creation'!

id: id server: server

    ^self basicNew setId: id server: server

    "Created: / 24-02-2013 / 12:52:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer::InputChannel methodsFor:'accessing'!

id

    ^ id

!

readSemaphore

    ^rlock

    "Created: / 03-03-2013 / 16:40:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer::InputChannel methodsFor:'initialization'!

reset

    closed := false.

    collection := (binary == true ifTrue:[ByteArray] ifFalse:[String]) new: 100.

    position := 0.

    readLimit := 0.

    writeLimit := 0.

    "Created: / 03-03-2013 / 13:18:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 03-03-2013 / 15:35:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

setId: aCharacter server: anHGCommandServer    

    self reset.

    id := aCharacter.

    server := anHGCommandServer.

    lock := Semaphore forMutualExclusion.

    rlock := Semaphore new:0.

    binary := false.

    "Created: / 24-02-2013 / 12:51:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 03-03-2013 / 14:20:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGCommandServer::InputChannel methodsFor:'misc'!

binary

    "switch to binary mode. In binary mode, reading of text streams

     returns byte-valued integers instead of characters; writing expects

     byte-valued integers respectively.

     Ignored here, but added to make internalStreams protocol compatible 

     with externalStreams."

    binary := true.

    collection := collection asByteArray

    "Created: / 03-03-2013 / 14:20:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

close

    lock critical:[

        closed := true.