"

"

"{ Package: 'stx:goodies/monticello' }"

"{ NameSpace: Smalltalk }"

MCStXSnapshotTransformation subclass:#MCStXSnapshotPreWriteTransformation

	instanceVariableNames:'extensionMethodCategoryMap projectDefinition includeExtrasForSTX'

	classVariableNames:''

	poolDictionaries:''

	category:'SCM-Monticello-St/X Storing'

!

!MCStXSnapshotPreWriteTransformation class methodsFor:'documentation'!

copyright

"

"

!

documentation

"

    documentation to be added.

    [author:]

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

    [instance variables:]

    [class variables:]

    [see also:]

"

! !

!MCStXSnapshotPreWriteTransformation methodsFor:'accessing'!

monticelloName

    | def code package |

    def := self projectDefinition.

    def notNil ifTrue:[^ def monticelloName].

    "/ No project definition - the package is proably

    "/ pure Monticello / Tonel package with no St/X extras.

    "/ 

    "/ Since all we have now is just a snapshot, we have to look

    "/ at any class or method definition and get the package name

    "/ from there.

    code := original definitions detect: [:e | e isClassDefinition ] ifNone: [ nil ].

    code notNil ifTrue: [

        package := code actualClass package.

    ] ifFalse: [ 

        "/ Look for some method definition

        code := original definitions detect: [:e | e isMethodDefinition ] ifNone: [ nil ].

        code notNil ifTrue: [ 

            package := (code actualClass compiledMethodAt: code selector) package.

        ].

    ].

    "/ If package DOES NOT look like Smalltalk/X package name,

    "/ return it...

    (package notNil and:[ package includesAny:':/']) ifFalse: [ 

         ^ package

    ].

    "/ ...otherwise, we cannot make a guess.

    self error: 'Cannot guess (monticello) package name!!'

    "Created: / 31-05-2013 / 00:12:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 28-10-2021 / 15:52:39 / Jan Vrany <jan.vrany@labware.com>"

!

projectDefinition

    original definitions reverseDo:[:d|

        | c |

        (d isClassDefinition

            and:[(c := d actualClass) notNil

                and:[c isProjectDefinition]])

                    ifTrue:[ ^ c  ]

    ].

    ^nil

    "Created: / 31-05-2013 / 00:23:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 31-05-2013 / 10:45:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!MCStXSnapshotPreWriteTransformation methodsFor:'accessing - templates'!

monticelloSmalltalkXExtensionMethodCategories_Code

^

'monticelloSmalltalkXExtensionMethodCategor

    "Returns an array of triples (class name, selector , St/X category)

     This information is used by Smalltalk/X when reading back Monticello package

     to patch methods category as in Monticello extensions must have funny name

     to be recognized by Monticello as extensions."

    ^#(

%1

    )

'

    "Created: / 31-05-2013 / 00:20:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

monticelloSmalltalkXProjectType_Code

^

'monticelloSmalltalkXProjectType

    "Returns either #library or #application.

     This information is used by Smalltalk/X when reading back Monticello package

     to patch my superclass as neither LibraryDefinition nor ApplicationDefinition classes

     are present in Squeak/Pharo images."

    ^%1

'

    "Created: / 30-05-2013 / 12:42:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!MCStXSnapshotPreWriteTransformation methodsFor:'private'!

withoutNamespacePrefix: className

    "Strip Smalltalk/X-style namespace from given `className` (if any)"

    | lastColonIndex |

    lastColonIndex := className lastIndexOf: $:.

    lastColonIndex ~~ 0 ifTrue: [

        ^ className copyFrom: lastColonIndex + 1

    ].            

    ^ className

    "Created: / 20-09-2022 / 11:09:33 / Jan Vrany <jan.vrany@labware.com>"

! !

!MCStXSnapshotPreWriteTransformation methodsFor:'testing'!

isExtensionMethodDefinition: definition

    ^(transformed includesClassNamed: definition className) not

    "Created: / 30-05-2013 / 22:48:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 31-05-2013 / 01:16:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

isSmalltalkXPackage

    ^ projectDefinition notNil

    "Created: / 12-06-2013 / 09:22:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!MCStXSnapshotPreWriteTransformation methodsFor:'transforming'!

