"

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

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

SCMAbstractPackageModel subclass:#SCMAbstractPackageWorkingCopy

	instanceVariableNames:'wc wcroot changed classesHasChanged extensionsHasChanged

		lastSequenceNumber lastSequenceNumberForChildren'

	classVariableNames:''

	poolDictionaries:''

	category:'SCM-Common-StX'

!

!SCMAbstractPackageWorkingCopy class methodsFor:'documentation'!

copyright

"

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

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 a checked-out working copy. 

    It knows how to map living classes to their respective file containers 

    and can fileout individual classes. Used (not only) by SCMAbstractCommitTask.

    == Changed packages ==

    A 'changed' package is a package that contain changes, i.e., some method/class

    beloging to a package has been modified or class/method has been added/removed.

    Compared to state of the package at its LOAD TIME, not to last nor compiled 

    revision !!!!!!

    See #hasChanges, #classesHasChanged, #extensionsHasChanged.

    [author:]

        Jan Vrany <jan.vrany@fit.cvut.cz>

    [instance variables:]

    [class variables:]

    [see also:]

        SCMAbstractPackageModel

"

! !

!SCMAbstractPackageWorkingCopy 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.

! !

!SCMAbstractPackageWorkingCopy class methodsFor:'testing'!

isAbstract

    ^ self == SCMAbstractPackageWorkingCopy

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

    "Modified: / 05-03-2014 / 21:59:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractPackageWorkingCopy methodsFor:'accessing'!

abbrevs

    ^ self definition abbrevs

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

!

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

!

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

!

revision

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

     on which the next commit will be based on"              

    self isVirtual ifTrue:[ 

        | childRevs |

        childRevs := Set new.

        self childrenDo:[:each | childRevs add: each revision ].

        childRevs size == 0 ifTrue:[ 

            self error: 'No non-virtual children'.

            ^ nil.

        ].

        childRevs size ~~ 1 ifTrue:[ 

            self error: 'Inconsistent revisions of chilren of virtual package'.

            ^ nil

        ].

        ^ childRevs anElement

    ] ifFalse:[ 

        ^ self getRevision

    ].

    "Modified: / 28-02-2014 / 09:38:15 / 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>"

! !

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

! !

!SCMAbstractPackageWorkingCopy methodsFor:'accessing-containers'!

containerFor: aString ifAbsent: aBlock

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

     container, evaluates a block"            

    ^self temporaryWorkingCopyRoot / aString

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

!

containerWriteStreamFor: containerName

    | filename directory |

    filename := self containerFor: 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: / 13-03-2014 / 22:56:16 / 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 containerFor: (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: / 13-03-2014 / 22:55:50 / 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: / 05-03-2014 / 23:29:04 / 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>"

! !

!SCMAbstractPackageWorkingCopy methodsFor:'accessing-hierarchy'!

children

    "Returns all my immediate children."

    self updateCachedValues.

    ^ children values.

    "

    (HGPackageModelRegistry packageNamed: 'stx:libscm') children

    "

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

    "Modified: / 28-02-2014 / 23:54:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

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

!

getRevision

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

     on which the next commit will be based on"              

    ^ self subclassResponsibility

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

! !

!SCMAbstractPackageWorkingCopy methodsFor:'file out'!

fileOutClass:cls

    |stream|

    stream := self containerWriteStreamForClass:cls.

    [

        self fileOutClass:cls on:stream

    ] ensure:[

        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: / 03-07-2013 / 19:50:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 30-07-2014 / 20:49:35 / 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