CodeGeneratorTool.st
author Claus Gittinger <cg@exept.de>
Fri, 06 Dec 2002 11:44:20 +0100
changeset 4351 cc4739c4797b
parent 4108 19af32811dfd
child 4444 6b077945517c
permissions -rw-r--r--
create test methods

"{ Package: 'stx:libtool' }"

Object subclass:#CodeGeneratorTool
	instanceVariableNames:''
	classVariableNames:''
	poolDictionaries:''
	category:'Interface-Browsers'
!

!CodeGeneratorTool class methodsFor:'documentation'!

documentation
"
    extracted code generation stuff from old and newBrowser.
    There is probably more to gome...

    [author:]
        Claus Gittiner
"
! !

!CodeGeneratorTool class methodsFor:'code generation'!

createAccessMethodsFor:aCollectionOfVarNames in:aClass withChange:withChange asValueHolder:asValueHolder readersOnly:readersOnly writersOnly:writersOnly
    "workhorse for creating access methods for instvars."

    |classesClassVars|

    classesClassVars := aClass theNonMetaclass allClassVarNames.

    aCollectionOfVarNames do:[:name |
        |source varType methodName|

        varType := (classesClassVars includes:name) 
                        ifTrue:['static'] 
                        ifFalse:[
                            (aClass isMeta ifTrue:['classInstVar'] ifFalse:['instance'])].

        methodName := name.
        name first isUppercase ifTrue:[
            methodName := methodName asLowercaseFirst. 
        ].

        writersOnly ifFalse:[
            "check, if method is not already present"
            (aClass includesSelector:(methodName asSymbol)) ifFalse:[
                asValueHolder ifTrue:[
                    source := methodName
                               , '\    "return/create the ''%2'' value holder (automatically generated)"\\' 
                               , '    %2 isNil ifTrue:[\'
                               , '        %2 := ValueHolder new.\'.
                    withChange ifTrue:[
                    source := source
                               , '        %2 addDependent:self.\'.
                    ].
                    source := source
                               , '    ].\'
                               , '    ^ %2'.
                ] ifFalse:[
                    source := methodName
                               , '\    "return the value of the %1 variable ''%2'' (automatically generated)"\\' 
                               , '    ^ %2'.
                ].
                source := (source bindWith:varType with:name) withCRs.
                self compile:source forClass:aClass inCategory:(asValueHolder ifTrue:['aspects'] ifFalse:['accessing']).
            ] ifTrue:[
                Transcript showCR:'method ''', methodName , ''' already present'
            ].
        ].

        readersOnly ifFalse:[
            (aClass includesSelector:((methodName , ':') asSymbol)) ifFalse:[
                asValueHolder ifTrue:[
                    source := methodName
                              , ':something\    "set the ''%2'' value holder'.
                    withChange ifTrue:[
                        source := source
                                  , ' (automatically generated)"\\'
                                  , '    |oldValue newValue|\\'
                                  , '    %2 notNil ifTrue:[\'
                                  , '        oldValue := %2 value.\'
                                  , '        %2 removeDependent:self.\'
                                  , '    ].\'
                                  , '    %2 := something.\'
                                  , '    %2 notNil ifTrue:[\'
                                  , '        %2 addDependent:self.\'
                                  , '    ].\'
                                  , '    newValue := %2 value.\'
                                  , '    oldValue ~~ newValue ifTrue:[\'
                                  , '        self update:#value with:newValue from:%2.\'
                                  , '    ].\'
                    ] ifFalse:[
                        source := source 
                                  , ' (automatically generated)"\\'
                                  , '    %2 := something.'.
                    ].
                ] ifFalse:[
                    source := methodName
                              , ':something\    "set the value of the %1 variable ''%2'''.
                    withChange ifTrue:[
                        source := source
                                  , ' and send a change notification (automatically generated)"\\'
                                  , '    (%2 ~~ something) ifTrue:[\'
                                  , '        %2 := something.\'
                                  , '        self changed:#%2.\'
                                  , '     ].\'.
                    ] ifFalse:[
                        source := source 
                                  , ' (automatically generated)"\\'
                                  , '    %2 := something.'.
                    ].
                ].
                source := (source bindWith:varType with:name) withCRs.
                self 
                    compile:source 
                    forClass:aClass 
                    inCategory:(asValueHolder ifTrue:['aspects'] ifFalse:['accessing']).
            ] ifTrue:[
                Transcript showCR:'method ''', methodName , ':'' already present'
            ].
        ].
    ]