transform: anMCSnapshot

    "Returns a transformed **copy** of the original snapshot"

    includeExtrasForSTX := anMCSnapshot options includeExtrasForSTX.

    extensionMethodCategoryMap := OrderedCollection new.

    original := anMCSnapshot.

    projectDefinition := self projectDefinition.

    super transform: anMCSnapshot.

    includeExtrasForSTX ifTrue:[

        (projectDefinition notNil and:[projectDefinition isPackageManifest not and:[extensionMethodCategoryMap notEmpty]]) ifTrue:[

            | source |

            source :=

                self monticelloSmalltalkXExtensionMethodCategories_Code bindWith:

                    (String streamContents:[:s|

                        extensionMethodCategoryMap do:[:entry|

                            s tab; tab; nextPutLine:  entry storeString

                        ].

                    ]).

             transformed definitions addFirst:

                (MCMethodDefinition

                    className:  projectDefinition name

                    classIsMeta: true

                    selector: 'monticelloSmalltalkXExtensionMethodCategories'

                    category: 'accessing - monticello'

                    timeStamp: 'Generated by ', self class name , ' at ' , Timestamp now printString

                    source: source)

        ].

    ].

    ^transformed.

    "Created: / 31-05-2013 / 00:05:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 07-09-2015 / 15:28:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 29-11-2021 / 14:46:02 / Jan Vrany <jan.vrany@labware.com>"

! !

!MCStXSnapshotPreWriteTransformation methodsFor:'visiting'!

visitClassComment: definition

    | comment source |

    comment := definition comment asStringWithNativeLineEndings."/ Make sure comment has native line endings

    comment := comment spacesToTabs.                            "/ Make sure there are only tabs (norm on Squeak / Pharo)

    comment := comment asStringWithSqueakLineEndings.           "/ Make sure comment has Squeak line endings

    comment := comment asSingleByteStringIfPossible.            "/ Convert to single byte string

    definition comment: comment.     

    source := definition source asStringWithNativeLineEndings.  "/ Make sure source has native line endings

    source := source spacesToTabs.                              "/ Make sure there are only tabs (norm on Squeak / Pharo)

    source := source asStringWithSqueakLineEndings.             "/ Make sure source has Squeak line endings

    source := source asSingleByteStringIfPossible.              "/ Convert to single byte string

    definition source: source.

    "Created: / 17-09-2021 / 12:12:39 / Jan Vrany <jan.vrany@labware.com>"

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

!

