"

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

Copyright (C) 2012-2015 Jan Vrany

Copyright (C) 2020-2021 LabWare

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

SCMAbstractTask subclass:#SCMAbstractFileoutLikeTask

	instanceVariableNames:'suppressClasses suppressExtensions suppresBuildSupportFiles

		packageClassesChanged packageExtensionsChanged extensionMethods

		fileout2codeMap'

	classVariableNames:''

	poolDictionaries:''

	category:'SCM-Common-StX-Tasks'

!

!SCMAbstractFileoutLikeTask class methodsFor:'documentation'!

copyright

"

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

Copyright (C) 2012-2015 Jan Vrany

Copyright (C) 2020-2021 LabWare

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

"

! !

!SCMAbstractFileoutLikeTask methodsFor:'accessing'!

extensionMethods

    ^ extensionMethods

!

extensionMethods:aCollection"of Methods"

    extensionMethods := aCollection.

    "Modified: / 14-05-2009 / 13:38:15 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

filesToGenerate

    self error: 'Should not be sent'.

    ^ self packageDefinition fileNamesToGenerate keys

    "

	SVN::CommitTask new

	    package: #stx:libsvn;

	    buildSupportFiles"

    "Created: / 27-11-2009 / 11:29:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

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

!

filesToGenerateFor: package

    ^ self filesToGenerateFor: package skipNotOverwritable: true

    "Created: / 22-02-2014 / 22:31:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 11-06-2015 / 08:20:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

filesToGenerateFor: package skipNotOverwritable: skipNotOverwritable

    | files definition fileNamesToSkip |

    package isVirtual ifTrue:[ 

        ^ OrderedCollection new 

    ].

    (self isSelectiveFileoutTask and:[packageClassesChanged not and:[(classes includes: package definition) not]]) ifTrue:[

        ^ OrderedCollection new

    ].  

    files := OrderedCollection new.

    definition := package definition.

    fileNamesToSkip := #().

    (package workingCopyRoot / definition rcFilename) exists ifTrue:[

        "/ Skip .rc files, it only generates a noise in repo and merge conflicts...

        fileNamesToSkip := fileNamesToSkip copyWith: definition rcFilename.

    ].

    definition fileNamesToGenerate keysAndValuesDo:[:file :selector |

        (fileNamesToSkip includes: file) ifFalse:[

            skipNotOverwritable ifTrue:[

                | annotation |

                annotation := (definition class lookupMethodFor: selector) annotationAt: #file:overwrite:.

                (annotation isNil or:[ (annotation argumentAt: 2) or:[ (package workingCopyRoot / file) exists not] ]) ifTrue:[ 

                    files add: file

                ].

            ] ifFalse:[ 

                files add: file

            ].

        ].

    ].

    ^ files

    "

        SVN::CommitTask new

            package: #stx:libsvn;

            buildSupportFiles"

    "Created: / 11-06-2015 / 08:18:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

packageDefinition

    self error: 'Should not be sent'.

    ^self package definition

    "Created: / 27-11-2009 / 11:27:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 21-02-2014 / 22:53:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

suppresBuildSupportFiles

    ^ suppresBuildSupportFiles

!

suppresBuildSupportFiles:something

    suppresBuildSupportFiles := something.

!

suppressClasses

    ^ suppressClasses

!

suppressClasses:aBoolean

    suppressClasses := aBoolean.

!

suppressExtensions

    ^ suppressExtensions

!

suppressExtensions:aBoolean

    suppressExtensions := aBoolean.

! !

!SCMAbstractFileoutLikeTask methodsFor:'executing - private'!

doAddNewContainers

    packages do:[:each | each isVirtual ifFalse: [ self doAddNewContainersFor: each ] ]

    "Created: / 11-04-2008 / 10:58:53 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 19-08-2009 / 14:00:26 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 27-02-2014 / 22:55:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doAddNewContainersFor: package

    | wcroot containers |

    ActivityNotification notify:'Adding new containers'.

    wcroot := package workingCopyRoot.

    containers := (self containersToFileOutFor: package)

                    collect:[ :e | wcroot / e ].

    self workingCopy track: containers.

    "Created: / 22-02-2014 / 22:49:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 28-02-2017 / 21:45:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doCompileCopyrightMethods

    packages do:[:each | each isVirtual ifFalse: [ self doCompileCopyrightMethodsFor: each ] ]

    "Modified: / 16-08-2009 / 12:59:50 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Created: / 08-04-2010 / 14:31:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 27-02-2014 / 22:55:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doCompileCopyrightMethodsFor: package

    | klasses |

    ActivityNotification notify:'Updating #copyright methods...'.

    klasses := (self classesToFileOutFor: package) select:[:cls | self shouldUpdateCopyrightInClass: cls ].

    klasses asArray

        withIndexDo:[:cls :index |

            SCMCopyrightUpdater updateClass: cls theNonMetaClass.

            ProgressNotification newException

                messageText: ('Compiling %1 (%2)' bindWith:#copyright

                                                      with:cls nameWithoutPrefix);

                parameter: (100 / klasses size) * index;

                raiseRequest.

        ]

    "Created: / 21-02-2014 / 22:59:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 08-10-2020 / 18:26:54 / Jan Vrany <jan.vrany@labware.com>"

