"
COPYRIGHT (c) 2002 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:libtool' }"
Object subclass:#CodeGeneratorTool
instanceVariableNames:'compositeChangeCollector compositeChangeNesting'
classVariableNames:'GenerateCommentsForGetters GenerateCommentsForSetters'
poolDictionaries:''
category:'Interface-Browsers'
!
!CodeGeneratorTool class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 2002 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
"
This utility class contains various code generation facilites;
these were extracted from the 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
"create accessors in aClass"
^ self new
createAccessMethodsFor:aCollectionOfVarNames in:aClass withChange:withChange asValueHolder:asValueHolder readersOnly:readersOnly writersOnly:writersOnly
!
createApplicationCodeFor:aClass
"create an empty application framework"
^ self new createApplicationCodeFor:aClass
!
createClassResponsibleProtocolFor:aClass
"create stubs for the required protocol"
^ self new createClassResponsibleProtocolFor:aClass
!
createClassTypeTestMethodsIn:aClass forClasses:subClasses
"create a #isXXX test methods (I'm tired of typing)"
^ self new createClassTypeTestMethodsIn:aClass forClasses:subClasses
!
createDocumentationMethodsFor:aClass
"create empty documentation methods"
^ self new createDocumentationMethodsFor:aClass
!
createStandardInitializationMethodsIn:aClass
"create a #new and #initialize methods (I'm tired of typing)"
^ self new createStandardInitializationMethodsIn:aClass
!
createTestCaseSampleCodeFor:aClass
"create an (almost) empty testCase class"
^ self new createTestCaseSampleCodeFor:aClass
!
createVisitorMethodsIn:visitedClass andVisitorClass:visitorClass
"create acceptVisitor: in visitedClass and acceptXXX in visitorClass. (I'm tired of typing)"
^ self new createVisitorMethodsIn:visitedClass andVisitorClass:visitorClass
!
initialMenuSpecMethodSourceForApplications
"return a menuSpec with typical stuff in it"
^
'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
"return an empty windowSpec with an initial menubar in it"
^
'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
"return an empty windowSpec for dialogs"
^
'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-basic'!
createAccessMethodsFor:aCollectionOfVarNames in:aClass withChange:withChange asValueHolder:asValueHolder readersOnly:readersOnly writersOnly:writersOnly lazyInitialization:lazyInitialization
"workhorse for creating access methods for instvars."
^ self new
createAccessMethodsFor:aCollectionOfVarNames in:aClass withChange:withChange asValueHolder:asValueHolder readersOnly:readersOnly writersOnly:writersOnly lazyInitialization:lazyInitialization
! !
!CodeGeneratorTool class methodsFor:'code generation-individual methods'!
createAcceptVisitorMethod:selector in:aClass
"create an acceptVisitor: method
(I'm tired of typing)"
^ self new createAcceptVisitorMethod:selector in:aClass
!
createAcceptVisitorMethodIn:aClass
"create an acceptVisitor: method
(I'm tired of typing)"
^ self new createAcceptVisitorMethodIn: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."
^ self new createCopyrightMethodFor:aClass
!
createDocumentationMethodFor:aClass
"add documentation method containing doc template
but only if not already present."
^ self new createDocumentationMethodFor:aClass
!
createExamplesMethodFor:aClass
"add examples method containing examples template
but only if not already present."
^ self new createExamplesMethodFor:aClass
!
createImageSpecMethodFor:anImage comment:comment in:aClass selector:sel
^ self new createImageSpecMethodFor:anImage comment:comment in:aClass selector:sel
!
createInitialHistoryMethodFor:aClass
"add history method containing created-entry
but only if not already present."
^ self new createInitialHistoryMethodFor:aClass
!
createInstanceCreationMethodWithSetupFor:selector category:category in:aMetaClass
"add an inst-creation method"
^ self new createInstanceCreationMethodWithSetupFor:selector category:category in:aMetaClass
!
createMultiSetterMethodFor:aCollectionOfVarNames in:aClass
"create a multi-setter method for instvars."
^ self new createMultiSetterMethodFor:aCollectionOfVarNames in:aClass
!
createSubclassResponsibilityMethodFor:aSelector category:cat in:aClass
"add a subclassResponsibility method;
but only if not already present."
^ self new createSubclassResponsibilityMethodFor:aSelector category:cat in:aClass
!
createUpdateMethodIn:aClass
"create an update:with:from:-method
(I'm tired of typing)"
^ self new createUpdateMethodIn:aClass
!
createVersionMethodFor:aClass
"add version method containing RCS template
but only if not already present and its not a private class."
^ self new createVersionMethodFor:aClass
! !
!CodeGeneratorTool class methodsFor:'compilation'!
compile:theCode forClass:aClass inCategory:cat
"install some code for a class.
If refactory browser stuff is avaliable the refactory tools are used to support undo"
^ self new compile:theCode forClass:aClass inCategory:cat
! !
!CodeGeneratorTool class methodsFor:'private'!
canUseRefactoringSupport
"check if refactory browser stuff is avaliable"
^ RefactoryChangeManager notNil
and:[RefactoryChangeManager isLoaded
and:[UserPreferences current useRefactoringSupport]]
! !
!CodeGeneratorTool methodsFor:'buld changes'!
addChange:aChange
compositeChangeCollector addChange:aChange
!
executeCollectedChangesNamed:name
compositeChangeCollector notNil ifTrue:[
compositeChangeNesting := compositeChangeNesting - 1.
compositeChangeNesting == 0 ifTrue:[
compositeChangeCollector name:name.
compositeChangeCollector changesSize == 0 ifTrue:[
self information:'Nothing generated.'.
] ifFalse:[
RefactoryChangeManager instance performChange:compositeChangeCollector.
].
compositeChangeCollector := nil.
]
]
!
startCollectChanges
(self canUseRefactoringSupport) ifTrue:[
compositeChangeCollector isNil ifTrue:[
compositeChangeCollector := CompositeRefactoryChange new.
compositeChangeNesting := 0.
].
compositeChangeNesting := compositeChangeNesting + 1.
]
! !
!CodeGeneratorTool methodsFor:'code generation'!
createAccessMethodsFor:aCollectionOfVarNames in:aClass withChange:withChange asValueHolder:asValueHolder readersOnly:readersOnly writersOnly:writersOnly
"create accessors in aClass"
self
createAccessMethodsFor:aCollectionOfVarNames
in:aClass
withChange:withChange
asValueHolder:asValueHolder
readersOnly:readersOnly
writersOnly:writersOnly
lazyInitialization:false
!
createApplicationCodeFor:aClass
"create an empty application framework"
|nonMetaClass metaClass className txt isDialog categoryForMenuActionsMethods|
self startCollectChanges.
categoryForMenuActionsMethods := UserPreferences current categoryForMenuActionsMethods.
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 class initialWindowSpecMethodSourceForDialogs.
] ifFalse:[
txt := self class initialWindowSpecMethodSourceForApplications.
].
self
compile:(txt bindWith:className)
forClass:metaClass
inCategory:'interface specs'.
].
isDialog ifFalse:[
"/ add a topMenu method
(metaClass includesSelector:#mainMenu) ifFalse:[
txt := self class initialMenuSpecMethodSourceForApplications.
self
compile:(txt bindWith:className)
forClass:metaClass
inCategory:'menu specs'.
].
].
(nonMetaClass 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'.
].
(nonMetaClass 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:[
(nonMetaClass 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:[
(nonMetaClass 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:[
(nonMetaClass 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:[
(nonMetaClass 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:categoryForMenuActionsMethods.
].
].
isDialog ifFalse:[
(nonMetaClass 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:categoryForMenuActionsMethods.
].
].
isDialog ifFalse:[
(nonMetaClass 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:categoryForMenuActionsMethods.
].
].
isDialog ifFalse:[
(nonMetaClass 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:categoryForMenuActionsMethods.
].
].
isDialog ifFalse:[
(nonMetaClass 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:categoryForMenuActionsMethods.
].
].
isDialog ifFalse:[
(nonMetaClass 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:categoryForMenuActionsMethods.
].
].
self executeCollectedChangesNamed:('Add Application Code for ' , aClass theNonMetaclass name).
"Modified: / 1.2.1998 / 16:10:03 / cg"
!
createClassResponsibleProtocolFor:aClass
"create stubs for the required protocol"
self startCollectChanges.
self privCreateClassResponsibleProtocolFor:aClass theNonMetaclass.
self privCreateClassResponsibleProtocolFor:aClass theMetaclass.
self executeCollectedChangesNamed:('Add Required Protocol to ' , aClass theNonMetaclass name).
!
createClassTypeTestMethodsIn:aClass forClasses:subClasses
"create a #isXXX test methods (I'm tired of typing)"
| code|
self startCollectChanges.
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'.
].
].
self executeCollectedChangesNamed:'Add ClassType Tests'
!
createDocumentationMethodsFor:aClass
"create empty documentation methods"
|cls|
cls := aClass theMetaclass.
self startCollectChanges.
self createVersionMethodFor:cls.
self createCopyrightMethodFor:aClass.
self createDocumentationMethodFor:aClass.
self createInitialHistoryMethodFor:aClass.
self executeCollectedChangesNamed:('Add Documentation to ' , aClass theNonMetaclass name).
!
createStandardInitializationMethodsIn:aClass
"create a #new and #initialize methods (I'm tired of typing)"
|code initializer m|
self startCollectChanges.
(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'.
].
self executeCollectedChangesNamed:('Add Initialization to ' , aClass theNonMetaclass name).
"Created: / 11.10.2001 / 22:18:55 / cg"
!
createStandardPrintOnMethodIn:aClass
"create a #printOn: method (I'm tired of typing)"
|code|
self startCollectChanges.
(aClass includesSelector:#'printOn:') ifFalse:[
code :=
'printOn:aStream
"append a printed representation if the receiver to the argument, aStream"
super printOn:aStream.
'.
aClass instVarNames do:[:eachInstVarName |
code := code , ' '.
code := code , 'aStream nextPutAll:'''.
code := code , eachInstVarName.
code := code , ': ''.' , Character cr.
code := code , ' '.
code := code , eachInstVarName.
code := code , ' printOn:aStream.' , Character cr.
].
self
compile:code
forClass:aClass
inCategory:'printing & storing'.
].
self executeCollectedChangesNamed:('Add #printOn: to ' , aClass theNonMetaclass name).
"Created: / 11.10.2001 / 22:18:55 / cg"
!
createTestCaseSampleCodeFor:aClass
"create an (almost) empty testCase class"
|nonMetaClass metaClass|
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
"/ className := nonMetaClass name.
( nonMetaClass includesSelector:#test1 ) ifFalse:[
self
compile:
'test1
"This is a demonstration testCase - it is meant to be removed eventually.
This testCase will PASS.
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
self new test1
"
'
forClass:nonMetaClass
inCategory:'tests'.
].
( nonMetaClass includesSelector:#test2 ) ifFalse:[
self
compile:
'test2
"This is a demonstration testCase - it is meant to be removed eventually..
This testCase WILL FAIL.
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 == 3 ).
"
self run:#test2
self new test2
"
'
forClass:nonMetaClass
inCategory:'tests'.
].
( nonMetaClass includesSelector:#test3 ) ifFalse:[
self
compile:
'test3
"This is a demonstration testCase - it is meant to be removed eventually..
This testCase WILL generate an ERROR.
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 foo ).
"
self run:#test3
self new test3
"
'
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].
self startCollectChanges.
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'.
].
self executeCollectedChangesNamed:('Add Visitor Pattern').
! !
!CodeGeneratorTool methodsFor:'code generation-basic'!
createAccessMethodsFor:aCollectionOfVarNames in:aClass withChange:withChange asValueHolder:asValueHolder readersOnly:readersOnly writersOnly:writersOnly lazyInitialization:lazyInitialization
"workhorse for creating access methods for instvars."
|classesClassVars generateComments generateCommentsForSetters generateCommentsForGetters|
self startCollectChanges.
generateComments := UserPreferences current generateComments.
generateCommentsForSetters := UserPreferences current generateCommentsForSetters.
generateCommentsForGetters := UserPreferences current generateCommentsForGetters.
classesClassVars := aClass theNonMetaclass allClassVarNames.
aCollectionOfVarNames do:[:name |
|source varType methodName defaultMethodName|
varType := (classesClassVars includes:name)
ifTrue:['static']
ifFalse:[
(aClass isMeta ifTrue:['classInstVar'] ifFalse:['instance'])].
methodName := name.
name first isUppercase ifTrue:[
methodName := methodName asLowercaseFirst.
].
"/ the GETTER
writersOnly ifFalse:[
lazyInitialization ifTrue:[
defaultMethodName := 'default' , name asUppercaseFirst.
].
"check, if method is not already present"
(aClass includesSelector:(methodName asSymbol)) ifFalse:[
asValueHolder ifTrue:[
source := methodName , '\'.
generateComments ifTrue:[
source := source , ' "return/create the ''%2'' value holder (automatically generated)"\\'.
].
source := source , ' %2 isNil ifTrue:[\'.
lazyInitialization ifTrue:[
source := source
, ' %2 := self class %3 asValue.\'.
] ifFalse:[
source := source
, ' %2 := ValueHolder new.\'.
].
withChange ifTrue:[
source := source
, ' %2 addDependent:self.\'.
].
source := source
, ' ].\'
, ' ^ %2'.
] ifFalse:[
source := methodName , '\'.
lazyInitialization ifTrue:[
generateCommentsForGetters ifTrue:[
source := source , ' "return the %1 instance variable ''%2'' with lazy instance creation (automatically generated)"\\'.
].
source := source
, ' %2 isNil ifTrue:[\'
, ' %2 := self class %3.\'
, ' ].\'
, ' ^ %2'.
] ifFalse:[
generateCommentsForGetters ifTrue:[
source := source , ' "return the %1 instance variable ''%2'' (automatically generated)"\\'.
].
source := source
, ' ^ %2'.
].
].
source := (source bindWith:varType with:name with:defaultMethodName) withCRs.
self compile:source forClass:aClass inCategory:(asValueHolder ifTrue:['aspects'] ifFalse:['accessing']).
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
"/ default for lazy on class side
lazyInitialization ifTrue:[
(aClass class includesSelector:(defaultMethodName asSymbol)) ifFalse:[
source := defaultMethodName , '\'.
generateComments ifTrue:[
source := source , ' "default value for the ''%2'' instance variable (automatically generated)"\\'.
].
source := source
, ' self halt:''unfinished code''.\'
, ' ^ nil.'.
source := (source bindWith:varType with:name) withCRs.
self compile:source forClass:aClass class inCategory:'defaults'.
].
].
].
"/ the SETTER
readersOnly ifFalse:[
(aClass includesSelector:((methodName , ':') asSymbol)) ifFalse:[
asValueHolder ifTrue:[
source := methodName , ':something\'.
generateComments ifTrue:[
source := source , ' "set the ''%2'' value holder' , ' (automatically generated)"\\'.
].
withChange ifTrue:[
source := source
, ' |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
, ' %2 := something.'.
].
] ifFalse:[
source := methodName , ':something\'.
withChange ifTrue:[
generateComments ifTrue:[
source := source , ' "set the value of the %1 variable ''%2'''.
source := source , ' and send a change notification (automatically generated)"\\'.
].
source := source
, ' (%2 ~~ something) ifTrue:[\'
, ' %2 := something.\'
, ' self changed:#%2.\'
, ' ].\'.
] ifFalse:[
generateCommentsForSetters ifTrue:[
source := source , ' "set the value of the %1 variable ''%2'''.
source := source , ' (automatically generated)"\\'.
].
source := source
, ' %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'
].
].
].
self executeCollectedChangesNamed:('Add Accessors').
!
createValueHoldersFor:aCollectionOfVarNames in:aClass lazyInitialization:lazyInitialization
"workhorse for creating access methods for instvars."
|classesClassVars generateComments generateCommentsForSetters generateCommentsForGetters|
self startCollectChanges.
generateComments := UserPreferences current generateComments.
generateCommentsForSetters := UserPreferences current generateCommentsForSetters.
generateCommentsForGetters := UserPreferences current generateCommentsForGetters.
classesClassVars := aClass theNonMetaclass allClassVarNames.
aCollectionOfVarNames do:[:name |
|source varType methodName holderMethodName defaultMethodName|
holderMethodName := name.
name first isUppercase ifTrue:[
holderMethodName := holderMethodName asLowercaseFirst.
].
(holderMethodName endsWith:'Holder') ifTrue:[
methodName := holderMethodName copyWithoutLast:6.
] ifFalse:[
methodName := holderMethodName.
holderMethodName := methodName , 'Holder'.
].
methodName notNil ifTrue:[
(aClass class includesSelector:(methodName asSymbol)) ifFalse:[
source := '%1\'.
generateComments ifTrue:[
source := source , ' "return the value in ''%2''"\\'.
].
source := source , ' ^ self %2 value'.
source := (source bindWith:methodName with:holderMethodName) withCRs.
self compile:source forClass:aClass inCategory:('accessing').
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
(aClass class includesSelector:((methodName , ':') asSymbol)) ifFalse:[
source := '%1: newValue\'.
generateComments ifTrue:[
source := source , ' "set the value in ''%2''"\\'.
].
source := source , ' self %2 value: newValue'.
source := (source bindWith:methodName with:holderMethodName) withCRs.
self compile:source forClass:aClass inCategory:('accessing').
] ifTrue:[
Transcript showCR:'method ''', methodName , ':'' already present'
].
].
(aClass class includesSelector:(holderMethodName asSymbol)) ifFalse:[
source := '%1\'.
generateComments ifTrue:[
source := source , ' "return/create the valueHolder ''%1''"\\'.
].
source := source , ' %1 isNil ifTrue:[\'.
source := source , ' %1 := ValueHolder with:nil "defaultValue here".\'.
source := source , ' ].\'.
source := source , ' ^ %1\'.
source := (source bindWith:holderMethodName) withCRs.
self compile:source forClass:aClass inCategory:('accessing').
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
].
self executeCollectedChangesNamed:('Add ValueHolder').
! !
!CodeGeneratorTool 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 code|
(aClass includesSelector:#documentation) ifFalse:[
userName := OperatingSystem getFullUserName.
loginName := OperatingSystem getLoginName.
hostName := OperatingSystem getHostName.
emailAddress := loginName , '@' , hostName.
"/ ugly; should ask the class for that
aClass isJavaScriptClass ifTrue:[
code :=
'function documentation() {
/*
' , (aClass theNonMetaclass comment ? ' documentation to be added.') , '
[author:]
' , userName
, ' (' , emailAddress , ')' , '
[instance variables:]
[class variables:]
[see also:]
*/
}
'
] ifFalse:[
code:=
'documentation
"
' , (aClass theNonMetaclass comment ? ' documentation to be added.') , '
[author:]
' , userName
, ' (' , emailAddress , ')' , '
[instance variables:]
[class variables:]
[see also:]
"
'
].
self
compile:code
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."
|code|
(aClass includesSelector:#history) ifFalse:[
HistoryManager notNil ifTrue:[
code := HistoryManager codeForInitialHistoryMethodIn:aClass.
self
compile:code
forClass:aClass
inCategory:'documentation'.
].
].
!
createInstanceCreationMethodWithSetupFor:selector category:category in:aMetaClass
"add an inst-creation method"
|template|
(aMetaClass includesSelector:selector) ifFalse:[
template := Parser methodSpecificationForSelector:selector.
self
compile:
template , '
^ self new ' , template , '
'
forClass:aMetaClass
inCategory:category.
].
!
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."
|code|
aClass isPrivate ifFalse:[
(aClass includesSelector:#version) ifFalse:[
"/ ugly; should ask the class for that
aClass isJavaScriptClass ifTrue:[
code:= ('function version() {\ return ("$' , 'Header$");\}') withCRs
] ifFalse:[
code:= ('version\ ^ ''$' , 'Header$''') withCRs
].
self
compile:code
forClass:aClass
inCategory:'documentation'.
]
].
! !
!CodeGeneratorTool methodsFor:'compilation'!
compile:theCode forClass:aClass inCategory:cat
"install some code for a class.
If refactory browser stuff is avaliable the refactory tools are used to support undo"
|change|
self canUseRefactoringSupport ifFalse:[
"/ compile immediately
aClass compile:theCode classified:cat.
^ self.
].
change := InteractiveAddMethodChange compile:(theCode asString) in:aClass classified:cat.
"/ if collecting, add to changes (to be executed as one change at the end,
"/ in order to have only one change in the undo-list (instead of many)
compositeChangeCollector notNil ifTrue:[
compositeChangeCollector addChange:change
] ifFalse:[
RefactoryChangeManager instance performChange:change.
]
! !
!CodeGeneratorTool methodsFor:'private'!
canUseRefactoringSupport
"check if refactory browser stuff is avaliable"
^ self class canUseRefactoringSupport
!
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.29 2004-07-27 14:37:17 ca Exp $'
! !