visitClassDefinition: definition

    "

     save ProjectDefinition classes with Object as superclass   

     (because ProjectDefinition is not present in Pharo/Squeak).

     When reading back into ST/X, the PostReadTransformation undoes this

    "

    | comment exporter class |

    comment := definition commentOrNil.

    comment notNil ifTrue: [

        comment := definition comment asStringWithNativeLineEndings."/ Make sure comment has native line endings

        comment := comment spacesToTabs.                            "/ Make sure there are only tabs (norm on Squeak / Pharo)

        comment := comment asStringWithSqueakLineEndings.           "/ Make sure comment has Squeak line endings

        comment := comment asSingleByteStringIfPossible.            "/ Convert to single byte string

        definition comment: comment.     

    ].

    includeExtrasForSTX ifFalse: [ 

        definition className: (self withoutNamespacePrefix: definition className).

        definition superclassName: (self withoutNamespacePrefix: definition superclassName)

    ].

    exporter := original options exporter.

    exporter notNil ifTrue: [ definition accept: exporter].   

    class := definition actualClass.

    (class isProjectDefinition) ifTrue:[

        includeExtrasForSTX ifTrue:[            

            definition

    "/            className:(definition className capitalized);

                superclassName: #PackageManifest;

                category: class monticelloName.

            transformed definitions addFirst:

                (MCMethodDefinition

                    className: definition className

                    classIsMeta: true

                    selector: 'monticelloProjectDefinitionTypeName'

                    category: 'accessing - monticello'

                    timeStamp: 'Generated by ', self class name , ' at ' , Timestamp now printString

                    source:

                        (self monticelloSmalltalkXProjectType_Code bindWith: (class isApplicationDefinition ifTrue:[#application] ifFalse:[#library]) storeString))

        ] ifFalse:[

            ]

        ].

    ].

    "Created: / 29-05-2013 / 12:19:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 31-07-2015 / 09:22:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

visitMethodDefinition: definition

    | class source exporter |

    class := definition actualClass.

    includeExtrasForSTX ifFalse:[

        "/ Remove all version_XX methods

        (AbstractSourceCodeManager isVersionMethodSelector: definition selector) ifTrue:[

            transformed definitions remove: definition.

        ].

        "/ If St/X extras should not be included, then remove all methods

        "/ that belong to project definition class.

        (class theNonMetaclass == projectDefinition and:[projectDefinition isPackageManifest not]) ifTrue:[ 

            transformed definitions remove: definition ifAbsent: [ "Might have been removed in previous step" ].

            ^ self.

        ].

    ].

    "/ Use source porter to perform automagic porting.

    "/ See MCSnapshotOptions >> exporter.

    exporter := original options exporter.

    exporter notNil ifTrue: [ definition accept: exporter].   

    includeExtrasForSTX ifFalse: [ 

        definition className: (self withoutNamespacePrefix: definition className)  

    ]. 

    "/ Now a horrible hack - do not read the chunk below.

    "/ In Squeak / Pharo world, the method source does not

    "/ (shall not?) contain trailing new lines. St/X browser,

    "/ OTOH, puts a trailing new line in methods' source.

    "/ 

    "/ So, when code is loaded into St/X and modified then saved 

    "/ back, it adds an spurious extra trailing line. This creates

    "/ a noise, especially when using Tonel.

    "/ 

    "/ It gets worse. I (JV) did not pay attention to this problem

    "/ before and start hacking, already adding a spurious new lines

    "/ to considerable codebase - too bad.

    "/ 

    "/ To fix while avoiding noise in diffs, we remove trailing newlines

    "/ for modified methods. However, we have to save back source without

    "/ trailing new lines to the method itself so that when the package is

    "/ saved again from the same image, it won't add the new line (because

    "/ second time the method is no longer 'modified').

    "/ 

    "/ Complicated, isn't it? Stupid, isn't it?

    source := definition source.

    (source last == Character lf or: [ source last == Character return ]) ifTrue: [ 

        (ChangeSet current includesChangeForClass: class selector: definition selector) ifTrue: [ 

            | method |

            source := source withoutTrailingSeparators.

            method := class compiledMethodAt: definition selector.

            method source: source.

        ].

    ].

    source := source asStringWithNativeLineEndings.  "/ Make sure source has native line endings

    source := source spacesToTabs.                              "/ Make sure there are only tabs (norm on Squeak / Pharo)

    source := source asStringWithSqueakLineEndings.             "/ Make sure source has Squeak line endings

    source := source asSingleByteStringIfPossible.              "/ Convert to single byte string

    definition source: source.

    (self isExtensionMethodDefinition: definition) ifTrue:[

        | prefix |

        prefix := '*' , self monticelloName asLowercase.

        (definition category asLowercase startsWith: prefix) ifFalse:[

            extensionMethodCategoryMap add:

                (Array

                    with: definition className , (definition classIsMeta ifTrue:[' class'] ifFalse:[''])

                    with: definition selector

                    with: definition category).

            definition category: '*' , self monticelloName.

        ]

    ].

    "Created: / 30-05-2013 / 22:48:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 10-05-2015 / 15:08:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 20-09-2022 / 16:56:55 / Jan Vrany <jan.vrany@labware.com>"

!

visitOrganizationDefinition: defintion

    "Add a category in which project definition class is..."

    | categories |

    projectDefinition notNil ifTrue: [

        categories := defintion categories.

        (categories includes: projectDefinition monticelloName) ifFalse:[

            categories := categories copyWith: projectDefinition monticelloName asSymbol.

            defintion categories: categories.

        ].

    ].

    "Created: / 05-10-2014 / 00:59:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 04-05-2021 / 11:42:08 / Jan Vrany <jan.vrany@labware.com>"

! !

!MCStXSnapshotPreWriteTransformation class methodsFor:'documentation'!

version

    ^ '$Header: /cvs/stx/stx/goodies/monticello/MCStXSnapshotPreWriteTransformation.st,v 1.11 2015-03-30 19:54:21 cg Exp $'

!

version_CVS

    ^ '$Header: /cvs/stx/stx/goodies/monticello/MCStXSnapshotPreWriteTransformation.st,v 1.11 2015-03-30 19:54:21 cg Exp $'

!

version_HG

    ^ '$Changeset: <not expanded> $'

! !