"

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

"

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

"

!

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 class methodsFor:'testing'!

isAbstract

    ^ self == SCMAbstractPackageModel

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

    "Modified: / 25-02-2014 / 22:38:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!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

!

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

!

revision

    "Return a logical revision of the package, i.e., a revision

     on which the next commit will be based on"              

    ^ self subclassResponsibility

    "Modified (comment): / 25-02-2014 / 22:41:34 / 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-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>"

!

containerNameForExtensions: aProgrammingLanguage javaClass: aJavaClass

    | class classBinaryName comps |

    class := aJavaClass theNonMetaClass.

    "Sigh, make it compatible with old and new naming of Java classes

    old -> aJavaClass name == #'java/lang/Object'

    new -> aJavaClass name == JAVA::java::lang::Object

           aJavaClass binaryName == #'java/lang/Object'

    "

    classBinaryName := (class respondsTo: #binaryName)

                            ifTrue:[ class binaryName ]

                            ifFalse:[ class name ].

    self assert: (classBinaryName includes: $:) not.

    ^ String streamContents:[:s|

        s nextPutAll: 'java/extensions'.

        comps := classBinaryName tokensBasedOn: $/.

        comps do:[:each| s nextPut: $/; nextPutAll: each ].

        s nextPut: $.; nextPutAll: aProgrammingLanguage sourceFileSuffix.

    ].

    "Created: / 24-09-2013 / 11:31:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 09-10-2013 / 08:56:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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

!

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

    | container |

    container := self containerFilenameFor: (self containerNameForExtensions: aProgrammingLanguage javaClass: aJavaClass).

    container directory exists ifFalse:[

         container directory recursiveMakeDirectory.

    ].

    ^ container writeStream

    "Created: / 04-09-2012 / 23:17:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 24-09-2013 / 12:07:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

containers

    | containers jextensions |

    containers := OrderedCollection new.

    containers addAll:

        (wcroot directoryContents select:

                [:container|self containerSuffixes anySatisfy:

                    [:suffix|container endsWith:suffix]]) asSet.

    (jextensions:= wcroot / 'java' / 'extensions') exists ifTrue:[

        jextensions recursiveDirectoryContentsDo:[:each|

            (self containerSuffixes anySatisfy:[:suffix|each endsWith:suffix]) ifTrue:[

                (jextensions / each) isRegularFile ifTrue:[

                    containers add: 'java/extensions/' , each.

                ].

            ].

        ]

    ].

    ^ containers

    "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: / 24-09-2013 / 12:39:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

containersToKeep

    | containers extensions |

    containers := self classes collect:[:cls|self containerNameForClass: cls].

    (extensions := self extensions) notEmpty ifTrue:[

        | languages extensionsNonJava extensionsJava |

        extensionsNonJava := extensions reject:[:m | m mclass programmingLanguage isJava].

        extensionsJava := extensions select:[:m | m mclass programmingLanguage isJava].

        languages :=  (extensionsNonJava collect:[:each|each programmingLanguage]) asSet.

        languages do: [:lang| containers add: (self containerNameForExtensions: lang)].

        extensionsJava do:[:m |

            | container |

            container := self containerNameForExtensions: m programmingLanguage javaClass: m mclass.

            (containers includes: container) ifFalse:[

                 containers add: container

            ].

        ].

    ].

    "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: / 24-09-2013 / 12:32:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractPackageModel methodsFor:'accessing-hierarchy'!

children

    "Returns all my immediate children."

    | childNames nameSizePlus1 |

    nameSizePlus1 := name size + 1.

    childNames := Smalltalk allProjectIDs select:[:each |

        (each startsWith: name)

        and:[ each ~= name

        and:[ ((each at: nameSizePlus1) == $/ or:[ (each at: nameSizePlus1) == $: ])

        and:[ (each indexOf: $/ startingAt: nameSizePlus1 + 1) == 0]]]].

    ^ childNames collect:[:each |  self childNamed: (each copyFrom: nameSizePlus1 + 1) ].

    "

    (HGPackageModelRegistry packageNamed: 'stx:libscm') children

    "

    "Created: / 19-02-2014 / 23:43:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

childrenDo: aBlock

    "Evaluate a block for all immediate children of the receiver.

     Does NOT recurse."

    self children do: aBlock

    "Created: / 19-02-2014 / 23:47:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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

!

root

    "Returns the root of this package model hierarchy, i.e., grand-parent which itself has no parent.

     See class documentation for details on parents"

    | p |

    p := self.

    [ p parent notNil ] whileTrue:[

        p := p parent.

    ].

    ^ p

    "Created: / 19-02-2014 / 23:30:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!