!

doCompileVersionMethods

    packages do:[:each |

	each isVirtual ifFalse: [

	    | klasses |

	    klasses := self classesToFileOutFor: each.

	    self doCompileVersionMethodsFor: each in: klasses asArray.

	]

    ].

    "Created: / 09-10-2013 / 11:57:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 27-02-2014 / 22:55:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doCompileVersionMethodsFor: package in: klasses

    | versionMethodName|

    versionMethodName := package manager nameOfVersionMethodInClasses.

    ActivityNotification notify:'Compiling #version methods...'.

    klasses

        withIndexDo:[:cls :index |

            |metaCls|

            cls isJavaClass ifFalse:[

                metaCls := cls theMetaclass.

                ((metaCls includesSelector:versionMethodName) not

                    "JV@2012-11-14: libsvn did this check, however, it is not valid for

                     SCMs that does not expand keywords. I disable it, but kept as comment

                     as I do not remember why it was good for..."

                    "or:[ ((cls perform:versionMethodName asSymbol) startsWith:'$Id') not ]")

                        ifTrue:[

                            metaCls compile:(metaCls

                                        versionMethodTemplateForSourceCodeManager:package manager)

                                classified:'documentation'.

                            (metaCls compiledMethodAt:versionMethodName)

                                setPackage:package name asSymbol

                        ].

                package manager utilities ensureCorrectVersionMethodsInClass: cls usingManager: package manager.

            ].

            ^ ProgressNotification newException

                messageText: ('Compiling %1 (%2)' bindWith:versionMethodName

                                                      with:cls nameWithoutPrefix);

                parameter: (100 / klasses size) * index;

                raiseRequest

        ].

    (self extensionMethodsToFileOutFor: package) notEmpty ifTrue:[

        | def |

        "TODO: Not programming language aware..."

        ((def := package definition) class includesSelector: package manager nameOfVersionMethodForExtensions) ifFalse:[

            def class

                compile:

                    (package manager versionMethodTemplateForSmalltalkFor:package manager nameOfVersionMethodForExtensions)

                classified: #documentation.

            (def class compiledMethodAt:package manager nameOfVersionMethodForExtensions)

                setPackage:package name asSymbol

        ]

    ]

    "Created: / 21-02-2014 / 23:01:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 31-07-2014 / 09:04:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doFileOut

    "Fileouts everything to the working copy"

    self

        doMakeLocalLocalSource;

        doUpdateBuildSupportFiles;

        doRenameContainers;

        doFileOutPackageClasses;

        doFileOutPackageExtensions;

        doAddNewContainers;

        doRemoveOldContainers.

    "Created: / 10-05-2012 / 17:05:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 21-11-2012 / 00:43:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 15-09-2021 / 15:46:15 / Jan Vrany <jan.vrany@labware.com>"

!

doFileOutAll

    self

	doUpdateCode;

	doFileOut.

    "Created: / 17-08-2009 / 18:28:18 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 10-05-2012 / 17:06:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doFileOutPackageClasses

    packages do:[:each | each isVirtual ifFalse: [ self doFileOutPackageClassesFor: each ] ].

    "Created: / 11-04-2008 / 10:58:16 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 19-08-2009 / 13:44:00 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 27-02-2014 / 22:55:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doFileOutPackageClassesFor: package

    |klasses|

    suppressClasses == true ifTrue:[^self].

    ActivityNotification notify:'Filing out package classes'.

    klasses := (self classesToFileOutFor: package) asArray.

    klasses

        withIndexDo:[:cls :index |

            ProgressNotification newException

                messageText: 'Filing out ' , cls nameWithoutPrefix;

                parameter: (100 / klasses size) * index;

                raiseRequest.

            (self shouldFileOutClass:cls) ifTrue:[package fileOutClass: cls]

        ].

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

    "Modified (format): / 15-09-2021 / 15:42:03 / Jan Vrany <jan.vrany@labware.com>"

!

