Bugfix: HGCommandParser>>parseCommandMerge: handle correctly clear merges.
"
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/common' }"
Object subclass:#SCMAbstractPackageModel
instanceVariableNames:'name parent children repository repositoryRoot wc wcroot
classesHasChanged extensionsHasChanged'
classVariableNames:''
poolDictionaries:''
category:'SCM-Common-StX'
!
!SCMAbstractPackageModel 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.
"
!
documentation
"
A model of a Smalltalk/X package in repository. It knows how to
map living classes to their respective file containers and can
fileout individual classes.
Package models forms a hiearchy that copies package hiearchy. The root
has no parent and represent a package which is located in the root
of the repository. Examples:
stx:libscm ---> parent = nil, repository = /home/.../build/stx/libscm, repositoryPath = '.'
stx:libscm/common ---> parent = stx:libscm, repository = /home/.../build/stx/libscm, repositoryPath = 'common'
stx:libscm/mercurial ---> parent = stx:libscm, repository = /home/.../build/stx/libscm, repositoryPath = 'mercurial'
In this case, the HGRepository object is shared by all three package models.
[author:]
Jan Vrany <jan.vrany@fit.cvut.cz>
[instance variables:]
[class variables:]
[see also:]
"
! !
!SCMAbstractPackageModel class methodsFor:'instance creation'!
named: package
self subclassResponsibility
"Created: / 16-11-2012 / 19:52:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
new
"return an initialized instance"
^ self basicNew initialize.
! !
!SCMAbstractPackageModel methodsFor:'accessing'!
classes
^self classesIncludingPrivate reject:[:cls|cls owningClass notNil]
"Created: / 06-10-2012 / 23:14:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
classesFiltered: classFilter
^self classes select: [:class|classFilter value: class].
"Created: / 06-10-2012 / 23:14:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
classesIncludingPrivate
^ProjectDefinition searchForClassesWithProject: self name
"Created: / 06-10-2012 / 23:15:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
commitDialog
^self commitDialogClass new
"Modified: / 14-11-2012 / 22:31:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
commitTask
^self commitTaskClass new
package: self;
yourself
"Created: / 06-10-2012 / 22:14:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 13-11-2012 / 23:22:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
construct: aString
"Create a package model for subpackage named aString"
| normalizedName components package |
normalizedName := (aString includes: $:) ifTrue:[aString copyReplaceAll:$: with:$/] ifFalse:[aString].
( normalizedName includes: $/) ifFalse:[
^self childNamed: normalizedName.
].
components := normalizedName tokensBasedOn: $/.
package := self.
components do:[:each|package := package childNamed: each].
^package
"Created: / 16-11-2012 / 23:47:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 03-12-2012 / 14:04:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
definition
^LibraryDefinition definitionClassForPackage:self name createIfAbsent:true
"Created: / 06-10-2012 / 23:09:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
extensions
^ProjectDefinition searchForExtensionsWithProject: self name
"Created: / 06-10-2012 / 23:12:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
extensionsFiltered:aBlock
^self extensions select:aBlock
"Created: / 06-10-2012 / 23:19:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
manager
"Returns a source code manager for this kind of package"
^self subclassResponsibility
"Created: / 14-11-2012 / 01:02:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
name
^ name
!
parent
"Returns the parent model. See class documentation for details on parents"
^parent
"Created: / 01-12-2012 / 17:56:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
repositoryRoot
"Returns relative path within the repository root where the package
content is located. Example: let's assume:
<repo>/.hg
<repo>/mercurial/...
<repo>/mercurial/tests/...
<repo>/common/..
then
(HGPackageModelRegistry packageNamed: 'stx:libscm/mercurial/tests') path
== 'mercurial/tests'
"
self assert: repositoryRoot notNil.
^repositoryRoot
"Created: / 01-12-2012 / 02:03:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
temporaryWorkingCopy
self ensureTemporaryWorkingCopy.
^wc
"Created: / 01-12-2012 / 00:26:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
temporaryWorkingCopyPath
"Return the directory which contains temporary working copy.
The directory may not exists if the temporary working copy has
not yet been initialized (which is done on demand)"
^ self manager temporaryWorkingCopyDirectory / repository uuid printString
"Created: / 05-02-2013 / 09:30:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
temporaryWorkingCopyRoot
self ensureTemporaryWorkingCopy.
^ wcroot
"Created: / 14-11-2012 / 23:51:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'accessing - containers'!
containerSuffixes
^ProgrammingLanguage all collect:[:each|each sourceFileSuffix]
"Created: / 23-03-2009 / 18:53:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 30-12-2009 / 18:15:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containers
^(wcroot directoryContents
select:
[:container|self containerSuffixes anySatisfy:
[:suffix|container endsWith:suffix]]) asSet
"Created: / 23-03-2009 / 18:52:27 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 12-06-2009 / 21:44:06 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 15-11-2012 / 00:55:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'accessing-classes'!
commitDialogClass
self subclassResponsibility
"Created: / 14-11-2012 / 22:29:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
commitTaskClass
"raise an error: must be redefined in concrete subclass(es)"
^ self subclassResponsibility
! !
!SCMAbstractPackageModel methodsFor:'accessing-containers'!
containerFilenameFor: containerName
^self temporaryWorkingCopyRoot / containerName
"Created: / 09-10-2008 / 20:25:02 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 01-12-2012 / 00:24:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containerNameForClass:cls
^self
containerNameForClassNamed: cls theNonMetaclass fullName
language: cls programmingLanguage
"Created: / 07-10-2012 / 10:36:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-11-2012 / 00:46:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containerNameForClassNamed: nm language: lang
^String streamContents:[:s|
s nextPutAll: (nm copyReplaceAll:$: with: $_).
s nextPut: $..
s nextPutAll: lang sourceFileSuffix
]
"Created: / 15-11-2012 / 00:45:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containerNameForExtensions
^self containerNameForExtensions: SmalltalkLanguage instance
"Created: / 07-10-2012 / 10:37:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containerNameForExtensions: aProgrammingLanguage
^'extensions.' , aProgrammingLanguage sourceFileSuffix
"Created: / 07-10-2012 / 10:38:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containerWriteStreamFor: containerName
| filename directory |
filename := self containerFilenameFor: containerName.
(directory := filename directory) exists ifFalse:[
directory recursiveMakeDirectory
].
^filename writeStream
eolMode: #nl;
yourself
"Created: / 09-10-2008 / 20:24:44 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 04-09-2012 / 23:44:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containerWriteStreamForClass:cls
^self containerWriteStreamFor: (self containerNameForClass:cls)
"Created: / 07-10-2012 / 10:27:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containerWriteStreamForExtensions: aProgrammingLanguage
^self containerWriteStreamFor: (self containerNameForExtensions: aProgrammingLanguage)
"Created: / 30-12-2009 / 18:14:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 07-10-2012 / 10:54:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containerWriteStreamForExtensions: aProgrammingLanguage javaClass: aJavaClass
| entry comps |
entry := wcroot / 'java' / 'extensions'.
comps := aJavaClass theNonMetaclass name tokensBasedOn: $/.
1 to: comps size - 1 do:[:i|entry := entry / (comps at:i)].
entry := entry / (comps last , '.' , aProgrammingLanguage sourceFileSuffix).
^entry writeStream.
"Created: / 04-09-2012 / 23:17:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 10-12-2012 / 05:52:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
containersToKeep
| containers extensions |
containers := self classes collect:[:cls|self containerNameForClass: cls].
(extensions := self extensions) notEmpty ifTrue:[
| languages |
languages := (extensions collect:[:each|each programmingLanguage]) asSet.
languages do: [:lang|containers add: (self containerNameForExtensions: lang)]
].
"Keep all directories"
wcroot directoryContents do: [:f|
(f ~= '.hg' and: [(wcroot / f) isDirectory]) ifTrue:[
containers add: f
].
].
"Keep all .st files that are for with other operating systems"
self definition classNamesAndAttributesDo: [:nm :attributes|
attributes do:[:attr|
(#(win32 unix vms autoload) includes: attr) ifTrue:[
containers add: (self containerNameForClassNamed: nm language: SmalltalkLanguage instance)
]
]
].
^containers asSet.
"Created: / 12-06-2009 / 21:27:12 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 15-11-2012 / 00:47:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'accessing-private'!
childNamed: aString
"Returns a child name aString. If no such child
exist, create one"
| child nm|
children at: aString ifPresent:[:child|^child].
child := self class new.
nm := (name includes: $:)
ifTrue: [name , '/' , aString]
ifFalse:[name , ':' , aString].
child setName: nm repository: repository.
child setParent: self.
children at: aString put: child.
^child
"Created: / 01-12-2012 / 01:29:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 01-12-2012 / 18:11:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'file out'!
fileOutClass:cls
|stream|
[stream := self containerWriteStreamForClass:cls.
self fileOutClass:cls on:stream]
ensure:[ stream ifNotNil:[ stream close ]]
"Modified: / 11-06-2009 / 16:18:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Created: / 30-12-2009 / 19:04:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 13-11-2012 / 23:22:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
fileOutClass:cls on:clsStream
"/ cls methodDictionary do:
"/ [:each|each makeLocalStringSource].
"/
"/ cls class methodDictionary do:
"/ [:each|each makeLocalStringSource].
self manager
fileOutSourceCodeOf:cls
on:clsStream
withTimeStamp:false
withInitialize:true
withDefinition:true
methodFilter:[:mth | mth package = name ]
"
String streamContents:[:s|
(SVN::RepositoryManager repositoryForPackage: Setup::ML package)
workingCopy
fileOutClass: Setup::ML on: s
]
"
"Created: / 19-04-2008 / 09:58:11 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 11-06-2009 / 16:18:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 07-07-2011 / 20:21:59 / jv"
"Modified: / 14-11-2012 / 01:01:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
fileOutExtensions: extensionMethods
^self fileOutExtensions: extensionMethods in: self temporaryWorkingCopyRoot
"Created: / 30-12-2009 / 19:01:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 01-12-2012 / 00:47:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
fileOutExtensions: extensionMethods in: directory
ProgrammingLanguage all do:[:lang|
| stream methods |
methods := extensionMethods select:[:mth|mth programmingLanguage = lang].
methods notEmpty ifTrue: [
ActivityNotification notify:'Filing out extension methods (', lang name , ')'.
self fileOutExtensions: methods in: directory language: lang
]
]
"Created: / 04-09-2012 / 22:56:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
fileOutExtensions: extensionMethods in: directory language: lang
"Given a directory, files out extensions methods in given language.
Takes care about Java extensions, as they are filed out separately
in per-classe .st file in <package dir>/java/extensions/<package>/<java classname>.st"
| stream nonJavaExtensionsMethod javaExtensionsMethods |
stream := self containerWriteStreamForExtensions: lang.
[
nonJavaExtensionsMethod := extensionMethods reject:[:each|each mclass theNonMetaclass isJavaClass].
self fileOutExtensions: nonJavaExtensionsMethod on: stream language: lang.
] ensure:[
stream close
].
javaExtensionsMethods := Dictionary new.
extensionMethods do:[:mthd|
mthd mclass theNonMetaclass isJavaClass ifTrue:[
(javaExtensionsMethods at: mthd mclass ifAbsentPut:[OrderedCollection new]) add: mthd.
].
].
javaExtensionsMethods keysAndValuesDo:[:cls :methods|
[
stream := self containerWriteStreamForExtensions: lang javaClass: cls.
self fileOutExtensions: methods on: stream language: lang.
] ensure:[
stream close.
]
]
"Created: / 04-09-2012 / 23:05:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-12-2012 / 17:50:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
fileOutExtensions: extensionMethods on:stream language: language
extensionMethods do:[:each|each makeLocalStringSource].
"Special hack for Smalltalk - use SourceCodeManager routine"
(language isSmalltalk and:[extensionMethods allSatisfy:[:m|m mclass theNonMetaclass isJavaClass not]]) ifTrue:[
self manager fileOutSourceCodeExtensions: extensionMethods package: self name on: stream.
^self.
].
"/ Generic fileout "
language sourceFileWriterClass new
fileOutPackageDefinition: self name on: stream;
fileOutMethods: extensionMethods on: stream
"Modified: / 15-06-2009 / 11:55:26 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Created: / 30-12-2009 / 19:01:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 16-12-2012 / 13:08:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'initialization'!
initialize
"Invoked when a new instance is created."
"/ please change as required (and remove this comment)
"/ name := nil.
"/ parent := nil.
children := Dictionary new.
"/ repository := nil.
"/ repositoryRoot := nil.
"/ wc := nil.
"/ wcroot := nil.
"/ classesHasChanged := nil.
"/ extensionsHasChanged := nil.
"/ super initialize. -- commented since inherited method does nothing
"Modified: / 01-12-2012 / 18:02:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
setName: aSymbolOrPackageId repository: aRepository
"Initializes the package. This method also MUST initialize 'repositoryRoot' instvar!!"
^self subclassResponsibility
"Created: / 01-12-2012 / 17:52:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
setNameComponents: aCollection repository: aRepository
| nm |
aCollection isEmpty ifTrue:[
self setName:'' repository: aRepository.
^self.
].
aCollection size == 1 ifTrue:[
self setName: aCollection first repository: aRepository.
^self.
].
nm := aCollection first , ':' , aCollection second.
aCollection size > 2 ifTrue:[
3 to: aCollection size do:[:i|
nm := nm , '/' , (aCollection at: i)
].
].
self setName: nm repository: aRepository.
^self
"Created: / 03-12-2012 / 12:36:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
setParent: parentModel
"Sets the parent model. See class documentation for details on parents models"
^parent := parentModel
"Created: / 01-12-2012 / 17:54:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 03-12-2012 / 14:05:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
setWorkingCopy: aSCMAbstractWorkingCopy
wc := aSCMAbstractWorkingCopy.
wcroot := wc root / self repositoryRoot
"Created: / 01-12-2012 / 17:53:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'private'!
commited
"Sent by commit task once commited"
extensionsHasChanged := false.
classesHasChanged := false.
"Created: / 13-08-2009 / 10:23:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 15-11-2012 / 10:05:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (comment): / 23-11-2012 / 22:50:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'queries'!
classesHasChanged
classesHasChanged :=
(classesHasChanged == true) or:[self computeClassesHasChanged].
^ classesHasChanged
"Created: / 06-10-2012 / 23:16:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
extensionsHasChanged
extensionsHasChanged :=
(extensionsHasChanged == true) or:[self computeExtensionsHasChanged].
^ extensionsHasChanged
"Created: / 06-10-2012 / 23:16:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'queries-privacy'!
computeClassesHasChanged
"
Answers true iff package classes differs from
those listed in ProjectDefinition>>classNamesAndAttributes"
|listedClasses realClasses pkgDef |
(pkgDef := self definition) isNil ifTrue:[^true].
listedClasses := pkgDef compiled_classNames_common ,
pkgDef compiled_classNamesForPlatform ,
pkgDef autoloaded_classNames.
realClasses := self classes collect:[:cls | cls fullName ].
listedClasses size ~= realClasses size
ifTrue:[^ true].
(realClasses allSatisfy:[:realClass | listedClasses includes:realClass ])
ifFalse:[^true].
^false
"
(CommitTask new package: 'stx:libsvn')
computePackageClassesChanged
(CommitTask new package: 'cvut:fel/smallruby')
computePackageClassesChanged
(SVN::RepositoryManager workingCopyForPackage: #'stx:libbasic')
computePackageClassesChanged
"
"Created: / 06-10-2012 / 23:17:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
computeExtensionsHasChanged
"
Answers true iff package extension method differs from
those listed in ProjectDefinition>>extensionMethodNames"
|listedExtensions listedExtensionsDictionary realExtensions|
realExtensions := self extensions.
listedExtensions := self definition
extensionMethodNames.
(listedExtensions size / 2) ~= realExtensions size ifTrue:[
^ true
].
listedExtensionsDictionary := Dictionary new.
listedExtensions
pairWiseDo:[:className :selector |
(listedExtensionsDictionary at:className
ifAbsentPut:[ OrderedCollection new ]) add:selector
].
^ (realExtensions
allSatisfy:[:mth |
(listedExtensionsDictionary includesKey:mth mclass name)
and:[ (listedExtensionsDictionary at:mth mclass name) includes:mth selector ]
])
not
"
(CommitTask new package: 'stx:libsvn')
packageExtensionsHasChanged"
"Created: / 06-10-2012 / 23:17:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SCMAbstractPackageModel methodsFor:'utils'!
ensureTemporaryWorkingCopy
"raise an error: must be redefined in concrete subclass(es)"
^ self subclassResponsibility
! !
!SCMAbstractPackageModel class methodsFor:'documentation'!
version_HG
^ '$Changeset: <not expanded> $'
!
version_SVN
^ '§Id:: §'
! !