"

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/common' }"

"{ NameSpace: Smalltalk }"

Object subclass:#SCMAbstractPackageModel

	instanceVariableNames:'name parent children repository repositoryRoot virtual'

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

"

!

documentation

"

    A model of a Smalltalk/X package in repository. It can

    answer a changeset containing package code and diffs against

    another package model.

    == Hierarchy ==

    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 (HG)Repository object is shared by all three package models. See

    #chilren, #parent and #root.

    == Virtual packages ==

    Package is 'virtual' if there's actually no code in the package. Virtual packages

    are therefore just containers for nested packages. For example, package 'stx' would

    be a 'virtual' package, since there's no code packages in 'stx' - all is in one of

    its nested sub-packages - stx:libbasic, stx:libscm.

    See #isVirtual.

    [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:'queries'!

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

abbrevs

    "Returns a Dictionary mapping class name to an abbrev entry object.

     This object should at least respond to #fileName"

    ^ self subclassResponsibility

    "Created: / 14-03-2014 / 22:02:00 / 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

    "Returns a sort of project definition object.

     It has to at least understand #classNamesAndAttributes and

     #xtensionMethodNames."

    ^ self subclassResponsibility

    "Created: / 14-03-2014 / 21:57:43 / 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 package model"

    ^ self subclassResponsibility

    "Created: / 05-03-2014 / 23:16:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractPackageModel methodsFor:'accessing-containers'!

containerFor: aString

    "Return a container as Filename with given name"    

    ^ self containerFor: aString ifAbsent: [ self error: 'No container named ', aString ]

    "Modified: / 14-03-2014 / 22:15:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

containerFor: aString ifAbsent: aBlock

    "Return a container as Filename with given name. If there's no such

     container, evaluates a block"    

    ^ self subclassResponsibility

    "Created: / 14-03-2014 / 22:15:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

containerForProjectDefinition

    ^ self containerFor: (ProjectDefinition projectDefinitionClassNameForDefinitionOf: name) , '.st'

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

    "Modified: / 14-03-2014 / 22:00:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

containerNameForClass:cls

    | clsName |

    clsName := cls isJavaClass 

        ifTrue:[ cls theNonMetaclass binaryName ] 

        ifFalse:[ cls theNonMetaclass fullName ].

    ^ self

        containerNameForClassNamed: clsName

        language: cls programmingLanguage

    "Created: / 07-10-2012 / 10:36:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 31-07-2014 / 08:39:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

containerNameForClassNamed: nm language: lang

    ^String streamContents:[:s|

        "/ Sigh, special case for Java classes. Their code

        "/ is in java/src subdirectory.

        lang isJavaLike ifTrue:[ 

            s nextPutAll: 'java'.

            s nextPut: Filename separator.

            s nextPutAll: 'src'.

            s nextPut: Filename separator.      

            s nextPutAll: (nm copyReplaceAll: $/ with: Filename separator).

        ] ifFalse:[ 

            | xlated |

            "/ Here, consult abbreviation file...

            lang isSmalltalk ifTrue:[

                | abbrev |

                abbrev := self abbrevs at: nm ifAbsent:[ nil ].

                abbrev notNil ifTrue:[ 

                    xlated := abbrev fileName.

                ].

            ].

            xlated isNil ifTrue:[ 

                xlated := (nm copyReplaceAll:$: with: $_).

            ].

            s nextPutAll: (nm copyReplaceAll:$: with: $_). "/ Q: should't this be nextPutAll: xlated here? See issue #48.

        ].

        s nextPut: $..

        s nextPutAll: lang sourceFileSuffix.

    ]

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

    "Modified (comment): / 31-07-2014 / 08:54:12 / 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>"

!

containers

    ^ self subclassResponsibility

    "Created: / 05-03-2014 / 23:36:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractPackageModel methodsFor:'accessing-hierarchy'!

children

    "Returns all my immediate children."       

    ^ self subclassResponsibility

    "Created: / 05-03-2014 / 23:18:47 / 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 := self.

    ].

    ^ p

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

!

siblings

    "Returns all my siblings"

    parent notNil

        ifTrue:[ ^ self parent children copy remove: self; yourself]

        ifFalse:[ ^ #() ]

    "

    (HGPackageWorkingCopyRegistry packageNamed: 'stx:libscm') siblings

    (HGPackageWorkingCopyRegistry packageNamed: 'stx:libscm/common') siblings

    "

    "Created: / 20-02-2014 / 00:22:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 07-03-2014 / 14:21:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

yourselfAndAllChildrenDo: aBlock

    "Evaluate a block for receiver and all its children, recursively."

    aBlock value: self.

    self children do:[:each | each yourselfAndAllChildrenDo: aBlock ]

    "Created: / 19-02-2014 / 23:49:27 / 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"     

    ^ self subclassResponsibility

    "Created: / 05-03-2014 / 23:19:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractPackageModel methodsFor:'initialization'!

setParent: aSCMAbstractPackageModel

    parent := aSCMAbstractPackageModel

    "Modified: / 08-03-2014 / 10:05:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractPackageModel methodsFor:'printing & storing'!

printOn:aStream

    "append a printed representation of the receiver to the argument, aStream"

     super printOn:aStream.

    aStream nextPut:$(.

    name printOn: aStream.

    aStream nextPutAll: ' @ '.

    self revision printOn: aStream.

    aStream nextPut:$).

    "Modified: / 08-03-2014 / 10:01:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractPackageModel methodsFor:'testing'!

isChildOf: anotherPackageModel

    ^ anotherPackageModel isParentOf: self.

    "Created: / 25-02-2014 / 22:51:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

isParentOf: anotherPackageModel    

    | anotherName |

    anotherName := anotherPackageModel name.

    ^ (anotherName size) > (name size + 1)

        and:[ (anotherName startsWith: name)

            and:[ ':/' includes: (anotherName at: name size + 1) ]].

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

!

isVirtual

    "Return true, if the package is virtual, i.e., there's no code in

     the package. False otherwise.

     Virtual packages serves merely as containers for nested packages"       

    ^ self subclassResponsibility

    "Modified (comment): / 07-03-2014 / 22:58:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractPackageModel class methodsFor:'documentation'!

version

    ^ '$Header$'

!

version_CVS

    ^ '$Header$'

!

version_HG

    ^ '$Changeset: <not expanded> $'

!

version_SVN

    ^ '$Id$'

! !