doFileOutPackageExtensions

    packages do:[:each | each isVirtual ifFalse: [ self doFileOutPackageExtensionsFor: each ] ]

    "Modified: / 07-04-2008 / 08:37:25 / janfrog"

    "Created: / 11-04-2008 / 10:58:36 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 14-05-2009 / 13:37:40 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 27-02-2014 / 22:55:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doFileOutPackageExtensionsFor: package

    | extensions |

    suppressExtensions == true ifTrue:[^self].

    extensions := self extensionMethodsToFileOutFor: package.

    extensions notEmpty ifTrue:[

	package fileOutExtensions: extensions.

    ]

    "Created: / 21-02-2014 / 23:10:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 22-02-2014 / 23:04:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doInitStateVariables

    packageClassesChanged := packages contains:[:each| each isVirtual not and: [ each classesHasChanged ] ] .

    packageExtensionsChanged := packages contains:[:each|  each isVirtual not and: [ each extensionsHasChanged ] ].

    "Created: / 17-06-2009 / 10:17:04 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 13-08-2009 / 10:18:37 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 11-06-2015 / 06:53:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doMakeLocalLocalSource

    packages do:[:each | each isVirtual ifFalse: [ self doMakeLocalLocalSourceFor: each ] ].

    "Created: / 15-09-2021 / 15:46:48 / Jan Vrany <jan.vrany@labware.com>"

!

doMakeLocalLocalSourceFor: package

    suppressClasses ~~ true ifTrue:[

        | klasses |        

        ActivityNotification notify:'Filing out package classes'.

        klasses := (self classesToFileOutFor: package) asArray.

        klasses

            withIndexDo:[:cls :index |

                ProgressNotification newException

                    messageText: 'Fetching source for ' , cls nameWithoutPrefix;

                    parameter: (100 / klasses size) * index;

                    raiseRequest.

                (self shouldFileOutClass:cls) ifTrue:[package makeLocalStringSource: cls]

            ].

    ].

    suppressExtensions ~~ true ifTrue:[

        | extensions |    

        extensions := self extensionMethodsToFileOutFor: package.

        extensions do: [:method | method makeLocalStringSource ]

    ]

    "Created: / 15-09-2021 / 15:49:21 / Jan Vrany <jan.vrany@labware.com>"

!

doRemoveOldContainers

    packages do:[:each | each isVirtual ifFalse: [ self doRemoveOldContainersFor: each ] ]

    "Created: / 11-04-2008 / 11:00:27 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 19-08-2009 / 15:03:51 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 27-02-2014 / 22:55:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doRemoveOldContainersFor: package

    | wcroot containers containersToKeep containersToDelete |

    self isSelectiveFileoutTask ifTrue:[

	^ self

    ].

    ActivityNotification notify:'Removing old containers'.

    wcroot := package workingCopyRoot.

    containers := package containers.

    containersToKeep := package containersToKeep.

    containersToDelete := containers \ containersToKeep.

    "/ Fix for issue #26: Java extension files are removed.

    "/ Filter out all Java extension containers which are for classes which

    "/ are currently not loaded.

    containersToDelete := containersToDelete reject:[:each |

	(each startsWith: 'java/extensions/')

	    and:[

		| nm |

		nm := each copyFrom:17 to: (each lastIndexOf: $.) - 1.

		(JavaVM registry classes contains: [:cls | cls binaryName = nm]) not.

	    ].

    ].

    containersToDelete do:[:nm|

	| entry |

	entry := wcroot / nm.

	entry remove

    ]

    "Created: / 21-02-2014 / 23:12:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doRenameContainerForClassNamed: new for: package using: renames language: lang

    | wcroot assoc old circular oldC oldE newC newE  |

    assoc := renames detectLast:[:each | each key == new ] ifNone:[ ^ self ].

    old := assoc value.

    renames remove: assoc.

    "/ Call recursively to process sequence of renames but not if

    "/ its a circular rename...

    circular := (renames contains:[:each | each value == new ]).

    circular ifTrue:[ ^ self ].

    self doRenameContainerForClassNamed: old for: package using: renames language: lang.

    wcroot := package workingCopyRoot.

    oldC := package containerNameForClassNamed: old language: lang .

    newC := package containerNameForClassNamed: new language: lang .

    (oldE := wcroot / oldC) exists ifTrue:[

	packageClassesChanged := true.

	newE := wcroot / newC.

	oldE moveTo: newE.

    ].

    "Created: / 11-04-2008 / 11:00:27 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 19-08-2009 / 15:03:51 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Created: / 06-08-2011 / 21:33:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 05-03-2014 / 00:13:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doRenameContainers

    | renames names |

    renames := OrderedCollection new.

    names := OrderedCollection new.

    ChangeSet current do:

                [:chg|

                chg isClassRenameChange ifTrue:[

                    renames add: chg className -> chg oldName.

                    names add: chg fullClassName.

                ]].

    packages do:[:each |

        each isVirtual ifFalse: [

            | classes |

            "/ We need to perform renames in stable order and, preferably,

            "/ in the prder in which they have been done. Following ensures

            "/ at least a stable order depending on order of renames.

            classes := self classesToFileOutFor: each.

            classes := classes select:[:cls | names includes: cls name ].

            classes := classes asArray sortBy:[ :a :b | (names indexOf: a name) < (names indexOf: b name) ].