!

createApplicationCodeFor:aClass
    "create an empty application framework"

    |nonMetaClass metaClass className txt isDialog|

    nonMetaClass := aClass theNonMetaclass.
    metaClass := aClass theMetaclass.
    className := nonMetaClass name.

    isDialog := (nonMetaClass isSubclassOf:SimpleDialog).

    "/ add a windowSpec method for an empty applicationWindow,
    "/ with a menuPanel.

    (metaClass includesSelector:#windowSpec) ifFalse:[
        isDialog ifTrue:[
            txt := self initialWindowSpecMethodSourceForDialogs.
        ] ifFalse:[
            txt := self initialWindowSpecMethodSourceForApplications.
        ].
        self
            compile:(txt bindWith:className)
            forClass:metaClass 
            inCategory:'interface specs'.
    ].

    isDialog ifFalse:[
        "/ add a topMenu method 

        (metaClass includesSelector:#mainMenu) ifFalse:[
            txt := self initialMenuSpecMethodSourceForApplications.
            self
                compile:(txt bindWith:className)
                forClass:metaClass 
                inCategory:'menu specs'.
        ].
    ].

    (metaClass includesSelector:#postBuildWith:) ifFalse:[
        txt :=
'postBuildWith:aBuilder
    "This is a hook method generated by the Browser.
     It will be invoked during the initialization of your app/dialog,
     after all of the visual components have been built, 
     but BEFORE the top window is made visible.
     Add any app-specific actions here (reading files, setting up values etc.)
     See also #postOpenWith:, which is invoked after opening."

    "/ add any code here ...

    ^ super postBuildWith:aBuilder
'.
        self
            compile:txt
            forClass:nonMetaClass 
            inCategory:'initialization & release'.
    ].

    (metaClass includesSelector:#postOpenWith:) ifFalse:[
        txt :=
'postOpenWith:aBuilder
    "This is a hook method generated by the Browser.
     It will be invoked right after the applications window has been opened.
     Add any app-specific actions here (starting background processes etc.).
     See also #postBuildWith:, which is invoked before opening."

    "/ add any code here ...

    ^ super postOpenWith:aBuilder
'.
        self
            compile:txt
            forClass:nonMetaClass 
            inCategory:'initialization & release'.
    ].

    isDialog ifFalse:[
        (metaClass includesSelector:#closeRequest) ifFalse:[
            txt :=
'closeRequest
    "This is a hook method generated by the Browser.
     It will be invoked when your app/dialog-window is about to be
     closed (this method has a chance to suppress the close).
     See also #closeDownViews, which is invoked when the close is really done."

    "/ change the code below as required ...
    "/ Closing can be suppressed, by simply returning.
    "/ The ''super closeRequest'' at the end will initiate the real closeDown

    ("self hasUnsavedChanges" true) ifTrue:[
        (self confirm:(resources string:''Close without saving ?'')) ifFalse:[
            ^ self
        ]
    ].

    ^ super closeRequest
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'initialization & release'.
        ].
    ].

    isDialog ifFalse:[
        (metaClass includesSelector:#closeDownViews) ifFalse:[
            txt :=
'closeDownViews
    "This is a hook method generated by the Browser.
     It will be invoked when your app/dialog-window is really closed.
     See also #closeDownViews, which is invoked before and may suppress the close
     or ask the user for confirmation."

    "/ change the code below as required ...
    "/ This should cleanup any leftover resources
    "/ (for example, temporary files)
    "/ super closeRequest will initiate the closeDown

    "/ add your code here

    "/ do not remove the one below ...
    ^ super closeDownViews
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'initialization & release'.
        ].
    ].

    isDialog ifTrue:[
        (metaClass includesSelector:#accept) ifFalse:[
            txt :=
'closeAccept
    "This is a hook method generated by the Browser.
     It will be invoked when your dialog-window is closed with OK."

    "/ add any actions as required here ...
    Transcript showCR:''dialog accepted''.

    "/ do not remove the one below ...
    ^ super closeAccept
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'user actions'.
        ].
    ].

    isDialog ifFalse:[
        (metaClass includesSelector:#menuNew) ifFalse:[
            txt :=
'menuNew
    "This method was generated by the Browser.
     It will be invoked when the menu-item ''new'' is selected."

    "/ change below and add any actions as required here ...
    self warn:''no action for ''''new'''' available.''.
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'menu actions'.
        ].
    ].
    isDialog ifFalse:[
        (metaClass includesSelector:#menuOpen) ifFalse:[
            txt :=
'menuOpen
    "This method was generated by the Browser.
     It will be invoked when the menu-item ''open'' is selected."

    "/ change below and add any actions as required here ...
    self warn:''no action for ''''open'''' available.''.
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'menu actions'.
        ].
    ].
    isDialog ifFalse:[
        (metaClass includesSelector:#menuSave) ifFalse:[
            txt :=
'menuSave
    "This method was generated by the Browser.
     It will be invoked when the menu-item ''save'' is selected."

    "/ change below and add any actions as required here ...
    self warn:''no action for ''''save'''' available.''.
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'menu actions'.
        ].
    ].
    isDialog ifFalse:[
        (metaClass includesSelector:#menuSaveAs) ifFalse:[
            txt :=
'menuSaveAs
    "This method was generated by the Browser.
     It will be invoked when the menu-item ''saveAs'' is selected."

    "/ change below and add any actions as required here ...
    self warn:''no action for ''''saveAs'''' available.''.
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'menu actions'.
        ].
    ].

    isDialog ifFalse:[
        (metaClass includesSelector:#openDocumentation) ifFalse:[
            txt :=
'openDocumentation
    "This method was generated by the Browser.
     It will be invoked when the menu-item ''help-documentation'' is selected."

    "/ change below as required ...

    "/ to open an HTML viewer on some document (under ''doc/online/<language>/'' ):
    HTMLDocumentView openFullOnDocumentationFile:''TOP.html''.

    "/ add application-specific help files under the ''doc/online/<language>/help/appName''
    "/ directory, and open a viewer with:
    "/ HTMLDocumentView openFullOnDocumentationFile:''help/<MyApplication>/TOP.html''.
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'menu actions'.
        ].
    ].

    isDialog ifFalse:[
        (metaClass includesSelector:#openAboutThisApplication) ifFalse:[
            txt :=
'openAboutThisApplication
    "This method was generated by the Browser.
     It will be invoked when the menu-item ''help-about'' is selected."

    "/ could open a customized aboutBox here ...
    super openAboutThisApplication
'.
            self
                compile:txt
                forClass:nonMetaClass 
                inCategory:'menu actions'.
        ].
    ].

    "Modified: / 1.2.1998 / 16:10:03 / cg"
