"

 COPYRIGHT (c) 2004 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:libbasic' }"

AbstractSourceFileWriter subclass:#SmalltalkChunkFileSourceWriter

	instanceVariableNames:'classBeingSaved methodsAlreadySaved generatingSourceForOriginal'

	classVariableNames:''

	poolDictionaries:''

	category:'Kernel-Classes-Support'

!

!SmalltalkChunkFileSourceWriter class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 2004 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

"

    I know how to write smalltalk chunk file format

"

! !

!SmalltalkChunkFileSourceWriter class methodsFor:'simple API'!

fileOut:aClass on:aStream

    self fileOut:aClass on:aStream withTimeStamp:true

        withInitialize:true withDefinition:true

        methodFilter:nil encoder:nil

!

fileOut:aClass on:aStream withTimeStamp:withTimeStamp

        withInitialize:initIt withDefinition:withDefinition

        methodFilter:methodFilter encoder:encoderOrNil

    self new

        fileOut:aClass on:aStream withTimeStamp:withTimeStamp

        withInitialize:initIt withDefinition:withDefinition

        methodFilter:methodFilter encoder:encoderOrNil

! !

!SmalltalkChunkFileSourceWriter class methodsFor:'utilities - source code'!

methodTemplate

    "return a method definition template string"

    |s|

    s := TextStream on:''.

    s nextPutAll:

'message selector and argument names

    "comment stating purpose of this message"

    |temporaries|

    statement.

    statement.

    "

     optional: comment giving example use

    "

'.

    s cr.

    s emphasis:(UserPreferences current commentEmphasisAndColor).

    s nextPutAll:

