"

stx:libscm - a new source code management library for Smalltalk/X

Copyright (C) 2012-2013 Jan Vrany

This library is free software; you can redistribute it and/or

modify it under the terms of the GNU Lesser General Public

License as published by the Free Software Foundation; either

version 2.1 of the License. 

This library is distributed in the hope that it will be useful,

but WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public

License along with this library; if not, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

"

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

Object subclass:#HGRepository

	instanceVariableNames:'uuid path wc changesets branches heads config lock server'

	classVariableNames:'Cache UseCommandServer'

	poolDictionaries:''

	category:'SCM-Mercurial-Core'

!

HGRepositoryObject subclass:#Changesets

	instanceVariableNames:'changesets revno2nodeIdMap'

	classVariableNames:''

	poolDictionaries:''

	privateIn:HGRepository

!

!HGRepository class methodsFor:'documentation'!

copyright

"

stx:libscm - a new source code management library for Smalltalk/X

Copyright (C) 2012-2013 Jan Vrany

This library is free software; you can redistribute it and/or

modify it under the terms of the GNU Lesser General Public

License as published by the Free Software Foundation; either

version 2.1 of the License. 

This library is distributed in the hope that it will be useful,

but WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public

License along with this library; if not, write to the Free Software

Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

"

! !

!HGRepository class methodsFor:'initialization'!

flush

    "Flush all cached repositories"

    Cache := CacheDictionary new: 8

    "Created: / 25-01-2013 / 18:58:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

initialize

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

    | useCommandServer |

    Cache := CacheDictionary new: 8.

    useCommandServer := OperatingSystem getEnvironment: 'STX_LIBSCM_MERCURIAL_USE_COMMAND_SERVER'.

    useCommandServer isNil ifTrue:[

        UseCommandServer := false.  

    ] ifFalse:[

        UseCommandServer := (useCommandServer = '1').

    ]

    "Modified: / 09-03-2013 / 22:21:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGRepository class methodsFor:'instance creation'!

on: aStringOrFilename

    ^self on: aStringOrFilename cached: false

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

    "Modified: / 16-12-2012 / 12:59:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

on: aStringOrFilename cached: cache

    | path |

    path := aStringOrFilename asFilename.

    ^cache ifTrue:[

        Cache at: path ifAbsentPut:[self new initializeOn: path]

    ] ifFalse:[

        self new initializeOn: path

    ]

    "Created: / 16-12-2012 / 12:58:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGRepository class methodsFor:'cloning'!

clone: aFilenameOrUrlOrString to: aStringOrFilename

    "Clones repository at given URL to given directory.

     Returns an instance HGRepository representing the clone."

    ^self clone: aFilenameOrUrlOrString to: aStringOrFilename update: true

    "Created: / 14-11-2012 / 22:46:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

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

!

clone: aFilenameOrUrlOrString to: aStringOrFilename update: update

    "Clones repository at given URL to given directory.

     Returns an instance HGRepository representing the clone."

    | url dst dir |

    url := aFilenameOrUrlOrString asString.

    dst := aStringOrFilename asFilename.

    dst exists ifTrue:[

        HGError raiseErrorString: 'Cannot clone to existsing directory!!'.

        ^nil

    ].

    dir := dst directory.

    dir exists ifFalse:[

        HGError raiseErrorString: 'Directory for clone does not exist!!'.

        ^nil

    ].

    dir isWritable ifFalse:[

        HGError raiseErrorString: 'Cannot clone into write-protected directory'.

        ^nil

    ].

    HGCommand clone

        url: url;

        path: dst pathName;

        update: update;

        execute.

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

! !

!HGRepository class methodsFor:'utilities'!

discover: aStringOrFilename

    "Find a Mercurial repository in given directory or super-directories

     and return it (as an instance of Filename). If no repository is found, 

     returns nil.

     Currently, it searches for presence of .hg directory"

    | f |

    f := aStringOrFilename.

    f isDirectory ifFalse:[

        f := f directory

    ].

    [ ( f / '.hg' ) exists ] whileFalse:[

        f isRootDirectory ifTrue:[ ^nil ].

        f := f directory.

    ].

    ^f

    "Created: / 13-11-2012 / 22:34:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 14-11-2012 / 00:02:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

discoverPackage: packageId

    "Find a Mercurial repository in current package path for given package id.

     and return it (as an instance of Filename). If no repository is found, 

     returns nil."

    | pkg pkgDir i |

    pkg := packageId.

    [ pkg notNil ] whileTrue:[

        pkgDir := Smalltalk getPackageDirectoryForPackage: pkg.

        (pkgDir notNil and:[(HGRepository discover: pkgDir) notNil]) ifTrue:[

            ^self discover: pkgDir

        ].

        i := pkg lastIndexOf: $/.

        i == 0 ifTrue:[ i := pkg lastIndexOf: $: ].

        i > 1 ifTrue:[pkg := pkg copyTo: i - 1] ifFalse:[pkg := nil].

    ].

    ^nil

    "Modified: / 14-11-2012 / 00:02:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Created: / 04-07-2013 / 02:15:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGRepository methodsFor:'accessing'!

branches

    "Returns a list of named branches in the repository,

     including closed ones"

    branches isNil ifTrue:[

        branches := HGCachedFileData

                        on: ((Filename named: self pathName) / '.hg' / 'store' / '00changelog.i')

                        reader:[:old |

                            | rbranches current names |

                            rbranches := old.

                            current := self execute:

                                        (HGCommand branches

                                            workingDirectory: path pathName;

                                            active: false;

                                            closed: true;

                                            yourself).

                            names := rbranches collect:[:b|b name].

                            current := current ? #() reject:[:b|names includes: b name].

                            current do:[:b|b setRepository: self].

                            rbranches addAll: current.

                            rbranches isEmpty ifTrue:[

                                rbranches add: (HGBranch new setName: 'default'; setRepository: self).

                            ].

                            rbranches.

                        ].

        branches setData: OrderedCollection new.

    ].

    ^branches value

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

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