!

createClassResponsibleProtocolFor:aClass
    "create stubs for the required protocol"

    self privCreateClassResponsibleProtocolFor:aClass theNonMetaclass.
    self privCreateClassResponsibleProtocolFor:aClass theMetaclass.
!

createClassTypeTestMethodsIn:aClass
    "create a #isXXX test methods
     (I'm tired of typing)"

    |subClasses code|

    subClasses := aClass subclasses.
    subClasses do:[:eachSubClass |
        |nm selector|

        nm := eachSubClass nameWithoutPrefix.
        selector := 'is' , nm.
        (aClass includesSelector:selector) ifFalse:[
            code := (selector , '\    ^ false') withCRs.
            self 
                compile:code
                forClass:aClass 
                inCategory:'testing'.
        ].
        (eachSubClass includesSelector:selector) ifFalse:[
            code := (selector , '\    ^ true') withCRs.
            self 
                compile:code
                forClass:eachSubClass 
                inCategory:'testing'.
        ].
    ].
!

createDocumentationMethodsFor:aClass
    "create empty documentation methods"

    |cls|

    cls := aClass theMetaclass.

    self createVersionMethodFor:cls.
    self createCopyrightMethodFor:aClass.
    self createDocumentationMethodFor:aClass.
    self createInitialHistoryMethodFor:aClass.
!

createStandardInitializationMethodsIn:aClass
    "create a #new and #initialize methods
     (I'm tired of typing)"

    |code initializer m|

    (aClass includesSelector:#'initialize') ifFalse:[
        code :=
'initialize
    "Invoked when a new instance is created."

    super initialize.

    "/ please change as required (and remove this comment)
'.

        m := aClass responseTo:#initialize.
        m notNil ifTrue:[
            m messagesSent size == 0 ifTrue:[
                "/ inherits an empty initialize.

                code :=
'initialize
    "Invoked when a new instance is created."

    "/ please change as required (and remove this comment)

    "/ super initialize.   -- commented since inherited method does nothing
'.

            ].
        ].

        aClass instVarNames do:[:eachInstVar |
            initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...
            code := code , ('    ' , eachInstVar , ' := ' , initializer , Character cr).
        ].

        self 
            compile:code
            forClass:aClass 
            inCategory:'initialization'.
    ].

    (aClass class includesSelector:#'new') ifFalse:[
        m := aClass class responseTo:#new.
        m notNil ifTrue:[
            (m sends:#initialize) ifTrue:[
                (self confirm:'The inherited #new method already seems to invoke #initialize. Redefine ?')
                ifFalse:[
                    ^ self
                ]
            ].
        ].
        code :=
'new
    ^ self basicNew initialize.
'.
        self 
            compile:code
            forClass:aClass class 
            inCategory:'instance creation'.
    ].


    "Created: / 11.10.2001 / 22:18:55 / cg"
!

createTestCaseSampleCodeFor:aClass
    "create an empty testCase"

    |nonMetaClass metaClass|

    nonMetaClass := aClass theNonMetaclass.
    metaClass := aClass theMetaclass.
    "/ className := nonMetaClass name.

    ( nonMetaClass includesSelector:#test1 ) ifFalse:[
        self
            compile:
'test1
    "Just a demonstration testCase.
     Double click on the TestCase class or open a TestRunner to see me checking...
     - please add more methods like this..."

    |o|

    o := Array new:2.
    self assert: ( o size == 2 ).
    self should: [ o at:0 ] raise:Error.
    self shouldnt: [ o at:1 ] raise:Error.

    "
     self run:#test1
    "
'
            forClass:nonMetaClass 
            inCategory:'tests'.
    ].

    ( nonMetaClass includesSelector:#setUp ) ifFalse:[
        self
            compile:
'setUp
    "common setup - invoked before testing"

    super setUp
'
            forClass:nonMetaClass 
            inCategory:'initialize / release'.
    ].

    ( nonMetaClass includesSelector:#tearDown ) ifFalse:[
        self
            compile:
'tearDown
    "common cleanup - invoked after testing"

    super tearDown
'
            forClass:nonMetaClass 
            inCategory:'initialize / release'.
    ]
!

createVisitorMethodsIn:visitedClass andVisitorClass:visitorClass
    "create acceptVisitor: in visitedClass and acceptXXX in visitorClass.
     (I'm tired of typing)"

    |sel|

    visitedClass isMeta ifTrue:[self halt].
    visitorClass isMeta ifTrue:[self halt].

    sel := ('visit' , visitedClass nameWithoutPrefix , ':').
    self createAcceptVisitorMethod:sel in:visitedClass.

    (visitorClass includesSelector:sel) ifFalse:[
        self 
            compile:
(('%1anObject 
    "dispatched back from the visited %2-object (visitor pattern)"

    "fall back to general object-case - please change as required"

    ^ self visitObject:anObject
') bindWith:sel with:visitedClass nameWithoutPrefix asLowercaseFirst)
            forClass:visitorClass 
            inCategory:'visiting'.
    ].

    (visitorClass includesSelector:#'visitObject:') ifFalse:[
        self 
            compile:
('visitObject:anObject 
    "dispatched back from the visited objects (visitor pattern)"

    "general fallBack - please change as required"

    self halt:''not yet implemented''
')
            forClass:visitorClass 
            inCategory:'visiting'.
    ].

    (visitorClass includesSelector:#'visit:') ifFalse:[
        self 
            compile:
('visit:anObject 
    "visit anObject (visitor pattern).
     The object should call back one of my visitXXXX methods."

    ^ anObject acceptVisitor:self
')
            forClass:visitorClass 
            inCategory:'visiting'.
    ]
!

initialMenuSpecMethodSourceForApplications
    ^
'mainMenu
    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,
     the MenuEditor may not be able to read the specification."

    "
     MenuEditor new openOnClass:%1 andSelector:#mainMenu
    "

    <resource: #menu>

    ^ #(#Menu
           #(
             #(#MenuItem
                #label: ''File''
                #translateLabel: true
                #submenu: 
                 #(#Menu
                     #(
                       #(#MenuItem
                          #label: ''New''
                          #translateLabel: true
                          #value: #menuNew
                      )
                       #(#MenuItem
                          #label: ''-''
                      )
                       #(#MenuItem
                          #label: ''Open...''
                          #translateLabel: true
                          #value: #menuOpen
                      )
                       #(#MenuItem
                          #label: ''-''
                      )
                       #(#MenuItem
                          #label: ''Save''
                          #translateLabel: true
                          #value: #menuSave
                      )
                       #(#MenuItem
                          #label: ''Save As...''
                          #translateLabel: true
                          #value: #menuSaveAs
                      )
                       #(#MenuItem
                          #label: ''-''
                      )
                       #(#MenuItem
                          #label: ''Exit''
                          #translateLabel: true
                          #value: #closeRequest
                      )
                    ) nil
                    nil
                )
            )
             #(#MenuItem
                #label: ''Help''
                #translateLabel: true
                #startGroup: #right
                #submenu: 
                 #(#Menu
                     #(
                       #(#MenuItem
                          #label: ''Documentation''
                          #translateLabel: true
                          #value: #openDocumentation
                      )
                       #(#MenuItem
                          #label: ''-''
                      )
                       #(#MenuItem
                          #label: ''About this Application''
                          #translateLabel: true
                          #value: #openAboutThisApplication
                      )
                    ) nil
                    nil
                )
            )
          ) nil
          nil
      )
