"

 COPYRIGHT (c) 2015 by eXept Software AG

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libbasic3' }"

"{ NameSpace: Smalltalk }"

VSEFileSourceWriter subclass:#VSEPackageFileSourceWriter

	instanceVariableNames:'projectDefinitionClass classesToBeInitialized'

	classVariableNames:''

	poolDictionaries:''

	category:'Kernel-Classes-Support'

!

!VSEPackageFileSourceWriter class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 2015 by eXept Software AG

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    fileout in a format which can be read by visualAge.

    For transporting software.

"

!

examples

"

                                                        [exBegin]

    |s|

    s := 'test.st' asFilename writeStream.

    [

        VSEPackageFileSourceWriter new

            fileOut:OrderedCollection on:s

    ] ensure:[

        s close

    ]

                                                        [exEnd]

                                                        [exBegin]

    |s|

    s := '' writeStream.

    [

        VSEPackageFileSourceWriter new

            fileOut:OrderedCollection on:s

    ] ensure:[

        s close

    ].

    s contents

                                                        [exEnd]

"

! !

!VSEPackageFileSourceWriter methodsFor:'source writing'!

fileOut:aClass on:aStream withTimeStamp:stampIt withInitialize:initIt withDefinition:withDefinition methodFilter:methodFilter encoder:encoderOrNil

    |commentOrDocumentation skipDocumentationMethod|

    aStream nextPutAll:'Class '.

    aStream nextPutAll:(self rewrittenClassNameOf:aClass).

    aStream space.

    aClass superclass isNil ifTrue:[

        self error:'unimplemented: nil superclass'.

    ].

    aStream nextPutAll:(self rewrittenClassNameOf:aClass superclass).

    aStream nextPutLine:'!!'.

    skipDocumentationMethod := false.

    (commentOrDocumentation := aClass comment) isEmptyOrNil ifTrue:[

        (commentOrDocumentation := aClass commentOrDocumentationString) notEmptyOrNil ifTrue:[

            skipDocumentationMethod := true

        ].

    ].

    commentOrDocumentation notEmptyOrNil ifTrue:[

        self putEntry:'Property' value:'Comment' on:aStream.

        self putEntry:'' value:commentOrDocumentation on:aStream.

    ].

    aClass isVariable ifTrue:[

        aClass isPointers ifTrue:[

            aStream nextPutLine:'IndexableObject!!'.

        ] ifFalse:[

            self error:'unimplemented: non-pointer indexable'.

        ]

    ] ifFalse:[

        aStream nextPutLine:'NonIndexable!!'.

    ].

    aClass instanceVariableNames do:[:v |

        aStream nextPutLine:'InstanceVariable ',v,'!!'.

    ].

    aClass classVariableNames do:[:v |

        aStream nextPutLine:'ClassVariable ',v,'!!'.

    ].

    aClass class instanceVariableNames do:[:v |

        aStream nextPutLine:'ClassInstanceVariable ',v,'!!'.

    ].

    aClass realSharedPoolNames do:[:nm |      

        aStream nextPutLine:'Pool ',nm,'!!'.

    ].

    aClass methodDictionary keys asNewOrderedCollection sort do:[:sel |

        self fileOutMethod:(aClass methodDictionary at:sel) isExtension:false on:aStream.

    ].

    aClass class methodDictionary keys asNewOrderedCollection sort do:[:sel |

        (skipDocumentationMethod and:[sel == #documentation]) ifTrue:[

            "/ skip method

        ] ifFalse:[

            self fileOutMethod:(aClass class methodDictionary at:sel) isExtension:false on:aStream.

        ].

    ].

    self putEntry:'EndClass' value:nil on:aStream.

!

fileOutCategory:aCategory of:aClass except:skippedMethods only:savedMethods methodFilter:methodFilter on:aStream

    "file out all methods belonging to aCategory, aString onto aStream.

     If skippedMethods is nonNil, those are not saved.

     If savedMethods is nonNil, only those are saved.

     If both are nil, all are saved. See version-method handling in

     fileOut for what this is needed."

    |sortedSelectors first prevPrivacy privacy interestingMethods|

self halt:'should not be called'.

    interestingMethods := OrderedCollection new.

    aClass methodsDo:[:aMethod |

        |wanted|

        (methodsAlreadySaved includes:aMethod) ifFalse:[

            (aCategory = aMethod category) ifTrue:[

                (methodFilter isNil or:[methodFilter value:aMethod]) ifTrue:[

                    skippedMethods notNil ifTrue:[

                        wanted := (skippedMethods includesIdentical:aMethod) not

                    ] ifFalse:[

                        wanted := savedMethods isNil or:[ savedMethods includesIdentical:aMethod ].

                    ].

                    wanted ifTrue:[

                        aMethod selector isSymbol ifTrue:[

                            interestingMethods add:aMethod

                        ] ifFalse:[

                            Transcript showCR:'skipping non-symbol method ', aMethod selector printString.

                        ].

                    ].

                ]

            ]

        ]

    ].

    interestingMethods notEmpty ifTrue:[

        first := true.

        prevPrivacy := nil.

        "/

        "/ sort by selector

        "/

        sortedSelectors := interestingMethods collect:[:m | aClass selectorAtMethod:m].

        sortedSelectors sortWith:interestingMethods.

        interestingMethods do:[:eachMethod |

            privacy := eachMethod privacy.

            first ifFalse:[

                privacy ~~ prevPrivacy ifTrue:[

                    first := true.

                    aStream space.

                    aStream nextPutChunkSeparator.

                ].

                aStream cr; cr

            ].

            first ifTrue:[

                aStream nextPutChunkSeparator.

                aClass printClassNameOn:aStream.

                privacy ~~ #public ifTrue:[

                    aStream nextPutAll:' privateMethods'.

                ] ifFalse:[

                    aStream nextPutAll:' publicMethods'.

                ].

                aStream nextPutChunkSeparator; cr; cr.

                first := false.

            ].

            self fileOutMethod:eachMethod on:aStream.

            methodsAlreadySaved add:eachMethod.

            prevPrivacy := privacy.

        ].

        aStream space.

        aStream nextPutChunkSeparator.

        aStream cr

    ].

    aStream cr