!

config

    ^config

    "Created: / 06-12-2012 / 21:40:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

heads

    "Returns a list of heads (as HGChangeset)"

    heads isNil ifTrue:[

        heads := HGCachedFileData

                        on: ((Filename named: self pathName) / '.hg' / 'store' / '00changelog.i')

                        reader:[

                            | ids |

                            ids := self execute: HGCommand heads.

                            ids collect:[:id|self changesetWithId: id].

                        ].                                

    ].

    ^heads value.

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

    "Modified: / 03-03-2013 / 22:53:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

path

    "Return path to the repository (directory with .hg store)"

    ^ path

    "Modified (comment): / 13-11-2012 / 18:18:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

pathName

    "Return path to the repository (directory with .hg store)"

    ^ path pathName

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

!

remoteDefault

    "Return default remote (upstream) repository or nil if none"

    ^self remotes detect:[:e|e isDefault] ifNone:[nil]

    "Created: / 10-12-2012 / 01:26:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

remotes

    "Returns a collection of configured remote (upstream) repositories"

    | paths remotes |

    paths := self config get: #paths default: nil.

    paths isNil ifTrue:[ ^ #() ].

    paths isEmpty ifTrue:[ ^ #() ].

    remotes := OrderedCollection new.

    paths keysAndValuesDo:[:name :url|

        remotes add: (HGRemote new setRepository: self; setName: name url:url value).

    ].

    ^remotes

    "Created: / 09-12-2012 / 22:51:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

uuid

    "Returns unique ID identifing this concrete instance

     of a repository"

    ^ uuid

    "Modified (comment): / 14-11-2012 / 23:22:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

workingCopy

    wc isNil ifTrue:[

	wc := HGWorkingCopy new setRepository: self.

    ].

    ^wc

    "Created: / 19-10-2012 / 15:42:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGRepository methodsFor:'accessing-changesets'!

@ id

    ^self changesetWithId: id.

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

!

changesetWithId: id

    ^changesets changesetWithId: id

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

! !

!HGRepository methodsFor:'accessing-private'!

branchWithName: name 

    "Returns branch with given name. If there is no such branch,

     an exception is raised"

    ^self branchWithName: name ifAbsent:[

        HGNoSuchBranchError newException

            parameter: name;

            messageText: 'No such branch: ', name;

            raiseSignal

    ]

    "Created: / 27-11-2012 / 13:55:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

branchWithName: name createIfAbsent: create

    ^self branchWithName: name ifAbsent:[

        | b |

        b := HGBranch new setRepository: self.

        b setName: name.

        branches value add: b.

        b

    ]

    "Created: / 10-12-2012 / 03:14:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 01-02-2013 / 13:39:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

branchWithName: name ifAbsent: block

    ^self branches detect:[:b|b name = name] ifNone: block

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

!

changesetWithId: id into: cs

    ^changesets load: id into: cs

    "Created: / 16-12-2012 / 01:26:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 22-01-2013 / 20:56:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

lock

    ^lock

    "Created: / 16-12-2012 / 00:39:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGRepository methodsFor:'initialize & release'!

initializeOn: aStringOrFilename

    | p |

    p := aStringOrFilename asFilename.

    p exists ifFalse:[

        HGRepositoryError raiseSignal: 'Given path does not exists'.

        ^nil.

    ].

    p isDirectory ifFalse:[

        HGRepositoryError raiseSignal: 'Given path is not a directory'.

        ^nil.

    ].

    (p / '.hg') isDirectory ifFalse:[

        HGRepositoryError raiseSignal: 'Given path does not contain a repository (.hg subdir not found - try use #lookup:)'.

        ^nil.

    ].

    path := p.

    changesets := HGRepository::Changesets new setRepository: self.

    uuid := UUID new.

    config := HGConfig new setRepository: self.

    lock := RecursionLock new.

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

    "Modified: / 25-01-2013 / 18:51:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!HGRepository methodsFor:'operations'!

cloneTo: aStringOrFilename

    "Creates a clone of the receiver into given directory.

     Returns an instance HGRepository representing the clone."

    ^self class clone: path to: aStringOrFilename

    "Created: / 14-11-2012 / 22:43:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

cloneTo: aStringOrFilename update: update

    "Creates a clone of the receiver into given directory.

     Returns an instance HGRepository representing the clone.

     If update is true, repository working copy is updated, otherwise

     it's left empty"

    ^self class clone: path to: aStringOrFilename update: update

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

!

execute: anHGCommand

    anHGCommand workingDirectoryOrNil isNil ifTrue:[

        anHGCommand workingDirectory: path

    ].

    "The command server does not work on Windows because readWait is

     broken on Windows!!"

    ^(UseCommandServer and:[OperatingSystem isMSWINDOWSlike not]) ifTrue:[

        server isNil ifTrue:[

            server := HGCommandServer new repository: self.

            server start.

        ].

        server execute: anHGCommand

    ] ifFalse:[

        anHGCommand execute

    ]

    "Created: / 03-03-2013 / 22:52:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 06-03-2013 / 11:14:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

pull

    "Pulls changesets from default upstream repository.

     See .hg/hgrc, section path"

    ^self pull: nil

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

    "Modified: / 04-02-2013 / 15:31:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

pull: remote

    "Push changesets to given remote repository. 'remote' can be either 

     an instance HGRemote, an instance of URL or a String (remote alias).