'.
!

initialWindowSpecMethodSourceForApplications
    ^
'windowSpec
    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,
     the UIPainter may not be able to read the specification."

    "
     UIPainter new openOnClass:%1 andSelector:#windowSpec
    "

    <resource: #canvas>

    ^ #(#FullSpec
          #window: 
           #(#WindowSpec
              #name: ''%1''
              #layout: #(#LayoutFrame 204 0 162 0 503 0 461 0)
              #label: ''%1''
              #min: #(#Point 10 10)
              #max: #(#Point 1024 768)
              #bounds: #(#Rectangle 204 162 504 462)
              #menu: #mainMenu
              #usePreferredExtent: false
          )
          #component: 
           #(#SpecCollection
              #collection: #()
          )
      )
'.
!

initialWindowSpecMethodSourceForDialogs
    ^
'windowSpec
    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,
     the UIPainter may not be able to read the specification."

    "
     UIPainter new openOnClass:%1 andSelector:#windowSpec
    "

    <resource: #canvas>

    ^

       #(#FullSpec
          #window: 
           #(#WindowSpec
              #name: ''%1''
              #layout: #(#LayoutFrame 221 0 118 0 520 0 417 0)
              #level: 0
              #label: ''%1''
              #min: #(#Point 10 10)
              #max: #(#Point 1024 768)
              #bounds: #(#Rectangle 221 118 521 418)
              #usePreferredExtent: false
          )
          #component: 
           #(#SpecCollection
              #collection: 
               #(
                 #(#HorizontalPanelViewSpec
                    #name: ''buttonPanel''
                    #layout: #(#LayoutFrame 0 0.0 -45 1 0 1.0 0 1.0)
                    #component: 
                     #(#SpecCollection
                        #collection: 
                         #(
                          #(#ActionButtonSpec
                             #name: ''cancelButton''
                             #label: ''Cancel''
                             #tabable: true
                             #translateLabel: true
                             #model: #cancel
                             #extent: #(#Point 125 22)
                           )
                           #(#ActionButtonSpec
                              #name: ''okButton''
                              #label: ''OK''
                              #tabable: true
                              #translateLabel: true
                              #isDefault: true
                              #model: #accept
                              #extent: #(#Point 125 22)
                          )
                        )
                    )
                    #reverseOrderIfOKAtLeft: true
                    #horizontalLayout: #spreadSpaceMax
                    #verticalLayout: #center
                    #horizontalSpace: 3
                    #verticalSpace: 3
                )
              )
          )
      )