!

fileOutDefinitionOf:aClass on:aStream

    "append an expression on aStream, which defines myself."

    |s owner ns superclass nm|

self halt:'should not be called'.

    owner := aClass owningClass.

    ns := aClass topNameSpace.

    "take care of nil-superclass"

    superclass := aClass superclass.

    superclass isNil ifTrue:[

        s := 'nil'

    ] ifFalse:[

        s := superclass nameWithNameSpacePrefix.

    ].

    aStream nextPutAll:s.   "/ superclass

    aStream space.

    aClass basicFileOutInstvarTypeKeywordOn:aStream.

    nm := aClass nameWithoutPrefix.

    aStream nextPut:$#.

    aStream nextPutAll:nm.

    aStream crtab.

    aStream nextPutAll:'instanceVariableNames:'''.

    aClass printInstVarNamesOn:aStream indent:16.

    aStream nextPutAll:''''.

    aStream crtab.

    aStream nextPutAll:'classVariableNames:'''.

    aClass printClassVarNamesOn:aStream indent:16.

    aStream nextPutAll:''''.

    aStream crtab.

    aStream nextPutAll:'poolDictionaries:'''.

    aClass printSharedPoolNamesOn:aStream indent:16.

    aStream nextPutAll:''''.

    aStream cr.

!

fileOutMethod:aMethod isExtension:isExtension on:aStream

    |sel mclass isMeta rewriteQuery originalSource possiblyRewrittenSource

     date time user whatVersion methodVersionString info sourceCodeManager|

    sel := aMethod selector.

    mclass := aMethod mclass.

    isMeta := mclass isMetaclass.

    projectDefinitionClass isNil ifTrue:[

        "/ 02/03/15 04:26:18 PM by unknown

        date := Date today.

        time := Time now.

        user := OperatingSystem getFullUserName.

        whatVersion := 'time exported'.

    ] ifFalse:[

        sourceCodeManager := projectDefinitionClass sourceCodeManager.

        isExtension ifTrue:[

            info := projectDefinitionClass extensionsRevisionInfoForManager:sourceCodeManager.

        ] ifFalse:[

            info := mclass theNonMetaclass revisionInfoOfManager:sourceCodeManager.

        ].

        date := Date readFrom:(info date).

        time := Time readFrom:(info time).

        user := info user.

        whatVersion := 'cvs version ',(info revision).

    ].

    methodVersionString := '%1 %2 by %3 (%4)'

                                bindWith:(date printStringFormat:'%m/%d/%Y')

                                with:(time printStringFormat:'%u:%m:%s %A')

                                with:user  

                                with:whatVersion.   

    originalSource := aMethod source.

    rewriteQuery := AbstractSourceFileWriter methodSourceRewriteQuery new.

    rewriteQuery method:aMethod source:originalSource.

    possiblyRewrittenSource := (rewriteQuery query) ? originalSource.

    isExtension ifTrue:[

        aStream nextPutAll:'MethodDefinition ',(self rewrittenClassNameOf:mclass theNonMetaclass).

    ] ifFalse:[

        aStream nextPutAll:'Method'.   

    ].

    isMeta ifTrue:[

        aStream nextPutLine:' class ',sel,'!!'.

    ] ifFalse:[

        aStream nextPutLine:' instance ',sel,'!!'.

    ].

    aStream space.

    self putString:possiblyRewrittenSource on:aStream.

    aStream nextPutLine:'!!'.

    self putEntry:'Property' value:'.Version' on:aStream.

    self putEntry:'' value:methodVersionString on:aStream.

    self putEntry:'Property' value:'Categories' on:aStream.

    self putEntry:'' value:aMethod category on:aStream.

!

putEntry:key value:value on:aStream

    key notNil ifTrue:[

        aStream nextPutAll:key.

    ].

    value notNil ifTrue:[

        aStream space.    

        self putString:value on:aStream

    ].

    aStream nextPutLine:'!!'.

!

putString:aString on:aStream

    "as the string is written (and should be counted) with cr-lf,

     count the returns and the size compute number"

    |numCRs|

    numCRs := aString occurrencesOf:Character cr.

    aStream nextPutAll:'<S'.

    aStream nextPutAll:(aString size + numCRs) asString.

    aStream nextPutAll:'>'.

    aStream nextPutAll:aString.

!

writeHeaderOn:aStream

    |releaseNr revisionNr author vsePackageName|

    releaseNr := 1.

    revisionNr := 1.

    author := OperatingSystem getFullUserName.

    projectDefinitionClass notNil ifTrue:[

        vsePackageName := projectDefinitionClass perform:#vsePackageName ifNotUnderstood:nil.

    ].

    vsePackageName isNil ifTrue:[

        |action optionLabels options|

        projectDefinitionClass notNil ifTrue:[

            optionLabels := #('Cancel' 'No, Browse' 'Yes').

            options := #(#abort #browse #yes)

        ] ifFalse:[

            optionLabels := #('Cancel' 'Yes').

            options := #(#abort #yes)

        ].

        action := OptionBox

                          request:(Dialog resources stringWithCRs:'No vsePackageName defined in ProjectDefinition.\\Proceed (using ST/X package name)?')

                          label:'VSE Package Export'

                          image:(WarningBox iconBitmap)

                          buttonLabels:(Dialog resources array:optionLabels)

                          values:options

                          default:(projectDefinitionClass isNil ifTrue:#abort ifFalse:#browse)

                          onCancel:#abort.

        action == #abort ifTrue:[

            AbortOperationRequest raise

        ].

        action == #browse ifTrue:[

            UserPreferences browserClass openInClass:projectDefinitionClass.

            AbortOperationRequest raise

        ].

    ].

    projectDefinitionClass notNil ifTrue:[

        releaseNr := projectDefinitionClass perform:#vseReleaseNr ifNotUnderstood:nil.

        releaseNr isNil ifTrue:[

            releaseNr := projectDefinitionClass revisionInfo majorVersion 

        ].

        revisionNr := projectDefinitionClass perform:#vseRevisionNr ifNotUnderstood:nil. 

        revisionNr isNil ifTrue:[

            revisionNr := projectDefinitionClass revisionInfo minorVersion 

        ].

        author := projectDefinitionClass perform:#vseAuthor ifNotUnderstood:nil.

        author isNil ifTrue:[

            author := projectDefinitionClass revisionInfo author 

        ].

    ].

    self putEntry:'Header' value:nil on:aStream.

    self putEntry:'Type ' value:'Package' on:aStream.

    self putEntry:'Format ' value:'ExtendedFileOut' on:aStream.

    self putEntry:'Version ' value:'1.0' on:aStream.

    self putEntry:'EndHeader' value:nil on:aStream.

    self putEntry:'Package ' value:(vsePackageName ? (projectDefinitionClass package) ? 'unnamed') on:aStream.

    self putEntry:'Property' value:'Release' on:aStream.

    self putEntry:nil value:(releaseNr asString) on:aStream.

    self putEntry:'Property' value:'RevisionNumber' on:aStream.

    self putEntry:nil value:(revisionNr asString) on:aStream.

    self putEntry:'Property' value:'Author' on:aStream.

    self putEntry:nil value:author on:aStream.

! !

!VSEPackageFileSourceWriter methodsFor:'utilities'!

fileOutPackage:packageID on:aStream

    |classesToFileout methodsToFileOut rewriter|

    projectDefinitionClass := packageID asPackageId projectDefinitionClass.

    classesToBeInitialized := OrderedCollection new.

    aStream lineEndCRLF.

    classesToFileout := classesToFileout reject:[:cls | cls isSubclassOf: ProjectDefinition ].

    classesToFileout topologicalSort:[:a :b | b isSubclassOf:a].

    rewriter := self class vseSourceRewriter new.

    rewriter classNamesToRewrite:classNameTranslations.

    methodsToFileOut := self extensionMethodsFor:packageID.

    self activityNotification:'checking for unportable unicode...'.

    classesToFileout do:[:eachClass |

        self ensureNoUnicodeInClass:eachClass

    ].

    methodsToFileOut do:[:eachClass |

        self ensureNoUnicodeInMethod:eachClass

    ].

    self writeHeaderOn:aStream.

    AbstractSourceFileWriter methodSourceRewriteQuery handle:[:rewriteQuery |

        |method source|

        method := rewriteQuery method.

        source := rewriteQuery source.

        source := rewriter rewriteMethod:method.

        rewriteQuery proceedWith:source.

    ] do:[

        classesToFileout do:[:eachClass |

            self activityNotification:'exporting ',eachClass name,'...'.

            self fileOut:eachClass on:aStream.

            (eachClass theMetaclass includesSelector:#initialize) ifTrue:[

                classesToBeInitialized add:eachClass.

            ].

        ].

        "/ fileout extensions

        self activityNotification:'exporting extensions...'.

        methodsToFileOut do:[:eachMethod |

            self fileOutMethod:eachMethod isExtension:true on:aStream.

            aStream cr.

        ].

    ].

    classesToBeInitialized notEmpty ifTrue:[

        |initializerCode|

        initializerCode := String 

            streamContents:[:s |

                classesToBeInitialized do:[:eachClass |

                    s nextPutLine:(self rewrittenClassNameOf:eachClass), ' initialize.'.

                ]

            ].

        self putEntry:'Initialization' value:initializerCode on:aStream.

    ].

    self activityNotification:'done.'.

! !

!VSEPackageFileSourceWriter class methodsFor:'documentation'!

version

!

version_CVS

! !