"

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

Copyright (C) 2012-2015 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' }"

"{ NameSpace: Smalltalk }"

Object subclass:#HGRepository

	instanceVariableNames:'uuid path wc changesets branches heads bookmarks bookmark config

		colors 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-2015 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

    Cache := CacheDictionary new: 8.

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

!

useCommandServer

    |useCommandServer|

    UseCommandServer isNil ifTrue:[

        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'!

init: aStringOrFilename

    "Create a new repository in given directory and

     return HGRepository for it"

    | dir |

    dir := aStringOrFilename asFilename.

    dir exists ifTrue:[ 

        dir isDirectory ifTrue:[ 

            dir directoryContents notEmpty ifTrue:[ 

                HGRepositoryError raiseErrorString: 'Directory exists but not empty'.  

                ^ self.

            ].

        ] ifFalse:[ 

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

            ^ self.

        ].

    ].

    HGCommand init

        path: dir;

        execute.

    ^self on: dir.

    "Created: / 13-02-2014 / 12:38:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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.

    ^self on: dst.

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

    "Modified: / 13-02-2014 / 12:40:59 / 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 the presence of .hg directory"

    | f parent |

    f := aStringOrFilename.

    f isDirectory ifFalse:[

        f := f directory

    ].

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

        "/ f pathName errorPrintCR.

        f isRootDirectory ifTrue:[^ nil].

        parent := f directory.

        "/ workaround: a network/shared folder seems to be not detected

        "/ as a root folder in a VM.

        parent pathName = f pathName ifTrue:[^ nil].

        f := parent.

    ].

    ^ 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'!

bookmark

    "Returns currently active bookmark or nil if none is active"

    | name |    

    bookmark isNil ifTrue:[

        bookmark := HGCachedFileData

                        on: ((Filename named: self pathName) / '.hg' / 'bookmarks.current')

                        reader:[:old :file |

                            | nm |

                            nm := nil.

                            file exists ifTrue:[ 

                                file readingFileDo:[:s| nm := s nextLine ].

                            ].

                            nm.

                        ].

        bookmark setData: nil

    ].

    name := bookmark value.

    name isNil ifTrue:[ ^ nil ].

    ^ self bookmarks detect:[:e | e name = name ].

    "Created: / 20-03-2014 / 17:31:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

bookmarks

    "Returns a list of bookmarks in the repository"

    bookmarks isNil ifTrue:[

        bookmarks := HGCachedFileData

                        on: ((Filename named: self pathName) / '.hg' / 'bookmarks')

                        reader:[:old :file |

                            | new newMap obsolete |

                            file exists ifTrue:[ 

                                file readingFileDo:[:s|

                                    new := (HGCommandParser on: s) parseDotHgBookmarks.

                                ].

                            ] ifFalse:[ 

                                new := #().

                            ].

                            newMap := Dictionary new.

                            new do:[:eachNew | 

                                newMap at: eachNew name put: eachNew

                            ].

                            obsolete := Set new.

                            "/ Iterate over existing bookmarks. If new set of bookmarks includes

                            "/ it, then update changeset and remove from new. If not, add it into

                            "/ obsolete.

                            old do:[:eachOld | 

                                | eachNew |

                                eachNew := newMap at: eachOld ifAbsent: nil.

                                eachNew notNil ifTrue:[ 

                                    eachOld setChangesetId: eachNew changesetId.

                                    new remove: eachNew.

                                ] ifFalse:[ 

                                    obsolete add: eachOld.

                                ].

                            ].

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

                            old removeAll: obsolete.

                            old addAll: new.

                            old.

                        ].

        bookmarks setData: OrderedCollection new.

    ].

    ^bookmarks value

    "Created: / 20-03-2014 / 02:13:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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

!

changesetsMatching: revset limit: limit

    "Returns a list of changesets that matches given revset, but not more than

     `limit` changesets.

    revset could be either HGRevset or plain string.

    limit is an integer or nil for not limit at all (use vit caution

    on large repositories this may take a while)

    "

    ^changesets changesetsMatching: revset limit: limit

    "Created: / 07-02-2014 / 13:08:28 / 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