'.
! !

!CodeGeneratorTool class methodsFor:'code generation - individual methods'!

createAcceptVisitorMethod:selector in:aClass
    "create an acceptVisitor: method
     (I'm tired of typing)"

    aClass isMeta ifTrue:[self halt].

    (aClass includesSelector:#'acceptVisitor:') ifFalse:[
        self 
            compile:
(('acceptVisitor:aVisitor 
    "Double dispatch back to the visitor, passing my type encoded in
     the selector (visitor pattern)"

    "stub code automatically generated - please change if required"

    ^ aVisitor %1self
') bindWith:selector)
            forClass:aClass 
            inCategory:'visiting'.
    ]
!

createAcceptVisitorMethodIn:aClass
    "create an acceptVisitor: method
     (I'm tired of typing)"

    self
        createAcceptVisitorMethod:('visit' , aClass nameWithoutPrefix , ':') asSymbol
        in:aClass
!

createCopyrightMethodFor:aClass
    "add copyright method containing your/your companies
     copyright template but only if not already present.
     this is only added, if specified in the 
     COPYRIGHT_TEMPLATE_FILE resources."

    |fn txt|

    (aClass includesSelector:#copyright) ifFalse:[
        fn := SystemBrowser classResources at:#'COPYRIGHT_TEMPLATE_FILE' default:nil.
        fn notNil ifTrue:[
            fn := fn asFilename.
            fn exists ifTrue:[
                txt := fn contents asString
            ]
        ].

        txt notNil ifTrue:[
            txt := txt bindWith:(Date today year).
            self compile:
'copyright
"
' , txt , '
"
'             forClass:aClass 
              inCategory:'documentation'.
        ]
    ].
!

createDocumentationMethodFor:aClass
    "add documentation method containing doc template
     but only if not already present."

    |userName loginName hostName emailAddress|

    (aClass includesSelector:#documentation) ifFalse:[
        userName := OperatingSystem getFullUserName.
        loginName := OperatingSystem getLoginName.
        hostName := OperatingSystem getHostName.
        emailAddress := loginName , '@' , hostName.

        self compile:
'documentation
"
    documentation to be added.

    [author:]
        ' , userName 
          , ' (' , emailAddress , ')' , '

    [instance variables:]

    [class variables:]

    [see also:]

"
'             forClass:aClass 
              inCategory:'documentation'.
    ].
!

createExamplesMethodFor:aClass
    "add examples method containing examples template
     but only if not already present."

    |fragment|

    (aClass includesSelector:#examples) ifFalse:[
        (aClass theNonMetaclass isSubclassOf:ApplicationModel) ifTrue:[
            fragment := '  Starting the application:
                                                                [exBegin]
    ' , aClass theNonMetaclass name , ' open

                                                                [exEnd]
'
        ] ifFalse:[
            fragment := ''
        ].

        self 
            compile:
'examples
"
' , fragment , '
  more examples to be added:
                                                                [exBegin]
    ... add code fragment for 
    ... executable example here ...
                                                                [exEnd]
"
'                   
            forClass:aClass 
            inCategory:'documentation'.
    ].
!

createImageSpecMethodFor:anImage comment:comment in:aClass selector:sel
    |imageStoreStream mthd imageKey category|

    anImage storeOn: (imageStoreStream := WriteStream on: '').

    "/ if that method already exists, do not overwrite the category
    category := 'image specs'.
    (mthd := aClass compiledMethodAt:sel) notNil ifTrue:[
        category := mthd category.
    ].

    imageKey :=  (aClass name, ' ', sel) asSymbol.
    Icon constantNamed: imageKey put:nil.
    aClass
        compile: ((sel,
            '\', comment,
            '\\' , 
            '    "\',
            '     self ' , sel , ' inspect\',
            '     ImageEditor openOnClass:self andSelector:#', sel, '\',
            '     Icon flushCachedIcons', 
            '\    "',
            '\\',
            '    <resource: #image>',
            '\\',
            '    ^Icon\') withCRs, 
            '        constantNamed:#''', imageKey, '''\' withCRs,
            '        ifAbsentPut:[', imageStoreStream contents, ']')
       classified: category.
!

createInitialHistoryMethodFor:aClass
    "add history method containing created-entry
     but only if not already present."

    (aClass includesSelector:#history) ifFalse:[ 
        HistoryManager notNil ifTrue:[
            HistoryManager createInitialHistoryMethodIn:aClass
        ].
    ].
!

createMultiSetterMethodFor:aCollectionOfVarNames in:aClass
    "create a multi-setter method for instvars."

    |source|

    source := ''.
    aCollectionOfVarNames do:[:eachVar |
        source := source , (eachVar , ':' , eachVar , 'Arg ').
    ].
    source := source , Character cr.
    source := source , ('    "set instance variables (automatically generated)"' , Character cr , Character cr).
    aCollectionOfVarNames do:[:eachVar |
        source := source , ('    ' , eachVar , ' := ' , eachVar , 'Arg.' , Character cr).
    ].
    self compile:source forClass:aClass inCategory:'accessing'.
!

createSubclassResponsibilityMethodFor:aSelector category:cat in:aClass
    "add a subclassResponsibility method;
     but only if not already present."

    (aClass includesSelector:aSelector) ifFalse:[

        self compile:
(Method methodDefinitionTemplateForSelector:aSelector) ,
'
    "raise an error: must be redefined in concrete subclass(es)"

    ^ self subclassResponsibility
' 
              forClass:aClass 
              inCategory:cat.
    ].
!

createUpdateMethodIn:aClass
    "create an update:with:from:-method
     (I'm tired of typing)"

    (aClass includesSelector:#'update:with:from:') ifFalse:[
        self 
            compile:
'update:something with:aParameter from:changedObject
    "Invoked when an object that I depend upon sends a change notification."

    "stub code automatically generated - please change as required"

    "/ changedObject == someOfMyValueHolders ifTrue:[
    "/     self doSomethingApropriate
    "/     ^ self
    "/ ].
    super update:something with:aParameter from:changedObject
'
            forClass:aClass 
            inCategory:'change & update'.
    ]
!

createVersionMethodFor:aClass
    "add version method containing RCS template
     but only if not already present and its not a private class."

    aClass isPrivate ifFalse:[
        (aClass includesSelector:#version) ifFalse:[
            self compile:
'version
    ^ ''$' , 'Header$''
' 
                  forClass:aClass 
                  inCategory:'documentation'.
        ]
    ].
! !

!CodeGeneratorTool class methodsFor:'compilation'!

canUseRefactoringSupport
     ^ RefactoryChangeManager notNil and:[RefactoryChangeManager isLoaded]
!

compile:theCode forClass:aClass inCategory:cat 
    |change|

    self canUseRefactoringSupport ifFalse:[
        aClass compile:theCode classified:cat.
        ^ self.
    ].

    change := InteractiveAddMethodChange compile:(theCode asString) in:aClass classified:cat.
    RefactoryChangeManager instance performChange:change.
! !

!CodeGeneratorTool class methodsFor:'private'!

privCreateClassResponsibleProtocolFor:aClass
    "create stubs for the required protocol aClass may be a a MetaClass
     or a NonMetaClass"

    |selectors|

    selectors := IdentitySet new.
    aClass allSuperclassesDo:[:cls |
        cls methodDictionary keysAndValuesDo:[:sel :mthd |
            (mthd sends:#subclassResponsibility) ifTrue:[
                selectors add:sel.
            ]
        ]
    ].

    selectors do:[:eachSelector |
        |cat comment mthd implClass|

        implClass := aClass whichClassImplements:eachSelector.
        implClass ~~ aClass ifTrue:[
            mthd := implClass compiledMethodAt:eachSelector.
            (mthd sends:#subclassResponsibility) ifTrue:[
                cat := mthd category.
                comment := mthd methodComment.
                comment size == 0 ifTrue:[
                    comment := 'Superclass says that I am responsible to implement this method'
                ].

                self 
                    compile:
(Method methodDefinitionTemplateForSelector:eachSelector), Character cr, '    "', comment,
'"

    self shouldImplement
' 
                    forClass:aClass 
                    inCategory:cat.
            ].
        ].
    ].
! !

!CodeGeneratorTool class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/libtool/CodeGeneratorTool.st,v 1.9 2002-12-06 10:44:20 cg Exp $'
! !