Changed license to LGPL2.
"
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.
^HGRepository on: dst.
"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).
If 'remote' nil, default upstream repository is used, '
See .hg/hgrc, section for configured aliases"
^self execute:
(HGCommand pull
url: (remote ? 'default') asString;
yourself)
"Created: / 04-02-2013 / 15:30:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 03-03-2013 / 22:53:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
push
"Pushes changesets to default upstream repository.
See .hg/hgrc, section path"
^self push: nil force: false
"Created: / 15-11-2012 / 09:59:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 27-11-2012 / 21:58:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
push: remote
"Push changesets to given remote repository. 'remote' can be either
an instance HGRemote, an instance of URL or a String (remote alias).
If 'remote' nil, default upstream repository is used, '
See .hg/hgrc, section for configured aliases"
^self push: remote force: false
"Created: / 15-11-2012 / 10:00:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 27-11-2012 / 21:59:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (comment): / 04-02-2013 / 15:31:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
push: remote force: force
"Push changesets to given remote repository. 'remote' can be either
an instance HGRemote, an instance of URL or a String (remote alias)'
If force is true, push is forced (allowing creation
of new heads in remote repo),
See .hg/hgrc, section path"
^self execute:
(HGCommand push
workingDirectory: path pathName;
url: (remote ? 'default') asString;
force: force;
yourself)
"Created: / 27-11-2012 / 21:58:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 03-03-2013 / 22:54:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGRepository methodsFor:'synchronized evaluation'!
synchronizationSemaphore
^lock
"Created: / 16-12-2012 / 00:40:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
synchronizationSemaphore: aRecursionLock
lock := aRecursionLock
"Created: / 16-12-2012 / 00:40:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGRepository::Changesets class methodsFor:'documentation'!
documentation
"
A simple object to maintain and load changesets metadata lazily.
[author:]
Jan Vrany <jan.vrany@fit.cvut.cz>
[instance variables:]
[class variables:]
[see also:]
"
! !
!HGRepository::Changesets class methodsFor:'instance creation'!
new
"return an initialized instance"
^ self basicNew initialize.
! !
!HGRepository::Changesets methodsFor:'accessing'!
changesetWithId: idobj
| id xid cs |
id := idobj asHGChangesetId.
id = HGChangesetId null ifTrue:[ ^ HGChangeset null].
"/Try to translate it...
id hasRevnoOnly ifTrue:[
xid := revno2nodeIdMap at: id revno ifAbsent:[nil].
].
xid := xid ? id.
"/Look in cache using xlated id...
cs := changesets at: xid ifAbsent:[ nil ].
cs notNil ifTrue: [ ^ cs ].
self synchronized:[
"/Look in cache using xlated id...
cs := changesets at: xid ifAbsent:[ nil ].
cs notNil ifTrue: [ ^ cs ].
cs := (xid isFull and:[xid hasRevno]) ifTrue:[
"/Full id, can make it lazy
HGChangeset new setId: xid; setRepository: repository
] ifFalse:[
"/Short id, we have to load it
self load: xid into: nil
].
self assert: cs id isFull.
self assert: cs id hasRevno.
changesets at: cs id put: cs.
revno2nodeIdMap at: cs id revno put: cs id.
].
^cs .
"Created: / 13-11-2012 / 17:52:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (format): / 08-03-2013 / 19:54:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGRepository::Changesets methodsFor:'initialization'!
initialize
"Invoked when a new instance is created."
"/ please change as required (and remove this comment)
changesets := Dictionary new.
revno2nodeIdMap := Dictionary new.
"/ super initialize. -- commented since inherited method does nothing
"Modified: / 16-11-2012 / 21:58:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGRepository::Changesets methodsFor:'private'!
load: id into: changesetOrNil
"Load all data for changeset with given id.
If changesetOrNil is not nil, then update given
changeset.
Return changeset with filled data, i.e,, changeset is
non-lazy"
| csets cs |
csets := self repository execute:
(HGCommand log
workingDirectory: repository path asString;
revsets: (self loadRevsetsForLoad: id);
yourself).
"/just to be defensive...
csets do:[:each|
| existing |
each setRepository: repository.
existing := changesets at: each id ifAbsentPut:[each].
existing ~~ each ifTrue:[
existing setSlotsFrom: each.
existing setNonLazy.
self assert: existing id isShort not.
self assert: existing id revno notNil.
self assert: existing loaded.
].
existing id = id ifTrue:[
cs := existing
].
].
self assert: cs notNil.
^cs
"Created: / 16-12-2012 / 00:57:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 03-03-2013 / 22:58:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
loadRevsetsForLoad: id
| revsets ids start stop addId |
revsets := OrderedCollection new.
ids := changesets keys asOrderedCollection sort: [:a :b|a revno > b revno].
addId := true.
ids do:[:each| | cs |
cs := changesets at: each.
cs loaded ifFalse:[
start isNil ifTrue:[
start := stop := each.
each = id ifTrue:[
addId := false
].
] ifFalse:[
each revno < (start revno - 20) ifTrue:[
revsets add: (start revno printString , ':' , (start revno - 20) printString).
start := stop := each.
] ifFalse:[
each = id ifTrue:[
addId := false
].
stop := each.
].
]
] ifTrue:[
start notNil ifTrue:[
start ~~ stop ifTrue:[
revsets add: (start revno printString , ':' , stop revno printString).
] ifFalse:[
revsets add: start revno printString
].
].
start := stop := nil.
]
].
start notNil ifTrue:[
start ~~ stop ifTrue:[
revsets add: (start revno printString , ':' , stop revno printString).
] ifFalse:[
revsets add: start revno printString
].
].
(addId or:[revsets isEmpty]) ifTrue:[revsets add: id printString].
^revsets
"Created: / 22-01-2013 / 16:41:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 12-03-2013 / 23:59:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!HGRepository class methodsFor:'documentation'!
version_HG
^ '$Changeset: <not expanded> $'
!
version_SVN
^ '§Id:: §'
! !
HGRepository initialize!