'"

 change the above template into real code;

 remove this comment.

 Then `accept'' either via the menu 

 or via the keyboard (usually CMD-A).

 You do not need this template; you can also

 select any existing methods code, change it,

 and finally `accept''. The method will then be

 installed under the selector as defined in the

 actual text - no matter which method is selected

 in the browser.

 Or clear this text, type in the method from scratch

 and install it with `accept''.

"

'.

    ^ s contents

!

versionMethodTemplateForCVS

    "careful to avoid expansion by cvs here!!"

    ^ ('version\    ^ ''$' , 'Header$''') withCRs

    "Created: / 21-08-2012 / 11:52:27 / cg"

! !

!SmalltalkChunkFileSourceWriter methodsFor:'accessing'!

generatingSourceForOriginal:aBoolean

    "if false (the default), the source of the current (in image) code is generated.

     That means, that any extension method which shadows some other original method,

     that extension method's code is generated.

     if true, the code of the original method is generated.

     Use a true value, when generating code for a SCM checkin operation, as then we do not

     want the extension to shadow the original"

    generatingSourceForOriginal := aBoolean.

! !

!SmalltalkChunkFileSourceWriter methodsFor:'source writing'!

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

    "file out my definition and all methods onto aStream.

     If stampIt is true, a timeStamp comment is prepended.

     If initIt is true, and the class implements a class-initialize method,

     append a corresponding doIt expression for initialization.

     The order by which the fileOut is done is used to put the version string at the end.

     Thus, if the version string is expanded (by CVS), the characterPositions of methods should not move"

    |collectionOfCategories comment versionMethods

     nonMeta meta classesImplementingInitialize outStream|

    classBeingSaved := nonMeta := aClass theNonMetaclass.

    meta := nonMeta class.

    methodsAlreadySaved := Set new.

    nonMeta isLoaded ifFalse:[

        ^ ClassDescription fileOutErrorSignal 

            raiseRequestWith:nonMeta

            errorString:' - will not fileOut unloaded class: ', nonMeta name

    ].

    encoderOrNil isNil ifTrue:[

        outStream := outStreamArg.

    ] ifFalse:[

        outStream := EncodedStream stream:outStreamArg encoder:encoderOrNil.

        outStream nextPutAll:'"{ Encoding: ' , encoderOrNil nameOfEncoding , ' }"'; cr; cr.

    ].

    "

     if there is a copyright method, add a copyright comment

     at the beginning, taking the string from the copyright method.

     We cannot do this unconditionally - that would lead to my copyrights

     being put on your code ;-).

     On the other hand: I want every file created by myself to have the

     copyright string at the beginning be preserved .... even if the

     code was edited in the browser and filedOut.

    "

    self generateHeaderWithCopyrightOn:outStream.

    stampIt ifTrue:[

        "/

        "/ first, a timestamp

        "/

        self generateTimestampOn:outStream.

    ].

    withDefinition ifTrue:[

        "/

        "/ then the definition(s)

        "/

        self fileOutAllDefinitionsOf:nonMeta on:outStream.

        "/

        "/ a comment - if any

        "/

        (comment := nonMeta comment) notNil ifTrue:[

            nonMeta fileOutCommentOn:outStream.

        ].

        "/

        "/ ST/X primitive definitions - if any

        "/

        nonMeta fileOutPrimitiveSpecsOn:outStream.

    ].

    "/

    "/ methods from all categories in metaclass (i.e. class methods)

    "/ EXCEPT: the version method is placed at the very end, to

    "/         avoid sourcePosition-shifts when checked out later.

    "/         (RCS expands this string, so its size is not constant)

    "/

    collectionOfCategories := meta categories asSortedCollection.

    versionMethods := meta methodDictionary values select:[:mthd | mthd isVersionMethod].

    collectionOfCategories notNil ifTrue:[

        "/

        "/ documentation first (if any), but not the version method

        "/

        (collectionOfCategories includes:'documentation') ifTrue:[

"/            versionMethods do:[:versionMethod |

"/                |source|

"/

"/                source := versionMethod source.

"/                (source isEmptyOrNil or:[(source startsWith:nonMeta nameOfOldVersionMethod) not]) ifTrue:[

"/                    "something bad happend to the classes code"

"/

"/                    Class fileOutErrorSignal 

"/                        raiseRequestWith:aClass

"/                        errorString:' - bad source for version method (uncompiled class file?): ', (versionMethod displayString)

"/                ].

"/            ].

            self fileOutCategory:'documentation' of:meta except:versionMethods only:nil methodFilter:methodFilter on:outStream.

        ].

        "/

        "/ initialization next (if any)

        "/

        (collectionOfCategories includes:'initialization') ifTrue:[

            self fileOutCategory:'initialization' of:meta methodFilter:methodFilter on:outStream.

        ].

        "/

        "/ instance creation next (if any)

        "/

        (collectionOfCategories includes:'instance creation') ifTrue:[

            self fileOutCategory:'instance creation' of:meta methodFilter:methodFilter on:outStream.

        ].

        collectionOfCategories do:[:aCategory |

            ((aCategory ~= 'documentation')

            and:[(aCategory ~= 'initialization')

            and:[aCategory ~= 'instance creation']]) ifTrue:[

                self fileOutCategory:aCategory of:meta methodFilter:methodFilter on:outStream.

            ]

        ]

    ].

    "/ if there are any primitive definitions (vw-like ffi-primitives),

    "/ file them out first in the order: defines, types.

    "/ Otherwise, we might have trouble when filing in later, because the types are needed

    "/ for the primitive calls.

    nonMeta methodDictionary keysAndValuesDo:[:sel :m |

        m isVisualWorksTypedef ifTrue:[

            self fileOutCategory:m category of:nonMeta except:nil only:(Array with:m) methodFilter:methodFilter on:outStream.

        ].

    ].

    "/

    "/ methods from all categories

    "/

    collectionOfCategories := nonMeta categories asSortedCollection.

    collectionOfCategories notNil ifTrue:[

        collectionOfCategories do:[:aCategory |

            self fileOutCategory:aCategory of:nonMeta methodFilter:methodFilter on:outStream.

        ]

    ].

    "/

    "/ any private classes' methods

    "/

    nonMeta privateClassesSorted do:[:aClass |

        self fileOutAllMethodsOf:aClass on:outStream methodFilter:methodFilter

    ].

    "/

    "/ finally, the previously skipped version method

    "/

    versionMethods notEmpty ifTrue: [

        self fileOutCategory:'documentation' of:meta except:nil only:versionMethods methodFilter:methodFilter on:outStream.

    ].

    initIt ifTrue:[

        "/

        "/ optionally an initialize message

        "/

        classesImplementingInitialize := OrderedCollection new.

        (meta includesSelector:#initialize) ifTrue:[

            classesImplementingInitialize add:nonMeta

        ].

        nonMeta privateClassesSorted do:[:aPrivateClass |

            (aPrivateClass theMetaclass includesSelector:#initialize) ifTrue:[

                classesImplementingInitialize add:aPrivateClass

            ]

        ].

        classesImplementingInitialize size ~~ 0 ifTrue:[

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

            outStream cr.

            classesImplementingInitialize do:[:eachClass |

                eachClass printClassNameOn:outStream. outStream nextPutAll:' initialize'.

                outStream nextPutChunkSeparator.

                outStream cr.

            ].

        ].

    ]

    "Created: / 15-11-1995 / 12:53:06 / cg"

    "Modified: / 01-04-1997 / 16:01:05 / stefan"

    "Modified: / 29-09-2011 / 14:53:49 / cg"

!

fileOutAllDefinitionsOf:aNonMetaClass on:aStream

    "append expressions on aStream, which defines myself and all of my private classes."

    |s|

    s := CharacterWriteStream on:(String new:50).

    aStream nextChunkPut:(s contents).

    "/ self fileOutDefinitionOf:aNonMetaClass on:aStream.

    "/ aStream nextPutChunkSeparator. 

    aStream cr; cr.

    "/

    "/ optional classInstanceVariables

    "/

    aNonMetaClass class instanceVariableString isBlank ifFalse:[

        aNonMetaClass fileOutClassInstVarDefinitionOn:aStream.

        aStream nextPutChunkSeparator. 

        aStream cr; cr

    ].

    "/ here, the full nameSpace prefixes are output,

    "/ to avoid confusing stc 

    "/ (which otherwise could not find the correct superclass)

    "/

    Class fileOutNameSpaceQuerySignal answer:false do:[

        Class forceNoNameSpaceQuerySignal answer:true do:[

            aNonMetaClass privateClassesSorted do:[:aClass |

            ]

        ]

    ].

!

fileOutAllMethodsOf:aClass on:aStream methodFilter:methodFilter

    |collectionOfCategories|

    collectionOfCategories := aClass class categories asSortedCollection.

    collectionOfCategories notNil ifTrue:[

        collectionOfCategories do:[:aCategory |

            self fileOutCategory:aCategory of:aClass class  methodFilter:methodFilter on:aStream.

        ]

    ].

    collectionOfCategories := aClass categories asSortedCollection.

    collectionOfCategories notNil ifTrue:[

        collectionOfCategories do:[:aCategory |

            self fileOutCategory:aCategory of:aClass methodFilter:methodFilter on:aStream.

        ]

    ].

    aClass privateClassesSorted do:[:aClass |

        self fileOutAllMethodsOf:aClass on:aStream methodFilter:methodFilter

    ].

    "Created: 15.10.1996 / 11:13:00 / cg"

    "Modified: 22.3.1997 / 16:12:17 / cg"

!

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

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

        "/

        "/ sort by selector

        "/

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

        sortedSelectors sortWith:interestingMethods.

        generatingSourceForOriginal == true ifTrue:[

            "/ care for methods which have been shadowed by an extension from another package!!

            (prjDef := aClass theNonMetaclass projectDefinitionClass) notNil ifTrue:[

                prjDef hasSavedOverwrittenMethods ifTrue:[

                    interestingMethods := interestingMethods collect:[:m |

                                                |originalOrNil|

                                                (m package ~~ aClass package) ifTrue:[ 

                                                    originalOrNil := prjDef savedOverwrittenMethods at:(aClass name -> m selector) ifAbsent:nil.

                                                    originalOrNil notNil ifTrue:[ 

                                                        self breakPoint:#cg 

                                                    ].

                                                ].

                                                originalOrNil ? m

                                          ].

                ]

            ].

        ].

        first := true.

        prevPrivacy := nil.

        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 space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.

                ] ifFalse:[

                    aStream nextPutAll:' methodsFor:'.

                ].

                cat := aCategory.

                cat isNil ifTrue:[ cat := '' ].

                aStream nextPutAll:aCategory asString storeString.

                aStream nextPutChunkSeparator; cr; cr.

                first := false.

            ].

            self fileOutMethod:eachMethod on:aStream.

            methodsAlreadySaved add:eachMethod.

            prevPrivacy := privacy.

        ].

        aStream space.

        aStream nextPutChunkSeparator.

        aStream cr

    ].

    aStream cr

    "Modified: 28.8.1995 / 14:30:41 / claus"

    "Modified: 12.6.1996 / 11:37:33 / stefan"

    "Modified: 15.11.1996 / 11:32:21 / cg"

    "Created: 1.4.1997 / 16:04:33 / stefan"

!

fileOutCategory:aCategory of:aClass methodFilter:methodFilter on:aStream

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

    self fileOutCategory:aCategory of:aClass except:nil only:nil methodFilter:methodFilter on:aStream

    "Created: 1.4.1997 / 16:04:44 / stefan"

!

fileOutCommentEndOn:aStream

    "Writes a comment end mark on aStream."

    "/ intentionally left blank - make each line an EOL-comment instead

!

fileOutCommentLine:aString on:aStream

    "Writes a single line of comment on a comment to a stream."

    aStream 

        nextPutAll:'"/ ';

        nextPutAll: aString

!

fileOutCommentStartOn:aStream