"

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

SCMAbstractTask subclass:#SCMAbstractFileoutLikeTask

	instanceVariableNames:'suppressClasses suppressExtensions suppresBuildSupportFiles

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

"

! !

!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 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: / 17-11-2010 / 14:08:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

packageDefinition

    ^self package definition

    "Created: / 27-11-2009 / 11:27:21 / 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

    | wcroot containers |

    ActivityNotification notify:'Adding new containers'.

    containers := 

        self isSelectiveFileoutTask 

            ifTrue:[#()] 

            ifFalse:[self containersToFileOut].

    wcroot := self temporaryWorkingCopyRoot.

    containers do:[:nm|

        | entry |

        entry := wcroot / nm.

        entry track.

    ]

    "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: / 15-11-2012 / 00:14:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doCompileCopyrightMethods

    | klasses source |

    (self packageDefinition class includesSelector: #copyright) ifFalse:[^self].

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

    klasses := self classesToFileOut asArray.

    source := (self packageDefinition class compiledMethodAt: #copyright) source.

    klasses 

        withIndexDo:[:cls :index | 

            |metaCls|

            metaCls := cls theMetaclass.

            (((metaCls includesSelector:#copyright) not) and:[metaCls programmingLanguage isSmalltalk])

                ifTrue:[

                    metaCls compile:source classified:'documentation'.

                    (metaCls compiledMethodAt:#copyright) 

                        setPackage:self package name asSymbol

                    ].

            ProgressNotification newException

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

                                                      with:cls nameWithoutPrefix);

                parameter: (100 / klasses size) * index;

                raiseRequest.

        ]

    "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: / 30-06-2013 / 12:44:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doCompileVersionMethods

    |klasses versionMethodName|

    versionMethodName := self package manager nameOfVersionMethodInClasses.

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

    klasses := self classesToFileOut asArray.

    klasses 

        withIndexDo:[:cls :index | 

            |metaCls|

            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:self package manager)

                            classified:'documentation'.

                        (metaCls compiledMethodAt:versionMethodName) 

                            setPackage:self package name asSymbol

                    ].

            self package manager utilities ensureCorrectVersionMethodsInClass: cls usingManager: self package manager.

            ^ ProgressNotification newException

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

                                                      with:cls nameWithoutPrefix);

                parameter: (100 / klasses size) * index;

                raiseRequest     

        ].

    self extensionMethodsToFileOut notEmpty ifTrue:[

        | def |

        "TODO: Not programming language aware..."

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

            def class 

                compile:

                    (self package manager versionMethodTemplateForSmalltalkFor:self package manager nameOfVersionMethodForExtensions)

                classified: #documentation.

            (def class compiledMethodAt:self package manager nameOfVersionMethodForExtensions) 

                setPackage:self package name asSymbol

        ]

    ]

    "Created: / 28-05-2008 / 07:43:43 / Jan Vrany <vranyj1@fel.cvut.cz>"

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

    "Modified: / 07-07-2011 / 20:15:21 / jv"

    "Modified: / 30-06-2013 / 12:43:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doFileOut

    "Fileouts everything to the working copy"

    self

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

!

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

    |klasses|

    suppressClasses == true ifTrue:[^self].

    ActivityNotification notify:'Filing out package classes'.

    klasses := self classesToFileOut asArray.

    klasses 

        withIndexDo:[:cls :index | 

            |clsStream|

            ProgressNotification newException

                messageText: 'Filing out ' , cls nameWithoutPrefix;

                parameter: (100 / klasses size) * index;

                raiseRequest.

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

        ].

    "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: / 30-06-2013 / 00:16:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doFileOutPackageExtensions

    suppressExtensions == true ifTrue:[^self].

    self extensionMethodsToFileOut isEmpty ifTrue:[^self].

    self package fileOutExtensions: self extensionMethodsToFileOut

    "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: / 07-10-2012 / 10:56:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doInitStateVariables

    packageClassesChanged := self package classesHasChanged.

    packageExtensionsChanged := self package 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: / 06-10-2012 / 23:28:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doRemoveOldContainers

    | wcroot containers containersToKeep containersToDelete |

    self isSelectiveFileoutTask ifTrue:[

        ^ self

    ].

    ActivityNotification notify:'Removing old containers'.

    wcroot := package temporaryWorkingCopyRoot.

    containers := self package containers.

    containersToKeep := self package containersToKeep.

    containersToDelete := containers \ containersToKeep.

    containersToDelete do:[:nm|

        | entry |

        entry := wcroot / nm.

        entry remove

    ]

    "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: / 15-11-2012 / 00:54:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doRenameContainerForClassNamed: new using: renames language: lang

    | wcroot old oldC oldE newC newE |

    old := renames at: new.

    (renames includesKey: old) ifTrue:[

        self doRenameContainerForClassNamed: old using: renames language: lang.

    ].

    wcroot := package temporaryWorkingCopyRoot.

    oldC := self package containerNameForClassNamed: old language: lang .

    newC := self 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: / 21-11-2012 / 00:43:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doRenameContainers

    | renames |

    renames := Dictionary new.

    ChangeSet current do:

                [:chg|

                chg isClassRenameChange ifTrue:[

                    renames at: chg className put: chg oldName.

                ]].

    self classesToFileOut do:[:cls|

        (renames includesKey: cls name) ifTrue:[

            self doRenameContainerForClassNamed: cls name using: renames language: cls programmingLanguage.

        ]        

    ]

    "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:13:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doUpdateBuildSupportFiles

    |pkgDef|

    suppresBuildSupportFiles == true ifTrue:[

        ^self.

    ].

    pkgDef := self package definition.

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

        ^self.

    ].

    ActivityNotification notify:'Updating build files'.

    "First, generate files into a temporary files - so originals

     are not destroyed when something goes wrong."

    self filesToGenerate do:[:supportFileName | 

        | supportFile |

        supportFile := self temporaryWorkingCopyRoot / (supportFileName , '.tmp').

        (packageClassesChanged or:[ supportFile exists not ]) ifTrue:[

            ActivityNotification notify:'Updating ' , supportFileName.

            supportFile directory exists ifFalse: [supportFile directory makeDirectory].

            supportFile writingFileDo:[:s|

                    s nextPutAll:(self for: pkgDef generateFile:supportFileName)

            ]

        ]

    ].

    "Now, copy them over the old files"

    self filesToGenerate do:[:supportFileName |

        | supportFile supportFileTmp |

        supportFile := package temporaryWorkingCopyRoot / supportFileName.

        supportFileTmp := package temporaryWorkingCopyRoot / (supportFileName , '.tmp').

        supportFileTmp moveTo: supportFile.

        supportFile track.

    ].

    "Created: / 20-06-2009 / 16:01:16 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 21-06-2009 / 15:18:17 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 12-01-2013 / 13:54:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

doUpdateCode

    "Updates project definitions and compiles version/copyright methods"

    self

        doInitStateVariables;

        doCompileVersionMethods;

        doCompileCopyrightMethods;

        doUpdateProjectDefinition.

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

!

doUpdateProjectDefinition

    | prjClass classesSpec classNamesAndAttributesMap |

    (packageClassesChanged | packageExtensionsChanged) ifFalse:[

        ^ self

    ].

    ActivityNotification notify:'Updating project definition'.

    prjClass := ProjectDefinition definitionClassForPackage:self package name createIfAbsent:true.

    "/Update classlist beforehand - to care about order and removals...

    classNamesAndAttributesMap := Dictionary new.

    prjClass classNamesAndAttributes do:[:nameOrPair |

        nameOrPair isArray 

            ifTrue:[classNamesAndAttributesMap at: nameOrPair first put: nameOrPair]

            ifFalse:[classNamesAndAttributesMap at: nameOrPair put: (Array with: nameOrPair)]

    ].

    classesSpec := prjClass searchForClasses collect:[:cls|

        classNamesAndAttributesMap at: cls name ifAbsent:[Array with: cls name]

    ].

    prjClass classNamesAndAttributes:classesSpec usingCompiler:nil.

    "/Now do standard update

    Class packageQuerySignal answer:prjClass package do:[

        prjClass theNonMetaclass 

            forEachContentsMethodsCodeToCompileDo:[:code :category |

                (code startsWith: 'excludedFromPreRequisites')

                    ifFalse:[prjClass theMetaclass compile:code classified:category]

            ]

            "/ignoreOldEntries: false

            ignoreOldDefinition: false

    ]

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

    "Modified: / 13-08-2009 / 09:13:14 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 19-03-2013 / 10:35:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SCMAbstractFileoutLikeTask methodsFor:'private'!

classesToFileOut

    suppressClasses == true ifTrue:[^#()].

    ^ self package classesFiltered:

            [:class |

            class isLoaded and: [ classes isNil or: [ classes includes: class ] ] ]

    "Created: / 23-03-2009 / 12:08:24 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 11-06-2009 / 18:17:38 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 06-10-2012 / 23:28:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

containersToFileOut

    | containers extensions |

    containers := self classesToFileOut

                collect: [:class | package containerNameForClass: class ].

    ^ containers

    "Created: / 14-05-2009 / 11:35:05 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

extensionMethodsToFileOut

    ^ self package extensionsFiltered:

            [:mth |

            extensionMethods isNil or: [ extensionMethods includes: mth ] ]

    "Created: / 14-05-2009 / 11:32:01 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 06-10-2012 / 23:28:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

for: def generateFile: file

    | contents savedClassFilenames |

    file ~= 'abbrev.stc' ifTrue:[^def generateFile: file].

    "Yet another kludge to trick Smalltalk>>fileNameForClass:, sigh"

    savedClassFilenames := Dictionary new.

    (def searchForClasses reject:[:e|e owningClass notNil]) do:

        [:cls|

        savedClassFilenames 

            at: cls

            put: cls getClassFilename.

        cls setClassFilename: (self package containerNameForClass: cls)].