"
COPYRIGHT (c) 2020-2022 LabWare
"
"{ 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
"
COPYRIGHT (c) 2020-2022 LabWare
"
!
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:'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 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.
].
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:[
class isPackageManifest ifFalse: [
transformed definitions remove: definition.
]
].
]
"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>"
"Modified: / 29-11-2021 / 14:47:19 / Jan Vrany <jan.vrany@labware.com>"
!
visitMethodDefinition: definition
| class source |
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 >> porter.
definition accept: original options porter.
"/ 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: / 25-07-2022 / 11:05:48 / 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> $'
! !