`TestRunner2`: do not use `#keysAndValuesCollect:`
...as semantics differ among smalltalk dialects. This is normally not a
problem until we use code that adds this as a "compatibility" method.
So to stay on a safe side, avoid using this method.
"
COPYRIGHT (c) 2002 by eXept Software AG
COPYRIGHT (c) 2016 Jan Vrany
COPYRIGHT (c) 2021 LabWare
COPYRIGHT (c) 2023 LabWare
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' }"
"{ NameSpace: Smalltalk }"
CodeGeneratorTool subclass:#SmalltalkCodeGeneratorTool
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'Interface-Browsers'
!
!SmalltalkCodeGeneratorTool class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 2002 by eXept Software AG
COPYRIGHT (c) 2016 Jan Vrany
COPYRIGHT (c) 2021 LabWare
COPYRIGHT (c) 2023 LabWare
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 come...
[author:]
Claus Gittiner
"
! !
!SmalltalkCodeGeneratorTool class methodsFor:'code generation'!
initialMenuSpecMethodSourceForApplications
"return code for 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>
^ ',(self initialMenuSpecForApplications decodeAsLiteralArray literalArrayEncoding storeString),'
'.
!
initialPageMenuSpecMethodSourceForWebApplications
"return code for 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>
^ ',(self initialPageMenuSpecForWebApplications decodeAsLiteralArray literalArrayEncoding storeString),'
'.
"
self initialPageMenuSpecMethodSourceForWebApplications
"
!
initialPageSpecMethodSourceForWebApplications
"return an empty pageSpec"
^
'pageSpec
"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:#pageSpec
"
<resource: #canvas>
^ ',(self initialPageSpecForWebApplications decodeAsLiteralArray literalArrayEncoding storeString),'
'.
!
initialToolbarMenuSpecMethodSource
"return a menuSpec with typical stuff in it"
^
'toolbarMenu
"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:#toolbarMenu
"
<resource: #menu>
^ ',(self initialToolbarMenuSpec decodeAsLiteralArray literalArrayEncoding storeString),'
'.
"
self initialToolbarMenuSpecMethodSource
"
!
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>
^ ',
self initialWindowSpecForApplications2 decodeAsLiteralArray prettyPrintString
.
"
self initialWindowSpecMethodSourceForApplications
"
!
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>
^ ',
self initialWindowSpecForDialogs decodeAsLiteralArray prettyPrintString
! !
!SmalltalkCodeGeneratorTool class methodsFor:'code generation-menus'!
createActionMethodFor:aSelector in:aClass category:aCategory redefine:redefine
|alreadyInSuperclass method code|
(aClass includesSelector:aSelector) ifTrue:[
^ nil
].
alreadyInSuperclass := aClass superclass canUnderstand:aSelector.
(alreadyInSuperclass and:[redefine not]) ifTrue:[
^ nil
].
method := self methodNameTemplateFor:aSelector.
code := '%1
<resource: #uiCallback>
"automatically generated by UIEditor ..."
"*** the code below performs no action"
"*** (except for some feedback on the Transcript)"
"*** Please change as required and accept in the browser."
"*** (and replace this comment by something more useful ;-)"
"action to be added ..."
Logger info:''action for #%2 ...''.
' bindWith:method with:aSelector.
alreadyInSuperclass ifTrue:[
code := code, (('\ super %1\' bindWith:method) withCRs).
].
self compile:code forClass:aClass inCategory:(aCategory ? #actions).
^ code
!
createAspectMethodFor:aSelector in:aClass category:aCategory redefine:redefine
|alreadyInSuperclass method code text|
(aClass includesSelector:aSelector) ifTrue:[
^ nil
].
alreadyInSuperclass := aClass superclass canUnderstand:aSelector.
(alreadyInSuperclass and:[redefine not]) ifTrue:[
^ nil
].
method := self methodNameTemplateFor:aSelector.
code := '%1
"automatically generated by UIEditor ..."
"*** the code below creates a default model when invoked"
"*** (which may not be the one you wanted)"
"*** Please change as required and accept in the browser."
"*** (and replace this comment by something more useful ;-)"
"aspect to be added ..."
Logger info:''aspect for #%2 ...''.
' bindWith:method with:aSelector.
alreadyInSuperclass ifTrue:[
text := ' ^ super %1\' bindWith:method.
] ifFalse:[
text := ' ^ builder valueAspectFor:#''%1'' initialValue:true\' bindWith:aSelector.
].
code := code, (text withCRs).
self compile:code forClass:aClass inCategory:(aCategory ? #actions).
^ code
! !
!SmalltalkCodeGeneratorTool class methodsFor:'compilation'!
compile:theCode forClass:aClass inCategory:cat
"install some code for a class.
Return the new method or nil.
If refactory browser stuff is avaliable, the refactory tools are used to support undo"
| parser selector |
super compile:theCode forClass:aClass inCategory:cat.
parser := Parser parseMethodSpecification: theCode in: aClass ignoreErrors: true ignoreWarnings: true.
(selector := parser selector) notNil ifTrue:[
^ aClass compiledMethodAt: selector.
].
^ nil
"Created: / 05-08-2014 / 16:14:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
compile:theCode forClass:aClass inCategory:cat notifying: requestor
"install some code for a class.
Return the new method or nil.
If refactory browser stuff is avaliable the refactory tools are used to support undo"
CompilationErrorHandlerQuery
answer:requestor
do:[
^ self compile:theCode forClass:aClass inCategory:cat
]
"Created: / 05-08-2014 / 16:04:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SmalltalkCodeGeneratorTool class methodsFor:'private'!
methodNameTemplateFor:aSelector
|numArgs method|
numArgs := aSelector numArgs.
numArgs == 1 ifTrue:[
method := aSelector, 'anArgument'.
] ifFalse:[
numArgs == 0 ifTrue:[
method := aSelector
] ifFalse:[
method := ''.
aSelector keywords keysAndValuesDo:[:i :key|
method := method, key, 'arg', i printString, ' '.
].
]
].
^ method
! !
!SmalltalkCodeGeneratorTool class methodsFor:'utilities - source code'!
methodTemplate
"return a method definition template string"
|s|
s := (TextStream ? WriteStream) 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:
'"
This is an autogenerated method template.
If you don''t like this method template to appear,
disable it either via the global or browser''s settings dialog,
or by evaluating:
UserPreferences current showMethodTemplate:false
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
"Modified: / 18-11-2016 / 01:34:20 / cg"
!
methodTemplateForDocumentation
"return a documentation method definition template string"
|s|
s := (TextStream ? WriteStream) on:''.
s nextPutAll:
'documentation
'.
s emphasis:(UserPreferences current commentEmphasisAndColor).
s nextPutAll:(
'"
This is an autogenerated documentation template from ',Timestamp now printString,'.
You can disable the generation of this template via the settings or by evaluating:
UserPreferences current showMethodTemplate:false
comment describing this class.
[instance variables:]
describe instance variables
[class variables:]
describe class variables
[see also:]
[author:]
%1
"
' bindWith:(OperatingSystem getFullUserName)).
^ s contents
"Modified: / 18-11-2016 / 01:32:06 / cg"
"Modified (comment): / 18-11-2016 / 10:52:32 / cg"
!
methodTemplateForPackageDocumentation
"return a documentation-method definition template string for packages"
|s|
s := (TextStream ? WriteStream) on:''.
s nextPutAll:
'documentation
'.
s emphasis:(UserPreferences current commentEmphasisAndColor).
s nextPutAll:(
'"
This is an autogenerated documentation template from ',Timestamp now printString,'.
You can disable the generation of this template via the settings or by evaluating:
UserPreferences current showMethodTemplate:false
Package Documentation
[see also:]
[author:]
%1
[primary maintainer:]
%1
"
' bindWith:(OperatingSystem getFullUserName)).
^ s contents
"Created: / 18-11-2016 / 10:49:08 / cg"
!
methodTemplateForVersionMethodCVS
"careful to avoid expansion by cvs here!!"
^ ('version_CVS\ ^ ''$' , 'Header$''') withCRs
"Created: / 21-08-2012 / 11:52:27 / cg"
! !
!SmalltalkCodeGeneratorTool methodsFor:'code generation'!
createClassInitializeMethodIn:aClass
"create a #initialize method on the class side (I'm tired of typing)"
|nonMetaClass metaClass className code initializer bindings|
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
self startCollectChanges.
(metaClass includesSelector:#'initialize') ifFalse:[
bindings := Dictionary new.
bindings at:'INIT_CLASSINSTVARS' put:(
String streamContents:[:s |
metaClass instVarNames do:[:eachClassInstVar |
initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...
s nextPutLine:(' "/ %1 := %2.' bindWith:eachClassInstVar with:initializer).
]
]).
bindings at:'INIT_CLASSVARS' put:(
String streamContents:[:s |
nonMetaClass classVarNames do:[:eachClassVar |
initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...
s nextPutLine:(' "/ %1 := %2.' bindWith:eachClassVar with:initializer).
]
]).
code := (self codeFor_classInitialize) expandPlaceholdersWith:bindings.
self
compile:code
forClass:metaClass
inCategory:#initialization.
].
self executeCollectedChangesNamed:('Add Class Initializer to ' , className).
!
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'
!
createEnumTypeCodeFor:aClass
|nonMetaClass metaClass className enumValues code initCode runValue maxValue|
self startCollectChanges.
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
enumValues := nonMetaClass classVarNames.
enumValues do:[:eachVariableName |
self
createAccessMethodsFor:(Array with:eachVariableName)
in:metaClass
withChange:false
asValueHolder:false
readersOnly:true
writersOnly:false
].
maxValue := enumValues
inject:0
into:[:maxSoFar :eachVariableName |
|oldVal val|
oldVal := nonMetaClass classVarAt:eachVariableName.
oldVal notNil ifTrue:[ val := oldVal numericValue ].
(val ? maxSoFar) max:maxSoFar
].
initCode := WriteStream on:''.
initCode nextPutLine:'initialize'.
runValue := maxValue + 1.
enumValues keysAndValuesDo:[:idx :eachVariableName |
|oldValue thisValue|
oldValue := nonMetaClass classVarAt:eachVariableName.
oldValue notNil ifTrue:[
thisValue := oldValue numericValue.
] ifFalse:[
thisValue := runValue.
runValue := runValue + 1.
].
initCode
nextPutAll:' ';
nextPutAll:eachVariableName;
nextPutAll:' := self basicNew'.
(aClass canUnderstand:#'setNumericValue:') ifTrue:[
initCode nextPutAll:' setNumericValue: ',thisValue printString.
].
(aClass canUnderstand:#'setCssClassString:') ifTrue:[
initCode nextPutAll:('; setCssClassString: ''' , nonMetaClass nameWithoutPrefix asLowercaseFirst , eachVariableName , '''').
].
(aClass canUnderstand:#'setName:') ifTrue:[
initCode nextPutAll:('; setName: ''' , eachVariableName asLowercaseFirst , '''').
].
initCode nextPutLine:'.'.
].
initCode cr.
initCode nextPutLine:' "'.
initCode nextPutLine:' ',className, ' initialize'.
initCode nextPutLine:' "'.
self
compile:(initCode contents)
forClass:metaClass
inCategory:#'class initialization'.
code := 'allStateNames\ ^ #( ' ,
((enumValues collect:[:each | '#''',each asLowercaseFirst,'''']) asStringWith:' ') , ')',
'\\ "\' ,
' ',className, ' allStateNames\' ,
' "\'.
self
compile:code withCRs
forClass:metaClass
inCategory:#queries.
self executeCollectedChangesNamed:('Generate EnumType Code for ' , className).
aClass initialize.
"Modified: / 1.2.1998 / 16:10:03 / cg"
!
createExamplesMethodForViewClass:aClass
"create an examples method"
|nonMetaClass metaClass className code|
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
self startCollectChanges.
(metaClass includesSelector:#examples) ifFalse:[
code :=
'examples
"
Notice that everything between [exBegin] and [exEnd] is extracted by the html-doc generator
to create nicely formatted and clickable executable examples in the generated html-doc.
(see the browsers class-documentation menu items for more)
trying the widget as standAlone view:
[exBegin]
%1 new open
[exEnd]
embedded in another view:
[exBegin]
|top v|
top := StandardSystemView new.
top extent:300@300.
v := %1 new.
v origin:10@10 corner:150@150.
top add:v.
top open
[exEnd]
"
' bindWith:className.
self
compile:code
forClass:metaClass
inCategory:#documentation.
].
self executeCollectedChangesNamed:('Add Example to ' , className).
!
createInitializationMethodIn:aClass
"create a #initialize methods (I'm tired of typing)"
|nonMetaClass metaClass className code initializer m|
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
self startCollectChanges.
(nonMetaClass includesSelector:#initialize) ifFalse:[
code :=
'initialize
"Invoked when a new instance is created."
"/ please change as required (and remove this comment)
'.
nonMetaClass instVarNames do:[:eachInstVar |
initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...
code := code , (' "/ ' , eachInstVar , ' := ' , initializer , '.' , Character cr).
].
m := nonMetaClass responseTo:#initialize.
(m notNil and:[m messagesSent size == 0]) ifTrue:[
"/ inherits an empty initialize.
code := code , '
"/ super initialize. -- commented since inherited method does nothing
'.
] ifFalse:[
code := code , '
super initialize.
'.
].
self
compile:code
forClass:nonMetaClass
inCategory:#initialization.
].
self executeCollectedChangesNamed:('Add Initialized Instance Creation to ' , className).
!
createInitializedInstanceCreationMethodsIn:aClass
"create a #new and #initialize methods (I'm tired of typing)"
|nonMetaClass metaClass className code m|
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
self startCollectChanges.
self createInitializationMethodIn:aClass.
(metaClass includesSelector:#new) ifFalse:[
m := metaClass responseTo:#new.
(m isNil
or:[ (m sendsSelector:#initialize) not
or:[
(Dialog
confirmWithCancel:('The inherited #new method already seems to invoke #initialize.\Redefine ?' withCRs)
default:false
onCancel:[^ self] )
]]) ifTrue:[
code :=
'new
"return an initialized instance"
^ self basicNew initialize.
'.
self
compile:code
forClass:metaClass
inCategory:#'instance creation'.
].
].
self executeCollectedChangesNamed:('Add Initialized Instance Creation to ' , className).
"Created: / 11-10-2001 / 22:18:55 / cg"
"Modified: / 30-01-2011 / 00:58:04 / cg"
!
createIsAbstractMethodIn:aClass
"create a #isAbstract query method (I'm tired of typing)"
|metaClass className code|
metaClass := aClass theMetaclass.
className := aClass theNonMetaclass name.
self startCollectChanges.
(metaClass includesSelector:#isAbstract) ifFalse:[
code :=
'isAbstract
"Return if this class is an abstract class.
True is returned here for myself only; false for subclasses.
Abstract subclasses must redefine this again."
^ self == ',className,'.
'.
self
compile:code
forClass:metaClass
inCategory:#'queries'.
].
self executeCollectedChangesNamed:('Make ',className,' abstract').
!
createParametrizedInstanceCreationMethodsNamed:selector in:aClass
"create a #selector instance creation method (I'm tired of typing)"
|nonMetaClass metaClass className code initializer m dfn|
dfn := Method methodDefinitionTemplateForSelector:selector.
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
self startCollectChanges.
(nonMetaClass includesSelector:selector asSymbol) ifFalse:[
code :=
'initialize',dfn asUppercaseFirst,'
"Invoked when a new instance is created for arg."
"/ please change as required (and remove these comments)
"/ do something with arg here (instVar-foo := arg)
'.
nonMetaClass instVarNames do:[:eachInstVar |
initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...
code := code , (' "/ ' , eachInstVar , ' := ' , initializer , '.' , Character cr).
].
m := nonMetaClass responseTo:#initialize.
(m notNil and:[ m messagesSent size == 0 ]) ifTrue:[
"/ inherits an empty initialize.
code := code , '
"/ super initialize. -- commented since inherited method does nothing
'.
] ifFalse:[
code := code , '
super initialize.
'.
].
self
compile:code
forClass:nonMetaClass
inCategory:#initialization.
].
(metaClass includesSelector:selector) ifFalse:[
m := metaClass responseTo:selector.
(m isNil
or:[ (Dialog confirmWithCancel:'The ',selector,'- method is already inherited. Redefine ?' onCancel:[^ self]) ])
ifTrue:[
code :=
dfn,'
"Create & return a new instance for arg."
^ self basicNew initialize',dfn asUppercaseFirst,'
'.
self
compile:code
forClass:metaClass
inCategory:#'instance creation'.
].
].
self executeCollectedChangesNamed:('Add Parametrized Instance Creation to ' , className).
!
createPoolInitializationCodeFor:aClass
|nonMetaClass metaClass className poolVars initCode|
self startCollectChanges.
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
poolVars := nonMetaClass classVarNames.
initCode := WriteStream on:''.
initCode nextPutLine:'initialize'.
poolVars do:[:eachVariableName |
|oldValue thisValue|
oldValue := nonMetaClass classVarAt:eachVariableName.
oldValue notNil ifTrue:[
thisValue := oldValue.
] ifFalse:[
thisValue := nil.
].
initCode
nextPutAll:' ';
nextPutAll:eachVariableName;
nextPutAll:' := ';
nextPutAll:thisValue storeString;
nextPutLine:'.'.
].
initCode cr.
initCode nextPutLine:' "'.
initCode nextPutLine:' ',className, ' initialize'.
initCode nextPutLine:' "'.
self
compile:(initCode contents)
forClass:metaClass
inCategory:#'class initialization'.
self executeCollectedChangesNamed:('Generate Pool Initialization Code for ' , className).
aClass initialize.
"Created: / 25-10-2006 / 09:28:40 / cg"
!
createRedefinedInstanceCreationMethodsIn:aClass
"create a redefined #new methods"
|nonMetaClass metaClass className code|
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
self startCollectChanges.
(metaClass includesSelector:#'new') ifFalse:[
code :=
'new
^ super new.
'.
self
compile:code
forClass:metaClass
inCategory:#'redefined instance creation'.
].
(metaClass includesSelector:#'new:') ifFalse:[
code :=
'new:n
^ super new:n.
'.
self
compile:code
forClass:metaClass
inCategory:#'redefined instance creation'.
].
self executeCollectedChangesNamed:('Redefined Instance Creation to ' , className).
!
createSingletonPatternInstanceCreationMethodsIn:aClass usingVariable:varName
"create redefined #new methods for singleton pattern.
Uses varName (typically a class-instvar) to keep the singleton instance."
|nonMetaClass metaClass className code|
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
self startCollectChanges.
(metaClass includesSelector:#theOneAndOnlyInstance) ifFalse:[
code :=
'theOneAndOnlyInstance
"returns a singleton"
%1 isNil ifTrue:[
%1 := self basicNew initialize.
].
^ %1.
'.
self
compile:(code bindWith:varName)
forClass:metaClass
inCategory:#'instance creation'.
].
(metaClass includesSelector:#new) ifFalse:[
code :=
'new
"returns a singleton"
^ self theOneAndOnlyInstance.
'.
self
compile:(code bindWith:varName)
forClass:metaClass
inCategory:#'instance creation'.
].
(metaClass includesSelector:#flushSingleton) ifFalse:[
code :=
'flushSingleton
"flushes the cached singleton"
%1 := nil
"
self flushSingleton
"
'.
self
compile:(code bindWith:varName)
forClass:metaClass
inCategory:#'instance creation'.
].
self executeCollectedChangesNamed:('Singleton Pattern for ' , className).
"Created: / 10-02-2011 / 16:32:48 / cg"
!
createStandaloneStartupCodeFor:aClass
"create an empty console application framework"
|metaClass nonMetaclass className txt|
targetClass := aClass.
self startCollectChanges.
metaClass := aClass theMetaclass.
nonMetaclass := aClass theNonMetaclass.
className := nonMetaclass name.
(metaClass includesSelector:#applicationRegistryPath) ifFalse:[
txt := self codeFor_standAloneApplicationRegistryPathFor:nonMetaclass.
self
compile:(txt bindWith:className)
forClass:metaClass
inCategory:'constants & defaults'.
].
(metaClass includesSelector:#applicationUUID) ifFalse:[
txt := self codeFor_standAloneApplicationUUID.
self
compile:(txt bindWith:className)
forClass:metaClass
inCategory:'constants & defaults'.
].
(metaClass includesSelector:#usage) ifFalse:[
txt := self codeFor_standAloneUsage.
self
compile:(txt bindWith:className)
forClass:metaClass
inCategory:'startup'.
].
(metaClass includesSelector:#'main:') ifFalse:[
txt := self codeFor_standAloneMainFor:nonMetaclass.
self
compile:(txt bindWith:className)
forClass:metaClass
inCategory:'startup'.
].
self executeCollectedChangesNamed:('Add StandaloneStartup Code for ' , className).
"Created: / 19-08-2011 / 02:01:31 / cg"
"Modified: / 14-06-2016 / 07:37:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
createStandardPrintOnMethodIn:aClass
"create a #printOn: method (I'm tired of typing)"
|code nonMetaClass|
nonMetaClass := aClass theNonMetaclass.
self startCollectChanges.
(nonMetaClass includesSelector:#printOn:) ifFalse:[
code :=
'printOn:aStream
"append a printed representation of the receiver to the argument, aStream"
super printOn:aStream.
'.
nonMetaClass 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:nonMetaClass
inCategory:#'printing & storing'.
].
self executeCollectedChangesNamed:('Add #printOn: to ' , nonMetaClass name).
"Created: / 11.10.2001 / 22:18:55 / cg"
!
createStartupCodeFor:aClass forStartOf:anApplicationClassOrNil
"create startup code (main)"
|nonMetaClass metaClass className source
hasAplicationClass anApplicationClassNameOrStartupClassName|
self startCollectChanges.
hasAplicationClass := anApplicationClassOrNil notNil.
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
(metaClass includesSelector:#main:) ifFalse:[
source := String streamContents:[:stream |
stream nextPutAll:
'main:argv
self verboseInfo:''starting %1''.
'.
hasAplicationClass ifTrue: [
stream nextPutAll:
' Smalltalk openDisplay.
Display notNil ifTrue:[
Display exitOnLastClose:true.
].
%1 open.
'.
] ifFalse:[
stream nextPutAll:
' "/ replace by real code
Stdout nextPutLine:''Hello World''.
'.
].
].
anApplicationClassNameOrStartupClassName := hasAplicationClass
ifTrue: [anApplicationClassOrNil name]
ifFalse: [className.].
self
compile:(source bindWith:anApplicationClassNameOrStartupClassName)
forClass:metaClass
inCategory:#startup.
].
self executeCollectedChangesNamed:('Add Startup Code to ' , className).
!
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|
self assert:( visitedClass isMeta not ).
self assert:( visitorClass isMeta not ).
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').
!
createVisitorMethodsIn:visitedClass andVisitorClass:visitorClass withParameter:withParameter withSuper:withSuper
"
This is much like createVisitorMethodsIn:andVisitorClass:,
but:
- if withParameter is true, generates
#acceptVisitor:with:
and
#visit<CLASNAME>:with:
- if withSuper is true, generates
self visit<SUPERCLASSNAME>:[with:] in the visitXXX methods body"
| sel superSel template |
self assert:(visitedClass isMeta not).
self assert:(visitorClass isMeta not).
self startCollectChanges.
sel := ('visit' , visitedClass nameWithoutPrefix , ':').
superSel := ('visit' , visitedClass superclass nameWithoutPrefix , ':').
template := '`@sel: object %1
"Dispatched back from the visited object (visitor pattern)"
^ %2
'
bindWith:(withParameter ifTrue:['with: param'] ifFalse:[''])
with:(withSuper
ifTrue:[
'self `@superSel: anObject'
, (withParameter ifTrue:[' with: param'] ifFalse:[''])
]
ifFalse:['self subclassResponsibility']).
self createAcceptVisitorMethod:sel in:visitedClass withParameter: withParameter.
(visitorClass includesSelector:sel) ifFalse:[
self addChange:((Tools::CodeGenerator new)
class:visitorClass;
protocol:'visiting';
source:template;
replace:'`@sel:' with:sel asSymbol;
replace:'`@superSel:' with:superSel asSymbol;
change)
].
(visitorClass includesSelector:#visit:) ifFalse:[
self
compile:('visit:object %1
"visit anObject (visitor pattern).
The object should call back one of my visitXXXX methods."
^ object acceptVisitor:self %1
'
bindWith:(withParameter ifTrue:['with: parameter'] ifFalse:['']))
forClass:visitorClass
inCategory:'visiting'.
].
self executeCollectedChangesNamed:('Add Visitor Pattern').
"Created: / 05-08-2013 / 13:13:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
createWebApplicationCodeFor:aClass
"create an empty webApplication framework"
|nonMetaClass metaClass className txt|
self startCollectChanges.
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
(metaClass includesSelector:#pageSpec) ifFalse:[
txt := self class initialPageSpecMethodSourceForWebApplications.
self
compile:(txt bindWith:className)
forClass:metaClass
inCategory:#'page specs'.
].
self executeCollectedChangesNamed:('Add WebApplication Code for ' , className).
"Modified: / 1.2.1998 / 16:10:03 / cg"
!
createWebServiceCodeFor:aClass
"create an empty webService framework"
|nonMetaClass metaClass className txt|
self startCollectChanges.
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
(nonMetaClass includesSelector:#page1:) ifFalse:[
txt :=
'page1:aRequest
"This is a sample page-generation method.
This uses the simplest possible way to generate html: generating plain HTML.
See page2 for a more structured example."
<resource: #PAGE>
|response|
response := aRequest response.
response nextPutLine:''<HTML>''.
response nextPutLine:'' <HEAD>''.
response nextPutLine:'' <TITLE>Hello</TITLE>''.
response nextPutLine:'' </HEAD>''.
response nextPutLine:'' <BODY>''.
response nextPutLine:'' <H1>Hello World !!</H1>''.
response nextPutLine:'' </BODY>''.
response nextPutLine:''</HTML>''.
'.
self
compile:txt
forClass:nonMetaClass
inCategory:#'response generation - pages'.
].
(nonMetaClass includesSelector:#page2:) ifFalse:[
txt :=
'page2:aRequest
"This is a sample page-generation method.
This uses a slightly more convenient way to generate html: using an HTML tree builder.
Even better examples to follow..."
<resource: #PAGE>
|page|
page := HTML::TreeBuilder newDocument.
page
head;
title:''Hello'';
headEnd;
body;
h1:''Hello World'';
div;
nlsText:''here is some text and '';
a; href:''page3'';
text:''an anchor to page3'';
aEnd;
text:'' and an image: '';
img:(httpServer graphicLinkIdFor:(ToolbarIconLibrary smiley_cool) expirationTimeDelta:30 seconds);
divEnd;
bodyEnd.
aRequest reply:(page htmlString).
'.
self
compile:txt
forClass:nonMetaClass
inCategory:#'response generation - pages'.
].
(nonMetaClass includesSelector:#page3:) ifFalse:[
txt :=
'page3:aRequest
"This is a sample page which generates plain text (i.e. not html)."
<resource: #PAGE>
aRequest response
contentType:''text/plain'';
data:''This is some plain text,
without any html formatting.''
'.
self
compile:txt
forClass:nonMetaClass
inCategory:#'response generation - pages'.
].
(nonMetaClass includesSelector:#process:) ifFalse:[
txt :=
'process:aRequest
"This is the web services main processing method.
It will be invoked for every incoming webBrowser-request.
The argument, aRequest contains the parameters (url, fields, parameters etc.); browse HTTPRequest for details.
Its response object collects any returned html or other contents. Browse HTTPResponse for more info.
Here, a simple dipatch method is used: a hardcoded switch on the URL...
It uses the page-name directly as selector for the page-generating method.
Because that would open a possible security hole (incoming url being #halt, for example),
we only call methods which have been annotated with PAGE (see sample pages)"
|whichPage methodName method|
whichPage := aRequest pathRelativeToService.
whichPage isEmpty ifTrue:[ whichPage := ''page1'' ].
"/ to prevent intruders from calling any method, check if it one
"/ of my own methods, which is marked as a PAGE-method.
methodName := (whichPage,'':'') asSymbol.
method := self class compiledMethodAt:methodName.
"/ is there such a method ?
method notNil ifTrue:[
"/ and it is marked as being a WebPage-generator ?
(method hasResource:#''PAGE'') ifTrue:[
self perform:methodName with:aRequest.
^ self
].
].
aRequest reportNotFound:''No such page in this service''.
'.
self
compile:txt
forClass:nonMetaClass
inCategory:#'response generation'.
].
(metaClass includesSelector:#linkName) ifFalse:[
txt :=
'linkName
"return the default linkName path (with slash)."
^ ''/NewService''
'.
self
compile:txt
forClass:metaClass
inCategory:#defaults.
].
(metaClass includesSelector:#settingsApplicationClass) ifFalse:[
txt :=
'settingsApplicationClass
"a SettingsApplication class - or nil (used in the settings dialog if non-nil)."
^ nil
'.
self
compile:txt
forClass:metaClass
inCategory:#defaults.
].
(nonMetaClass includesSelector:#addRequiredForeignServicesTo:) ifFalse:[
txt :=
'addRequiredForeignServicesTo:aServer
"add any additional (usually file-) services"
"/ uncomment to install additional standard file services
"/ self addStandardFileServicesTo:aServer.
"/ uncomment and add an instance variable named ''tentativeObjectService'' if you need
"/ a tentative object service
"/ tentativeObjectService := aServer tentativeObjectService.
"/ uncomment to install a file service for my data files (in the ''data'' folder of my project directory
"/ (aServer serviceForLink:(self linkName,''/data'') ifAbsent:nil) isNil ifTrue:[
"/ aServer addFileServiceWithRootLinkName:(self linkName,''/data'')
"/ rootDirectory:(self class projectDirectory / ''data'')
"/ defaultFileName:nil.
"/ ].
'.
self
compile:txt
forClass:nonMetaClass
inCategory:#initialization.
].
self executeCollectedChangesNamed:('Add WebService Code for ' , className).
"Modified: / 02-06-2011 / 12:51:15 / cg"
!
createWidgetCodeFor:aClass
"create usually required widget code (redraw, model update, event handling)"
|nonMetaClass metaClass className compileTemplateAction|
self startCollectChanges.
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
className := nonMetaClass name.
compileTemplateAction :=
[:selector :templateSelector :category |
(nonMetaClass includesSelector:selector) ifFalse:[
|txt|
txt := self perform:templateSelector.
self
compile:txt
forClass:nonMetaClass
inCategory:category.
]
].
#(
initialize code_forWidget_initialize #'initialization & release'
update:with:from: code_forWidget_update #'change & update'
redrawX:y:width:height: code_forWidget_redraw #'drawing'
buttonPress:x:y: code_forWidget_buttonPress #'event handling'
keyPress:x:y: code_forWidget_keyPress #'event handling'
sizeChanged: code_forWidget_sizeChanged #'event handling'
) inGroupsOf:3 do:compileTemplateAction.
self executeCollectedChangesNamed:('Add Widget Code for ' , className).
! !
!SmalltalkCodeGeneratorTool 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 generateCommentsForSetters generateCommentsForGetters spaceAfterKeyword|
self startCollectChanges.
generateCommentsForSetters := userPreferences generateCommentsForSetters.
generateCommentsForGetters := userPreferences generateCommentsForGetters.
classesClassVars := aClass theNonMetaclass allClassVarNames.
spaceAfterKeyword := RBFormatter spaceAfterKeywordSelector ifTrue: [ ' ' ] ifFalse: [ '' ].
aCollectionOfVarNames do:[:name |
|source varType methodName defaultMethodName argName|
varType := (classesClassVars includes:name)
ifTrue:['static']
ifFalse:[
(aClass isMeta ifTrue:['classInstVar'] ifFalse:['instance'])].
methodName := name.
name isUppercaseFirst ifTrue:[
(name conform:[:ch | ch isLetter not or:[ch isUppercase]]) ifFalse:[ "/ allow all-uppercase for class-vars
methodName := methodName asLowercaseFirst.
]
].
argName := 'something'.
"/ 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:',spaceAfterKeyword,'[\'.
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:',spaceAfterKeyword,'[\'
, ' %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 theMetaclass includesSelector:(defaultMethodName asSymbol)) ifFalse:[
source := defaultMethodName , '\'.
generateComments ifTrue:[
source := source , ' "default value for the ''%2'' instance variable (automatically generated)"\\'.
].
source := source
, ' self shouldImplement.\'
, ' ^ nil.'.
source := (source bindWith:varType with:name) withCRs.
self compile:source forClass:aClass theMetaclass inCategory:#defaults.
].
].
].
"/ the SETTER
readersOnly ifFalse:[
(aClass includesSelector:(methodName asMutator)) ifFalse:[
((methodName size > 2) and:[ (methodName startsWith:'is') and:[ (methodName at:3) isUppercase ]])
ifTrue:[
argName := 'aBoolean'
].
asValueHolder ifTrue:[
source := methodName , ':',spaceAfterKeyword,'%3\'. "/ argName
generateComments ifTrue:[
source := source , ' "set the ''%2'' value holder' , ' (automatically generated)"\\'.
].
withChange ifTrue:[
source := source
, ' |oldValue newValue|\\'
, ' %2 notNil ifTrue:',spaceAfterKeyword,'[\'
, ' oldValue := %2 value.\'
, ' %2 removeDependent:',spaceAfterKeyword,'self.\'
, ' ].\'
, ' %2 := %3.\' "/ argName
, ' %2 notNil ifTrue:',spaceAfterKeyword,'[\'
, ' %2 addDependent:',spaceAfterKeyword,'self.\'
, ' ].\'
, ' newValue := %2 value.\'
, ' oldValue ~~ newValue ifTrue:',spaceAfterKeyword,'[\'
, ' self update:',spaceAfterKeyword,'#value with:',spaceAfterKeyword,'newValue from:',spaceAfterKeyword,'%2.\'
, ' ].\'
] ifFalse:[
source := source
, ' %2 := %3.'. "/ argName
].
] ifFalse:[
source := methodName , ':',spaceAfterKeyword,'%3\'. "/ argName
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 ~~ %3) ifTrue:[\'
, ' %2 := %3.\' "/ argName
, ' self changed:',spaceAfterKeyword,'#%2.\'
, ' ].\'.
] ifFalse:[
generateCommentsForSetters ifTrue:[
source := source , ' "set the value of the %1 variable ''%2'''.
source := source , ' (automatically generated)"\\'.
].
source := source
, ' %2 := %3.'. "/ argName
].
].
source := (source bindWith:varType with:name with:argName) withCRs.
self
compile:source
forClass:aClass
inCategory:(asValueHolder ifTrue:[#aspects] ifFalse:[#accessing]).
] ifTrue:[
Transcript showCR:'method ''', methodName , ':'' already present'
].
].
].
self executeCollectedChangesNamed:('Add Accessors').
"Modified: / 21-07-2011 / 15:19:25 / cg"
"Modified: / 01-02-2023 / 11:10:13 / Jan Vrany <jan.vrany@labware.com>"
!
createCollectionAccessMethodsFor:aCollectionOfVarNames in:aClass withChange:withChange
|classesClassVars|
self startCollectChanges.
classesClassVars := aClass theNonMetaclass allClassVarNames.
aCollectionOfVarNames do:[:name |
|source varType methodNameBase methodName defaultMethodName|
varType := (classesClassVars includes:name)
ifTrue:['static']
ifFalse:[
(aClass isMeta ifTrue:['classInstVar'] ifFalse:['instance'])].
methodNameBase := name asUppercaseFirst.
(methodNameBase endsWith:'s') ifTrue:[
methodNameBase := methodNameBase copyButLast:1.
].
methodName := 'add' , methodNameBase, ':'.
"check, if method is not already present"
(aClass includesSelector:(methodName asSymbol)) ifFalse:[
source := methodName , 'a%1\'.
generateComments ifTrue:[
source := source , ' "add a ',methodNameBase,'"\\'.
].
source := source , ' %2 isNil ifTrue:[\'.
source := source
, ' %2 := OrderedCollection new.\'.
source := source
, ' ].\'
, ' %2 add: a%1'.
source := (source bindWith:methodNameBase with:name) withCRs.
self compile:source forClass:aClass inCategory:#accessing.
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
methodName := 'remove' , methodNameBase, ':'.
"check, if method is not already present"
(aClass includesSelector:(methodName asSymbol)) ifFalse:[
source := methodName , 'a%1\'.
generateComments ifTrue:[
source := source , ' "remove a ',methodNameBase,'"\\'.
].
source := source
, ' %2 remove: a%1'.
source := (source bindWith:methodNameBase with:name) withCRs.
self compile:source forClass:aClass inCategory:#accessing.
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
].
self
createAccessMethodsFor:aCollectionOfVarNames
in:aClass
withChange:withChange
asValueHolder:false
readersOnly:true
writersOnly:false
lazyInitialization:false.
self executeCollectedChangesNamed:('Add Collection Access').
"Created: / 04-02-2007 / 15:52:31 / cg"
!
createValueHoldersFor:aCollectionOfVarNames in:aClass lazyInitialization:lazyInitialization
"workhorse for creating access methods for instvars."
|nonMetaClass metaClass classesClassVars generateCommentsForSetters generateCommentsForGetters|
nonMetaClass := aClass theNonMetaclass.
metaClass := aClass theMetaclass.
self startCollectChanges.
generateCommentsForSetters := userPreferences generateCommentsForSetters.
generateCommentsForGetters := userPreferences generateCommentsForGetters.
classesClassVars := nonMetaClass allClassVarNames.
aCollectionOfVarNames do:[:name |
|source varType methodName holderMethodName defaultMethodName|
holderMethodName := name.
name isUppercaseFirst ifTrue:[
holderMethodName := holderMethodName asLowercaseFirst.
].
(holderMethodName endsWith:'Holder') ifTrue:[
methodName := holderMethodName copyButLast:6.
] ifFalse:[
methodName := holderMethodName.
holderMethodName := methodName , 'Holder'.
].
methodName notNil ifTrue:[
(metaClass 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:nonMetaClass inCategory:#accessing.
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
(metaClass includesSelector:(methodName asMutator)) 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:nonMetaClass inCategory:#accessing.
] ifTrue:[
Transcript showCR:'method ''', methodName , ':'' already present'
].
].
(metaClass 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:nonMetaClass inCategory:#accessing.
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
].
self executeCollectedChangesNamed:('Add ValueHolder').
! !
!SmalltalkCodeGeneratorTool methodsFor:'code generation-individual methods'!
createAcceptVisitorMethod:selector in:aClass
^ self createAcceptVisitorMethod:selector in:aClass withParameter: false.
"Modified: / 05-08-2013 / 13:34:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
createAcceptVisitorMethod:selector in:aClass withParameter: withParameter
"create an acceptVisitor: method
(I'm tired of typing)"
self assert:( aClass isMeta not ).
(aClass includesSelector:#'acceptVisitor:') ifFalse:[
self
compile:
(('acceptVisitor:visitor %2
"Double dispatch back to the visitor, passing my type encoded in
the selector (visitor pattern)"
"stub code automatically generated - please change if required"
^ visitor %1self %2
') bindWith:selector with:(withParameter ifTrue:[' with: parameter'] ifFalse:['']))
forClass:aClass
inCategory:#visiting.
]
"Created: / 05-08-2013 / 13:34:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
createAcceptVisitorMethodIn:aClass
"create an acceptVisitor: method
(I'm tired of typing)"
self
createAcceptVisitorMethod:('visit' , aClass nameWithoutPrefix) asMutator
in:aClass
!
createAspectMethodFor:anAspectSymbol in:aClass
"create an aspect method."
|source aspect|
aspect := anAspectSymbol asSymbol.
source := String
streamContents:[:s |
s nextPutAll:aspect asString.
s nextPutAll:'
|holder|
(holder := builder bindingAt:',aspect storeString,') isNil ifTrue:[
builder aspectAt:',aspect storeString,' put:(holder := nil asValue).
].
^ holder.
'.
].
self compile:source forClass:aClass inCategory:#aspects.
!
createCopyrightMethodFor:copyRightText for:aClass
"add copyright method containing text,
but only if not already present."
|txt log thisYear initialYear scm firstRev firstRevDate|
(aClass includesSelector:#copyright) ifFalse:[
copyRightText notNil ifTrue:[
initialYear := thisYear := Date today year.
(copyRightText includes:$%) ifTrue:[
scm := aClass theNonMetaclass sourceCodeManager.
scm == CVSSourceCodeManager ifTrue:[
log := CVSSourceCodeManager revisionLogOf:aClass fromRevision:'1.1' toRevision:'1.1'.
log isNil ifTrue:[
initialYear := thisYear
] ifFalse:[
(firstRev := (log at:#revisions) firstIfEmpty:nil) notNil ifTrue:[
firstRevDate := firstRev at:#date ifAbsent:nil.
firstRevDate notNil ifTrue:[
firstRevDate := Date readFrom:firstRevDate onError:nil.
firstRevDate notNil ifTrue:[
initialYear := firstRevDate year.
]
]
]
].
].
].
thisYear ~= initialYear ifTrue:[
txt := copyRightText bindWith:(initialYear printString, '-', thisYear printString).
] ifFalse:[
txt := copyRightText bindWith:initialYear.
].
self compile:
'copyright
"
' , txt , '
"
' forClass:aClass
inCategory:#documentation.
]
].
!
createDocumentationMethodFor:aClass
"add documentation method containing doc template
but only if not already present."
|metaClass nonMetaClass userName loginName hostName emailAddress code existingComment|
metaClass := aClass theMetaclass.
nonMetaClass := aClass theNonMetaclass.
(metaClass includesSelector:#documentation) ifFalse:[
existingComment := nonMetaClass comment.
existingComment isEmptyOrNil ifTrue:[
(nonMetaClass isSubclassOf:HTTPService) ifTrue:[
existingComment := ' [start Server with:]
HTTPServer startServerOnPort:8080
[start with:]
(self new)
registerServiceOn:(HTTPServer runningServerOnPort:8080)'.
].
].
userName := OperatingSystem getFullUserName.
loginName := OperatingSystem getLoginName.
hostName := OperatingSystem getHostName.
emailAddress := loginName , '@' , hostName.
"/ ugly; should ask the class for that
metaClass isJavaScriptMetaclass ifTrue:[
code :=
'function documentation() {
/*
' , (existingComment ? ' documentation to be added.') , '
[author:]
' ", userName
, ' (' , emailAddress , ')' "
, UserPreferences current historyManagerSignature , '
[instance variables:]
[class variables:]
[see also:]
*/
}
'
] ifFalse:[
code:=
'documentation
"
' , (existingComment ? ' documentation to be added.') , '
[author:]
' ", userName
, ' (' , emailAddress , ')' "
, UserPreferences current historyManagerSignature , '
[instance variables:]
[class variables:]
[see also:]
"
'
].
self
compile:code
forClass:metaClass
inCategory:#documentation.
].
"Modified: / 24-11-2006 / 15:54:27 / cg"
"Modified: / 04-02-2011 / 08:24:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
createExamplesMethodFor:aClass
"add examples method containing examples template
but only if not already present."
|nonMetaclass fragment|
nonMetaclass := aClass theNonMetaclass.
(nonMetaclass isSubclassOf:View) ifTrue:[
self createExamplesMethodForViewClass:aClass.
^ self
].
(nonMetaclass isSubclassOf:ApplicationModel) ifFalse:[
^ self
].
(aClass includesSelector:#examples) ifFalse:[
(nonMetaclass isSubclassOf:ApplicationModel) ifTrue:[
fragment := ' Starting the application:
[exBegin]
' , nonMetaclass 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.
].
!
createFalseReturnMethodFor:aSelector category:cat in:aClass
"add a ^ false method;
but only if not already present."
(aClass includesSelector:aSelector) ifFalse:[
self compile:
(Method methodDefinitionTemplateForSelector:aSelector) ,
'
"return false here; to be redefined in subclass(es)"
^ false
'
forClass:aClass
inCategory:cat.
].
!
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 "theNonMetaclass" name, ' ', sel.
Icon constantNamed: imageKey put:nil.
self
compile: ((sel,
'\', comment,
'\\' ,
' "\',
' self ' , sel , ' inspect\',
' ImageEditor openOnClass:self andSelector:#', sel, '\',
' Icon flushCachedIcons',
'\ "',
'\\',
' <resource: #image>',
'\\',
' ^Icon\') withCRs,
' constantNamed:''', imageKey, '''\' withCRs,
' ifAbsentPut:[', imageStoreStream contents, ']')
forClass:aClass
inCategory: category.
"Modified: / 01-07-2011 / 12:31:12 / cg"
!
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 instMthd argNames|
(aMetaClass includesSelector:selector) ifFalse:[
instMthd := aMetaClass theNonMetaclass compiledMethodAt:selector.
(instMthd notNil
and:[ (argNames := instMthd methodArgNames) notEmptyOrNil ])
ifTrue:[
template := Parser methodSpecificationForSelector:selector argNames:argNames.
] ifFalse:[
template := Parser methodSpecificationForSelector:selector.
].
self
compile:
template , '
^ self new ' , template , '
'
forClass:aMetaClass
inCategory:category.
].
!
createMultiSetterInstanceCreationMethodFor:aCollectionOfVarNames in:aClass
"create a multi-setter instance creator method for instvars."
|argPart source|
self createMultiSetterMethodFor:aCollectionOfVarNames in:aClass.
source := ''.
aCollectionOfVarNames do:[:eachVar |
source := source , (eachVar , ':' , eachVar , 'Arg ').
].
argPart := source.
source := source , Character cr.
(userPreferences generateCommentsForSetters) ifTrue:[
source := source , (' "return a new instance with multiple instance variables initialized"' , Character cr , Character cr).
].
source := source , (' ^ self new ' , argPart).
self compile:source forClass:aClass theMetaclass inCategory:#'instance creation'.
!
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.
(userPreferences generateCommentsForSetters) ifTrue:[
source := source , (' "set instance variables"' , Character cr , Character cr).
].
aCollectionOfVarNames do:[:eachVar |
source := source , (' ' , eachVar , ' := ' , eachVar , 'Arg.' , Character cr).
].
self compile:source forClass:aClass inCategory:#accessing.
!
createShouldImplementMethodFor: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: this method should be implemented (TODO)"
^ self shouldImplement
'
forClass:aClass
inCategory:cat.
].
!
createSubclassResponsibilityMethodFor:aSelector category:cat in:aClass
"add a subclassResponsibility method;
but only if not already present."
| subclasses implementors header |
(aClass includesSelector:aSelector) ifTrue: [ ^ self ].
"/ Find 'closest' implementors to pick argument names from.
implementors := #().
subclasses := aClass subclasses.
[ implementors isEmpty and:[ subclasses notEmpty ] ] whileTrue: [
implementors := SystemBrowser findImplementorsOf:aSelector in: subclasses ignoreCase: false.
implementors notEmpty ifTrue: [
subclasses := (subclasses gather: [ :cls | cls subclasses ]).
].
].
implementors notEmpty ifTrue: [
| implementor |
"/ JV@2021-05-05: Here we just pick anyone, but is it
"/ a good idea? Shouldn;t we check all implementors having
"/ the same arg names and warn if not? Dunno.
implementor := implementors anyOne.
header := implementor methodDefinitionTemplate.
] ifFalse: [
header := SmalltalkLanguage current methodDefinitionTemplateForSelector: aSelector.
].
self compile:
header ,
'
^ self subclassResponsibility
'
forClass:aClass
inCategory:cat.
"Modified: / 05-05-2021 / 10:34:17 / Jan Vrany <jan.vrany@labware.com>"
!
createUpdateMethodIn:aClass
"create an update:with:from:-method
(I'm tired of typing)"
|code|
(aClass includesSelector:#update:with:from:) ifFalse:[
generateComments ifFalse:[
code :=
'update:something with:aParameter from:changedObject
super update:something with:aParameter from:changedObject
'
] ifTrue:[
code :=
'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
'
].
self
compile:code
forClass:aClass
inCategory:#'change & update'.
]
!
createVersionMethodFor:aClass
<resource: #obsolete>
"add a version method containing RCS template
but only if not already present and it's not a private class."
|code|
self obsoleteMethodWarning.
aClass isPrivate ifFalse:[
(aClass includesSelector:#version) ifFalse:[
code := aClass programmingLanguage methodTemplateForVersionMethodCVS.
self
compile:code
forClass:aClass
inCategory:#documentation.
]
].
"Modified (comment): / 21-08-2012 / 11:54:57 / cg"
! !
!SmalltalkCodeGeneratorTool methodsFor:'code templates'!
anyApplicationClassInProjectOf:aClass
|prjDefinition|
prjDefinition := aClass projectDefinitionClass.
prjDefinition isNil ifTrue:[ ^ nil ].
^ (prjDefinition allClasses
select:[:cls | cls isSubclassOf:ApplicationModel])
firstIfEmpty:nil.
"Created: / 21-01-2012 / 13:24:12 / cg"
!
codeFor_classInitialize
generateComments ifFalse:[
^
'initialize
%(INIT_CLASSINSTVARS)
%(INIT_CLASSVARS)
'.
].
^
'initialize
"Invoked at system start or when the class is dynamically loaded."
"/ please change as required (and remove this comment)
%(INIT_CLASSINSTVARS)
%(INIT_CLASSVARS)
'.
!
codeFor_closeAccept
generateComments ifFalse:[
^
'closeAccept
^ super closeAccept
'.
].
^
'closeAccept
"This is a hook method generated by the Browser/CodeGeneratorTool.
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 (otherwise, the dialog will not close itself)...
^ super closeAccept
'.
"Created: / 27-10-2006 / 10:03:31 / cg"
!
codeFor_closeDownViews
generateComments ifFalse:[
^
'closeDownViews
^ super closeDownViews
'.
].
^
'closeDownViews
"This is a hook method generated by the Browser/CodeGeneratorTool.
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
'.
"Created: / 27-10-2006 / 10:01:32 / cg"
!
codeFor_closeRequest
generateComments ifFalse:[
^
'closeRequest
self hasUnsavedChanges ifTrue:[
(self confirm:(resources string:''Close without saving ?'')) ifFalse:[
^ self
]
].
^ super closeRequest
'.
].
^
'closeRequest
"This is a hook method generated by the Browser/CodeGeneratorTool.
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 ifTrue:[
(self confirm:(resources string:''Close without saving ?'')) ifFalse:[
^ self
]
].
^ super closeRequest
'.
"Created: / 27-10-2006 / 10:01:06 / cg"
!
codeFor_emptyMenuActionCodeFor:selector menuItem:item
generateComments ifFalse:[
^
selector,'
self warn:''no action for ''''',item,''''' defined.''.
'.
].
^
selector,'
"This method was generated by the Browser/CodeGeneratorTool.
It will be invoked when the menu-item ''',item,''' is selected."
"/ change below and add any actions as required here ...
self warn:''no action for ''''',item,''''' defined.''.
'.
"Created: / 27-10-2006 / 10:16:43 / cg"
!
codeFor_hasUnsavedChanges
generateComments ifFalse:[
^
'hasUnsavedChanges
^ false.
'.
].
^
'hasUnsavedChanges
"Return true, if any unsaved changes are present
(i.e. the contents needs to be saved or else will be lost)"
"/ add real code as required (or remove the halt and always return false)...
"/ self halt:''check this code''.
^ false.
'.
"Created: / 27-10-2006 / 10:00:36 / cg"
!
codeFor_menuSaveAs
^
'menuSaveAs
"This method was generated by the Browser/CodeGeneratorTool.
It will be invoked when the menu-item ''saveAs'' is selected."
"/ change below as required... (see examples in Dialog class for more options)
Dialog
requestSaveFileName:(resources string:''Save'')
default:''foo.txt''
fromDirectory:nil
action:[:fileName | self doSaveAs:fileName]
appendAction:nil.
'.
"Created: / 27-10-2006 / 10:01:57 / cg"
!
codeFor_openAboutThisApplication
^
'openAboutThisApplication
"This method was generated by the Browser/CodeGeneratorTool.
It will be invoked when the menu-item ''help-about'' is selected."
"/ could open a customized aboutBox here ...
super openAboutThisApplication
'.
"Created: / 27-10-2006 / 10:03:13 / cg"
!
codeFor_openDocumentation
^
'openDocumentation
"This method was generated by the Browser/CodeGeneratorTool.
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>/'' ):
self openDocumentationFile:''TOP.html''.
"/ add application-specific help files under the ''doc/online/<language>/help/appName''
"/ directory, and open a viewer with:
"/ self openDocumentationFile:''help/<MyApplication>/TOP.html''.
'.
"Created: / 27-10-2006 / 10:02:55 / cg"
!
codeFor_postBuildWith
generateComments ifFalse:[
^
'postBuildWith:aBuilder
^ super postBuildWith:aBuilder
'.
].
^
'postBuildWith:aBuilder
"This is a hook method generated by the Browser/CodeGeneratorTool.
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
'.
"Created: / 27-10-2006 / 09:59:33 / cg"
!
codeFor_postOpenWith
generateComments ifFalse:[
^
'postOpenWith:aBuilder
^ super postOpenWith:aBuilder
'.
].
^
'postOpenWith:aBuilder
"This is a hook method generated by the Browser/CodeGeneratorTool.
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
'.
"Created: / 27-10-2006 / 09:59:56 / cg"
!
codeFor_standAloneApplicationRegistryPathFor:aClassOrNil
|pkg appClass|
pkg := 'someUniqueName'.
aClassOrNil notNil ifTrue:[
(appClass := self anyApplicationClassInProjectOf:aClassOrNil) notNil ifTrue:[
pkg := appClass nameWithoutPrefix.
]
].
generateComments ifFalse:[
^
'applicationRegistryPath
^ #(''stx'' ''%1'')
' bindWith:pkg.
].
^
'applicationRegistryPath
"for windows only:
the key under which this application stores its process ID in the registry
as a collection of path-components.
i.e. if #(''foo'' ''bar'' ''baz'') is returned here, the current application''s ID will be stored
in HKEY_CURRENT_USER\Software\foo\bar\baz\CurrentID.
(would also be used as a relative path for a temporary lock file under unix).
Used to detect if another instance of this application is already running."
^ #(''stx'' ''%1'')
' bindWith:pkg.
"Created: / 21-01-2012 / 11:23:40 / cg"
!
codeFor_standAloneApplicationUUID
generateComments ifFalse:[
^
'applicationUUID
^ UUID fromString:''', UUID genUUID printString, '''
'.
].
^
'applicationUUID
"answer an application-specific unique uuid.
This is used as the name of some exclusive OS-resource, which is used to find out,
if another instance of this application is already running.
Under win32, a mutex is used; under unix, an exclusive file in the tempDir could be used.
If redefined, please return a real UUID (i.e. UUID fromString:''.....'') and not a string or
similar possibly conflicting identifier.
You can paste a fresh worldwide unique id via the editor''s ''more''-''misc''-''paste UUID'' menu function."
^ UUID fromString:''', UUID genUUID printString, '''
'.
"Created: / 19-08-2011 / 02:13:19 / cg"
!
codeFor_standAloneMainFor:aClass
| application code |
application := self anyApplicationClassInProjectOf:aClass.
code := 'main: argv
"Application entry point. `argv` is the array of command arguments (as Array of Strings)"
| optparser positional |
optparser := CmdLineParser new.
optparser
"/ on: #(''-s'' ''--long'') do:[ ... ];
"/ on: #(''-I'' ''--include'') do:[ :value | includes add: value ];
on: #(''-h'' ''--help'') do:[ self usage. Smalltalk exitIfStandalone:0 ].
[
positional := optparser parse:argv.
] on: CmdLineOptionError do:[:ex |
Stderr nextPutAll: ''ERROR: ''; nextPutLine: ex description.
Smalltalk exitIfStandalone:0.
].
'.
application notNil ifTrue:[
code := code , '
%1 open.
' bindWith: application name
] ifFalse:[
code := code , '
Stdout nextPutLine:''Hello World''.
Stdout nextPutLine:(positional asStringWith:Character space)
'
].
^ code
"
self new codeFor_standAloneMainFor: HelloWorld0Start
"
"Created: / 14-06-2016 / 07:28:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeFor_standAloneUsage
^
'usage
"output some command-line usage infos on stderr"
Stderr nextPutLine:''usage: '',self applicationName,'' [options...]''.
Stderr nextPutLine:'' --noInfoPrint ........ disable diagnostic messages''.
Stderr nextPutLine:'' -h ................... output this message''.
Stderr nextPutLine:'' -a <file> ............ a-argument(s)''.
Stderr nextPutLine:'' -b <file> ............ b-argument(s)''.
Stderr nextPutLine:'' -c ................... c-option''.
'.
"Created: / 19-08-2011 / 02:22:46 / cg"
"Modified: / 06-06-2016 / 14:59:19 / cg"
!
code_forWidget_buttonPress
generateComments ifFalse:[
^
'buttonPress:button x:x y:y
Transcript show:''button: ''; showCR:button.
super buttonPress:button x:x y:y
'
].
^
'buttonPress:button x:x y:y
"called when a mouse-button is pressed. button is the button-nr (1 for left-button).
x/y are the mouse position at the time of the click.
There are also corresponding buttonRelease and buttonMotion methods which could be
redefined...."
Transcript show:''button: ''; showCR:button.
"/ super-code handles middleButtonMenu, if it was assigned (with middleButtonmenu:)
super buttonPress:button x:x y:y
'
!
code_forWidget_initialize
^
'initialize
super initialize "/ to initialize inherited state
"/ add code to initialize private variables,
"/ and sub-components as required.
'
!
code_forWidget_keyPress
generateComments ifFalse:[
^
'keyPress:key x:x y:y
"/ key == #Copy ifTrue:[
"/ ].
"/ key == #Cut ifTrue:[
"/ ].
Transcript show:''key: ''; showCR:key.
super keyPress:key x:x y:y
'
].
^
'keyPress:key x:x y:y
"called when a keyboard-key was pressed. key is either a character (for ordinary keys)
or a symbol, such as #Copy, #Cut or #Paste.
x/y are the mouse position at the time of the key-press.
There is also a corresponding keyRelease method which could be redefined...."
Transcript show:''key: ''; showCR:key.
super keyPress:key x:x y:y
'
!
code_forWidget_redraw
|sel comment code|
sel := 'redrawX:x y:y width:w height:h'.
generateComments ifFalse:[
comment := ''.
] ifTrue:[
comment := '
"called to redraw a part of the widgets area. x/y define the origin, w/h the size of
that area. The clipping region has already been set by the caller, so even if the code
below draws outside the redraw-area, it will not affect what is on the screen.
Therefore, the example below can fill the rectangle in the redraw area, but still draw
the cross in the outside regions."
'.
].
code := '
self paint:Color red.
self fillRectangleX:x y:y width:w height:h.
self paint:Color yellow.
self displayLineFrom:0@0 to:(width@height).
self displayLineFrom:width@0 to:(0@height).
'.
^ sel,comment,code
!
code_forWidget_sizeChanged
generateComments ifFalse:[
^
'sizeChanged:how
self invalidate.
super sizeChanged:how.
'
].
^
'sizeChanged:how
"Invoked whenever the size of the view changes.
Here, we force a full redraw, which might not be needed all the time"
self invalidate.
super sizeChanged:how.
'
!
code_forWidget_update
generateComments ifFalse:[
^
'update:something with:aParameter from:changedObject
changedObject == model ifTrue:[
self invalidate.
^ self
].
super update:something with:aParameter from:changedObject
'
].
^
'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 == model ifTrue:[
self invalidate.
^ self
].
super update:something with:aParameter from:changedObject
'
! !
!SmalltalkCodeGeneratorTool methodsFor:'compilation'!
compilerClass
"Return a real compiler classto use to compile code"
^ Compiler
"Created: / 05-08-2014 / 21:03:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!SmalltalkCodeGeneratorTool methodsFor:'private'!
codeFor_shouldImplementFor:selector inClass:aClass
"used in the 'generate required protocol' to generate a shouldImplement-sending
method for each subclassClassresponsibility method above aClass."
|mthd comment implClass methodBodyStream searcher errorMessageString|
(aClass notNil
and:[ aClass superclass notNil ]) ifTrue:[
implClass := aClass superclass whichClassImplements:selector.
].
implClass isNil ifTrue:[
^ ((Method methodDefinitionTemplateForSelector:selector),'\ ^ self shouldImplement\') withCRs
].
mthd := implClass compiledMethodAt:selector.
methodBodyStream := '' writeStream.
methodBodyStream
nextPutAll:mthd methodDefinitionTemplate; cr.
"/ include the comment of the subclassResponsibility-sending method
UserPreferences current generateComments ifTrue: [
methodBodyStream nextPutAll:' "'.
comment := mthd methodComment.
comment isEmptyOrNil ifTrue:[
methodBodyStream
nextPutAll:('superclass <1s> says that I am responsible to implement this method'
expandMacrosWith:implClass name)
] ifFalse:[
comment
asStringCollection do:[:eachLine|
methodBodyStream nextPutAll:eachLine.
] separatedBy:[
methodBodyStream cr; nextPutAll:' '.
].
].
methodBodyStream
nextPut:$"; cr; cr.
].
"/ include the argument of the subclassResponsibility:-sending method
self canUseRefactoringSupport ifTrue:[
(mthd sendsSelector:#subclassResponsibility:) ifTrue:[
searcher := ParseTreeSearcher new.
searcher
matches: 'self subclassResponsibility: `''.*'''
do:[:node :answer |
errorMessageString := node arguments first value.
true.
].
searcher executeTree: (mthd parseTree) initialAnswer: false.
].
].
errorMessageString notEmptyOrNil ifTrue:[
methodBodyStream
nextPutAll:' ^ self shouldImplement:';
nextPutLine:(errorMessageString storeString)
] ifFalse:[
methodBodyStream
nextPutLine:' ^ self shouldImplement'.
].
^ methodBodyStream contents
"Modified: / 06-03-2023 / 15:18:27 / Jan Vrany <jan.vrany@labware.com>"
! !
!SmalltalkCodeGeneratorTool class methodsFor:'documentation'!
version
^ '$Header$'
!
version_CVS
^ '$Header$'
!
version_HG
^ '$Changeset: <not expanded> $'
!
version_SVN
^ '$Id$'
! !