1 "

     2  COPYRIGHT (c) 2002 by eXept Software AG

     3               All Rights Reserved

     4 

     5  This software is furnished under a license and may be used

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

     7  inclusion of the above copyright notice.   This software may not

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

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

    10  hereby transferred.

    11 "

    12 "{ Package: 'stx:libtool' }"

    13 

    14 CodeGeneratorTool subclass:#SmalltalkCodeGeneratorTool

    15 	instanceVariableNames:''

    16 	classVariableNames:''

    17 	poolDictionaries:''

    18 	category:'Interface-Browsers'

    19 !

    20 

    21 !SmalltalkCodeGeneratorTool class methodsFor:'documentation'!

    22 

    23 copyright

    24 "

    25  COPYRIGHT (c) 2002 by eXept Software AG

    26               All Rights Reserved

    27 

    28  This software is furnished under a license and may be used

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

    30  inclusion of the above copyright notice.   This software may not

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

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

    33  hereby transferred.

    34 "

    35 !

    36 

    37 documentation

    38 "

    39     This utility class contains various code generation facilites;

    40     these were extracted from the old and newBrowser.

    41     There is probably more to come...

    42 

    43     [author:]

    44         Claus Gittiner

    45 "

    46 ! !

    47 

    48 !SmalltalkCodeGeneratorTool class methodsFor:'code generation'!

    49 

    50 initialMenuSpecMethodSourceForApplications

    51     "return code for a menuSpec with typical stuff in it"

    52 

    53     ^

    54 'mainMenu

    55     "This resource specification was automatically generated by the CodeGeneratorTool."

    56 

    57     "Do not manually edit this!! If it is corrupted,

    58      the MenuEditor may not be able to read the specification."

    59 

    60     "

    61      MenuEditor new openOnClass:%1 andSelector:#mainMenu

    62     "

    63 

    64     <resource: #menu>

    65 

    66     ^ ',(self initialMenuSpecForApplications decodeAsLiteralArray literalArrayEncoding storeString),'

    67 '.

    68 !

    69 

    70 initialPageMenuSpecMethodSourceForWebApplications

    71     "return code for a menuSpec with typical stuff in it"

    72 

    73     ^

    74 'mainMenu

    75     "This resource specification was automatically generated by the CodeGeneratorTool."

    76 

    77     "Do not manually edit this!! If it is corrupted,

    78      the MenuEditor may not be able to read the specification."

    79 

    80     "

    81      MenuEditor new openOnClass:%1 andSelector:#mainMenu

    82     "

    83 

    84     <resource: #menu>

    85 

    86     ^ ',(self initialPageMenuSpecForWebApplications decodeAsLiteralArray literalArrayEncoding storeString),'

    87 '.

    88 

    89     "

    90      self initialPageMenuSpecMethodSourceForWebApplications

    91     "

    92 !

    93 

    94 initialPageSpecMethodSourceForWebApplications

    95     "return an empty pageSpec"

    96 

    97     ^

    98 'pageSpec

    99     "This resource specification was automatically generated by the CodeGeneratorTool."

   100 

   101     "Do not manually edit this!! If it is corrupted,

   102      the UIPainter may not be able to read the specification."

   103 

   104     "

   105      UIPainter new openOnClass:%1 andSelector:#pageSpec

   106     "

   107 

   108     <resource: #canvas>

   109 

   110     ^ ',(self initialPageSpecForWebApplications decodeAsLiteralArray literalArrayEncoding storeString),'

   111 '.

   112 !

   113 

   114 initialToolbarMenuSpecMethodSource

   115     "return a menuSpec with typical stuff in it"

   116 

   117     ^

   118 'toolbarMenu

   119     "This resource specification was automatically generated by the CodeGeneratorTool."

   120 

   121     "Do not manually edit this!! If it is corrupted,

   122      the MenuEditor may not be able to read the specification."

   123 

   124     "

   125      MenuEditor new openOnClass:%1 andSelector:#toolbarMenu

   126     "

   127 

   128     <resource: #menu>

   129 

   130     ^ ',(self initialToolbarMenuSpec decodeAsLiteralArray literalArrayEncoding storeString),'

   131 '.

   132 

   133     "

   134      self initialToolbarMenuSpecMethodSource

   135     "

   136 !

   137 

   138 initialWindowSpecMethodSourceForApplications

   139     "return an empty windowSpec with an initial menubar in it"

   140 

   141     ^

   142 'windowSpec

   143     "This resource specification was automatically generated by the CodeGeneratorTool."

   144 

   145     "Do not manually edit this!! If it is corrupted,

   146      the UIPainter may not be able to read the specification."

   147 

   148     "

   149      UIPainter new openOnClass:%1 andSelector:#windowSpec

   150     "

   151 

   152     <resource: #canvas>

   153 

   154     ^ ',

   155         self initialWindowSpecForApplications2 decodeAsLiteralArray prettyPrintString           

   156 .

   157 

   158     "

   159      self initialWindowSpecMethodSourceForApplications

   160     "

   161 !

   162 

   163 initialWindowSpecMethodSourceForDialogs

   164     "return an empty windowSpec for dialogs"

   165 

   166     ^

   167 'windowSpec

   168     "This resource specification was automatically generated by the CodeGeneratorTool."

   169 

   170     "Do not manually edit this!! If it is corrupted,

   171      the UIPainter may not be able to read the specification."

   172 

   173     "

   174      UIPainter new openOnClass:%1 andSelector:#windowSpec

   175     "

   176 

   177     <resource: #canvas>

   178 

   179     ^ ',

   180         self initialWindowSpecForDialogs decodeAsLiteralArray prettyPrintString           

   181 ! !

   182 

   183 !SmalltalkCodeGeneratorTool class methodsFor:'code generation-menus'!

   184 

   185 createActionMethodFor:aSelector in:aClass category:aCategory redefine:redefine

   186     |alreadyInSuperclass method code|

   187 

   188     (aClass includesSelector:aSelector) ifTrue:[

   189         ^ nil

   190     ].

   191 

   192     alreadyInSuperclass := aClass superclass canUnderstand:aSelector.

   193     (alreadyInSuperclass and:[redefine not]) ifTrue:[

   194         ^ nil

   195     ].

   196 

   197     method := self methodNameTemplateFor:aSelector.

   198 

   199     code := '%1

   200     "automatically generated by UIEditor ..."

   201 

   202     "*** the code below performs no action"

   203     "*** (except for some feedback on the Transcript)"

   204     "*** Please change as required and accept in the browser."

   205     "*** (and replace this comment by something more useful ;-)"

   206 

   207     "action to be added ..."

   208 

   209     Transcript showCR:self class name, '': action for #%2 ...''.

   210 ' bindWith:method with:aSelector.

   211 

   212     alreadyInSuperclass ifTrue:[

   213         code := code, (('\    super %1\' bindWith:method) withCRs).

   214     ].

   215     self compile:code forClass:aClass inCategory:(aCategory ? 'actions').

   216     ^ code

   217 !

   218 

   219 createAspectMethodFor:aSelector in:aClass category:aCategory redefine:redefine

   220     |alreadyInSuperclass method code text|

   221 

   222     (aClass includesSelector:aSelector) ifTrue:[

   223         ^ nil

   224     ].

   225 

   226     alreadyInSuperclass := aClass superclass canUnderstand:aSelector.

   227     (alreadyInSuperclass and:[redefine not]) ifTrue:[

   228         ^ nil

   229     ].

   230 

   231     method := self methodNameTemplateFor:aSelector.

   232 

   233     code := '%1

   234     "automatically generated by UIEditor ..."

   235 

   236     "*** the code below creates a default model when invoked"

   237     "*** (which may not be the one you wanted)"

   238     "*** Please change as required and accept in the browser."

   239     "*** (and replace this comment by something more useful ;-)"

   240 

   241     "aspect to be added ..."

   242 

   243     Transcript showCR:self class name, '': aspect for #%2 ...''.

   244 

   245 ' bindWith:method with:aSelector.

   246 

   247     alreadyInSuperclass ifTrue:[

   248         text := '    ^ super %1\' bindWith:method.

   249     ] ifFalse:[

   250         text := '    ^ builder valueAspectFor:#''%1'' initialValue:true\' bindWith:aSelector.

   251     ].

   252     code := code, (text withCRs).

   253     self compile:code forClass:aClass inCategory:(aCategory ? 'actions').

   254     ^ code

   255 ! !

   256 

   257 !SmalltalkCodeGeneratorTool class methodsFor:'private'!

   258 

   259 methodNameTemplateFor:aSelector

   260     |numArgs method|

   261 

   262     numArgs := aSelector numArgs.

   263     numArgs == 1 ifTrue:[

   264         method := aSelector, 'anArgument'.

   265     ] ifFalse:[

   266         numArgs == 0 ifTrue:[

   267             method := aSelector

   268         ] ifFalse:[

   269             method := ''.

   270             aSelector keywords keysAndValuesDo:[:i :key|

   271                 method := method, key, 'arg', i printString, ' '.

   272             ].

   273         ]

   274     ].

   275     ^ method

   276 ! !

   277 

   278 !SmalltalkCodeGeneratorTool methodsFor:'code generation'!

   279 

   280 createClassInitializeMethodIn:aClass

   281     "create a #initialize method on the class side (I'm tired of typing)"

   282 

   283     |nonMetaClass metaClass className code initializer bindings|

   284 

   285     nonMetaClass := aClass theNonMetaclass.

   286     metaClass := aClass theMetaclass.

   287     className := nonMetaClass name.

   288 

   289     self startCollectChanges.

   290 

   291     (metaClass includesSelector:#'initialize') ifFalse:[

   292 'initialize

   293     "Invoked at system start or when the class is dynamically loaded."

   294 

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

   296 '.

   297         bindings := Dictionary new.

   298         bindings at:'INIT_CLASSINSTVARS' put:(

   299             String streamContents:[:s |

   300                 metaClass instVarNames do:[:eachClassInstVar |

   301                     initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...

   302                     s nextPutLine:('    "/ %1 := %2.' bindWith:eachClassInstVar with:initializer).

   303                 ]

   304             ]).

   305 

   306         bindings at:'INIT_CLASSVARS' put:(

   307             String streamContents:[:s |

   308                 nonMetaClass classVarNames do:[:eachClassVar |

   309                     initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...

   310                     s nextPutLine:('    "/ %1 := %2.' bindWith:eachClassVar with:initializer).

   311                 ]

   312             ]).

   313 

   314         code := (self codeFor_classInitialize) expandPlaceholdersWith:bindings.

   315 

   316         self 

   317             compile:code

   318             forClass:metaClass 

   319             inCategory:'initialization'.

   320     ].

   321 

   322     self executeCollectedChangesNamed:('Add Class Initializer to ' , className).

   323 !

   324 

   325 createClassTypeTestMethodsIn:aClass forClasses:subClasses

   326     "create a #isXXX test methods (I'm tired of typing)"

   327 

   328     | code|

   329 

   330     self startCollectChanges.

   331 

   332     subClasses do:[:eachSubClass |

   333         |nm selector|

   334 

   335         nm := eachSubClass nameWithoutPrefix.

   336         selector := 'is' , nm.

   337         (aClass includesSelector:selector) ifFalse:[

   338             code := (selector , '\    ^ false') withCRs.

   339             self 

   340                 compile:code

   341                 forClass:aClass 

   342                 inCategory:'testing'.

   343         ].

   344         (eachSubClass includesSelector:selector) ifFalse:[

   345             code := (selector , '\    ^ true') withCRs.

   346             self 

   347                 compile:code

   348                 forClass:eachSubClass 

   349                 inCategory:'testing'.

   350         ].

   351     ].

   352 

   353     self executeCollectedChangesNamed:'Add ClassType Tests'

   354 !

   355 

   356 createEnumTypeCodeFor:aClass

   357     |nonMetaClass metaClass className enumValues code initCode runValue maxValue|

   358 

   359     self startCollectChanges.

   360 

   361     nonMetaClass := aClass theNonMetaclass.

   362     metaClass := aClass theMetaclass.

   363     className := nonMetaClass name.

   364 

   365     enumValues := nonMetaClass classVarNames.

   366     enumValues do:[:eachVariableName |

   367         self 

   368             createAccessMethodsFor:(Array with:eachVariableName)

   369             in:metaClass  

   370             withChange:false

   371             asValueHolder:false

   372             readersOnly:true    

   373             writersOnly:false

   374     ].

   375 

   376     maxValue := enumValues 

   377                     inject:0 

   378                     into:[:maxSoFar :eachVariableName | 

   379                             |oldVal val| 

   380                             oldVal := nonMetaClass classVarAt:eachVariableName.

   381                             oldVal notNil ifTrue:[ val := oldVal numericValue ].

   382                             (val ? maxSoFar) max:maxSoFar

   383                          ].

   384 

   385     initCode := WriteStream on: String new.

   386     initCode nextPutLine:'initialize'.

   387     runValue := maxValue + 1.

   388     enumValues keysAndValuesDo:[:idx :eachVariableName |

   389         |oldValue thisValue|

   390 

   391         oldValue := nonMetaClass classVarAt:eachVariableName.

   392         oldValue notNil ifTrue:[

   393             thisValue := oldValue numericValue.

   394         ] ifFalse:[

   395             thisValue := runValue.

   396             runValue := runValue + 1.

   397         ].

   398         initCode 

   399             nextPutAll:'    ';

   400             nextPutAll:eachVariableName;

   401             nextPutAll:' := self basicNew'.

   402         (aClass canUnderstand:#'setNumericValue:') ifTrue:[

   403             initCode nextPutAll:' setNumericValue: ',thisValue printString.

   404         ].

   405         (aClass canUnderstand:#'setCssClassString:') ifTrue:[

   406             initCode nextPutAll:('; setCssClassString: ''' , nonMetaClass nameWithoutPrefix asLowercaseFirst , eachVariableName , '''').

   407         ].

   408         (aClass canUnderstand:#'setName:') ifTrue:[

   409             initCode nextPutAll:('; setName: ''' , eachVariableName asLowercaseFirst , '''').

   410         ].

   411         initCode nextPutLine:'.'.

   412     ].

   413     initCode cr.

   414     initCode nextPutLine:'    "'.

   415     initCode nextPutLine:'     ',className, ' initialize'.

   416     initCode nextPutLine:'    "'.

   417 

   418     self

   419         compile:(initCode contents)

   420         forClass:metaClass 

   421         inCategory:'class initialization'.

   422 

   423 

   424     code := 'allStateNames\    ^ #( ' ,

   425                 ((enumValues collect:[:each | '#''',each asLowercaseFirst,'''']) asStringWith:' ') , ')',

   426                 '\\    "\' ,

   427                 '     ',className, ' allStateNames\' ,

   428                 '    "\'.

   429     self

   430         compile:code withCRs

   431         forClass:metaClass 

   432         inCategory:'queries'.

   433 

   434     self executeCollectedChangesNamed:('Generate EnumType Code for ' , className).

   435 

   436     aClass initialize.

   437 

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

   439 !

   440 

   441 createExamplesMethodForViewClass:aClass

   442     "create an examples method"

   443 

   444     |nonMetaClass metaClass className code|

   445 

   446     nonMetaClass := aClass theNonMetaclass.

   447     metaClass := aClass theMetaclass.

   448     className := nonMetaClass name.

   449 

   450     self startCollectChanges.

   451 

   452     (metaClass includesSelector:#examples) ifFalse:[

   453         code := 

   454 'examples

   455 "

   456  Notice that everything between [exBegin] and [exEnd] is extracted by the html-doc generator

   457  to create nicely formatted and clickable executable examples in the generated html-doc.

   458  (see the browsers class-documentation menu items for more)

   459 

   460  trying the widget as standAlone view:

   461                                                         [exBegin]

   462     %1 new open

   463                                                         [exEnd]

   464 

   465  embedded in another view:

   466                                                         [exBegin]

   467     |top v|

   468 

   469     top := StandardSystemView new.

   470     top extent:300@300.

   471     v := %1 new.

   472     v origin:10@10 corner:150@150.

   473     top add:v.

   474     top open

   475                                                         [exEnd]

   476 "

   477 ' bindWith:className.    

   478 

   479         self 

   480             compile:code

   481             forClass:metaClass 

   482             inCategory:'documentation'.

   483     ].

   484 

   485     self executeCollectedChangesNamed:('Add Example to ' , className).

   486 !

   487 

   488 createInitializationMethodIn:aClass

   489     "create a #initialize methods (I'm tired of typing)"

   490 

   491     |nonMetaClass metaClass className code initializer m|

   492 

   493     nonMetaClass := aClass theNonMetaclass.

   494     metaClass := aClass theMetaclass.

   495     className := nonMetaClass name.

   496 

   497     self startCollectChanges.

   498 

   499     (nonMetaClass includesSelector:#'initialize') ifFalse:[

   500         code :=

   501 'initialize

   502     "Invoked when a new instance is created."

   503 

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

   505 '.

   506 

   507         nonMetaClass instVarNames do:[:eachInstVar |

   508             initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...

   509             code := code , ('    "/ ' , eachInstVar , ' := ' , initializer , '.' , Character cr).

   510         ].

   511 

   512         m := nonMetaClass responseTo:#initialize.

   513         (m notNil and:[m messagesSent size == 0]) ifTrue:[

   514             "/ inherits an empty initialize.

   515 

   516             code := code , '

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

   518 '.

   519         ] ifFalse:[

   520             code := code , '

   521     super initialize.

   522 '.

   523         ].

   524 

   525         self 

   526             compile:code

   527             forClass:nonMetaClass 

   528             inCategory:'initialization'.

   529     ].

   530 

   531     self executeCollectedChangesNamed:('Add Initialized Instance Creation to ' , className).

   532 !

   533 

   534 createInitializedInstanceCreationMethodsIn:aClass

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

   536 

   537     |nonMetaClass metaClass className code m|

   538 

   539     nonMetaClass := aClass theNonMetaclass.

   540     metaClass := aClass theMetaclass.

   541     className := nonMetaClass name.

   542 

   543     self startCollectChanges.

   544 

   545     self createInitializationMethodIn:aClass.

   546 

   547     (metaClass includesSelector:#'new') ifFalse:[

   548         m := metaClass responseTo:#new.

   549         (m isNil 

   550         or:[ (m sends:#initialize) not 

   551         or:[ 

   552             (Dialog 

   553                 confirmWithCancel:'The inherited #new method already seems to invoke #initialize. Redefine ?'

   554                 onCancel:[^ self]) ]]) ifTrue:[

   555             code :=

   556 'new

   557     "return an initialized instance"

   558 

   559     ^ self basicNew initialize.

   560 '.

   561             self 

   562                 compile:code

   563                 forClass:metaClass 

   564                 inCategory:'instance creation'.

   565         ].

   566     ].

   567 

   568     self executeCollectedChangesNamed:('Add Initialized Instance Creation to ' , className).

   569 

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

   571 !

   572 

   573 createParametrizedInstanceCreationMethodsNamed:selector in:aClass

   574     "create a #selector instance creation method (I'm tired of typing)"

   575 

   576     |nonMetaClass metaClass className code initializer m dfn|

   577 

   578     dfn := Method methodDefinitionTemplateForSelector:selector.

   579 

   580     nonMetaClass := aClass theNonMetaclass.

   581     metaClass := aClass theMetaclass.

   582     className := nonMetaClass name.

   583 

   584     self startCollectChanges.

   585 

   586     (nonMetaClass includesSelector:selector asSymbol) ifFalse:[

   587         code :=

   588 'initialize',dfn asUppercaseFirst,'

   589     "Invoked when a new instance is created for arg."

   590 

   591     "/ please change as required (and remove these comments)

   592     "/ do something with arg here (instVar-foo := arg)

   593 '.

   594         nonMetaClass instVarNames do:[:eachInstVar |

   595             initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...

   596             code := code , ('    "/ ' , eachInstVar , ' := ' , initializer , '.' , Character cr).

   597         ].

   598 

   599         m := nonMetaClass responseTo:#initialize.

   600         (m notNil and:[ m messagesSent size == 0 ]) ifTrue:[

   601             "/ inherits an empty initialize.

   602 

   603             code := code , '

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

   605 '.

   606         ] ifFalse:[

   607             code := code , '

   608     super initialize.  

   609 '.

   610         ].

   611 

   612         self 

   613             compile:code

   614             forClass:nonMetaClass 

   615             inCategory:'initialization'.

   616     ].

   617 

   618     (metaClass includesSelector:selector) ifFalse:[

   619         m := metaClass responseTo:selector.

   620         (m isNil 

   621         or:[ (Dialog confirmWithCancel:'The ',selector,'- method is already inherited. Redefine ?' onCancel:[^ self]) ])

   622         ifTrue:[

   623             code :=

   624 dfn,'

   625     "Create & return a new instance for arg."

   626 

   627     ^ self basicNew initialize',dfn asUppercaseFirst,'

   628 '.

   629             self 

   630                 compile:code

   631                 forClass:metaClass 

   632                 inCategory:'instance creation'.

   633         ].

   634     ].

   635 

   636     self executeCollectedChangesNamed:('Add Parametrized Instance Creation to ' , className).

   637 !

   638 

   639 createPoolInitializationCodeFor:aClass

   640     |nonMetaClass metaClass className poolVars code initCode runValue maxValue|

   641 

   642     self startCollectChanges.

   643 

   644     nonMetaClass := aClass theNonMetaclass.

   645     metaClass := aClass theMetaclass.

   646     className := nonMetaClass name.

   647 

   648     poolVars := nonMetaClass classVarNames.

   649 

   650     initCode := WriteStream on: String new.

   651     initCode nextPutLine:'initialize'.

   652 

   653     poolVars do:[:eachVariableName |

   654         |oldValue thisValue|

   655 

   656         oldValue := nonMetaClass classVarAt:eachVariableName.

   657         oldValue notNil ifTrue:[

   658             thisValue := oldValue.

   659         ] ifFalse:[

   660             thisValue := nil.

   661         ].

   662         initCode 

   663             nextPutAll:'    ';

   664             nextPutAll:eachVariableName;

   665             nextPutAll:' := ';

   666             nextPutAll:thisValue storeString;

   667             nextPutLine:'.'.

   668     ].

   669     initCode cr.

   670     initCode nextPutLine:'    "'.

   671     initCode nextPutLine:'     ',className, ' initialize'.

   672     initCode nextPutLine:'    "'.

   673 

   674     self

   675         compile:(initCode contents)

   676         forClass:metaClass 

   677         inCategory:'class initialization'.

   678 

   679     self executeCollectedChangesNamed:('Generate Pool Initialization Code for ' , className).

   680 

   681     aClass initialize.

   682 

   683     "Created: / 25-10-2006 / 09:28:40 / cg"

   684 !

   685 

   686 createRedefinedInstanceCreationMethodsIn:aClass

   687     "create a redefined #new methods"

   688 

   689     |nonMetaClass metaClass className code|

   690 

   691     nonMetaClass := aClass theNonMetaclass.

   692     metaClass := aClass theMetaclass.

   693     className := nonMetaClass name.

   694 

   695     self startCollectChanges.

   696 

   697     (metaClass includesSelector:#'new') ifFalse:[

   698         code :=

   699 'new

   700     ^ super new.

   701 '.

   702         self 

   703             compile:code

   704             forClass:metaClass 

   705             inCategory:'redefined instance creation'.

   706     ].

   707     (metaClass includesSelector:#'new:') ifFalse:[

   708         code :=

   709 'new:n

   710     ^ super new:n.

   711 '.

   712         self 

   713             compile:code

   714             forClass:metaClass 

   715             inCategory:'redefined instance creation'.

   716     ].

   717 

   718     self executeCollectedChangesNamed:('Redefined Instance Creation to ' , className).

   719 !

   720 

   721 createStandardPrintOnMethodIn:aClass

   722     "create a #printOn: method (I'm tired of typing)"

   723 

   724     |code nonMetaClass|

   725 

   726     nonMetaClass := aClass theNonMetaclass.

   727 

   728     self startCollectChanges.

   729 

   730     (nonMetaClass includesSelector:#'printOn:') ifFalse:[

   731         code :=

   732 'printOn:aStream

   733     "append a printed representation if the receiver to the argument, aStream"

   734 

   735     super printOn:aStream.

   736 '.

   737         nonMetaClass instVarNames do:[:eachInstVarName |

   738             code := code , '    '.

   739             code := code , 'aStream nextPutAll:'''.

   740             code := code , eachInstVarName.

   741             code := code , ': ''.' , Character cr.

   742             code := code , '    '.

   743             code := code , eachInstVarName.

   744             code := code , ' printOn:aStream.' , Character cr.

   745         

   746         ].

   747 

   748         self 

   749             compile:code

   750             forClass:nonMetaClass 

   751             inCategory:'printing & storing'.

   752     ].

   753 

   754 

   755     self executeCollectedChangesNamed:('Add #printOn: to ' , nonMetaClass name).

   756 

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

   758 !

   759 

   760 createStartupCodeFor:aClass forStartOf:anApplicationClassOrNil

   761     "create startup code (main)"

   762 

   763     |nonMetaClass metaClass className source 

   764      hasAplicationClass anApplicationClassNameOrStartupClassName|

   765 

   766     self startCollectChanges.

   767 

   768     hasAplicationClass := anApplicationClassOrNil notNil.

   769     nonMetaClass := aClass theNonMetaclass.

   770     metaClass := aClass theMetaclass.

   771     className := nonMetaClass name.

   772 

   773     (metaClass includesSelector:#main:) ifFalse:[

   774 

   775         source := String streamContents:[:stream |

   776             stream nextPutAll: 

   777 'main:argv

   778     self verboseInfo:''starting %1''.

   779 

   780 '.

   781             hasAplicationClass ifTrue: [

   782                 stream nextPutAll: 

   783 '    Smalltalk openDisplay.

   784     Display notNil ifTrue:[

   785         Display exitOnLastClose:true.

   786     ].

   787     %1 open.

   788 '.

   789             ].

   790         ].

   791 

   792         anApplicationClassNameOrStartupClassName := hasAplicationClass 

   793             ifTrue: [anApplicationClassOrNil name]

   794             ifFalse: [className.].

   795         self

   796             compile:(source bindWith:anApplicationClassNameOrStartupClassName)

   797             forClass:metaClass 

   798             inCategory:'startup'.

   799     ].

   800     self executeCollectedChangesNamed:('Add Startup Code to ' , className).

   801 !

   802 

   803 createTestCaseSampleCodeFor:aClass

   804     "create an (almost) empty testCase class"

   805 

   806     |nonMetaClass metaClass|

   807 

   808     nonMetaClass := aClass theNonMetaclass.

   809     metaClass := aClass theMetaclass.

   810     "/ className := nonMetaClass name.

   811 

   812     ( nonMetaClass includesSelector:#test1 ) ifFalse:[

   813         self

   814             compile:

   815 'test1

   816     "This is a demonstration testCase - it is meant to be removed eventually.

   817      This testCase will PASS.

   818      Double click on the TestCase class or open a TestRunner to see me checking...

   819      - please add more methods like this..."

   820 

   821     |o|

   822 

   823     o := Array new:2.

   824     self assert: ( o size == 2 ).

   825     self should: [ o at:0 ] raise:Error.

   826     self shouldnt: [ o at:1 ] raise:Error.

   827 

   828     "

   829      self run:#test1

   830      self new test1

   831     "

   832 '

   833             forClass:nonMetaClass 

   834             inCategory:'tests'.

   835     ].

   836 

   837     ( nonMetaClass includesSelector:#test2 ) ifFalse:[

   838         self

   839             compile:

   840 'test2

   841     "This is a demonstration testCase - it is meant to be removed eventually..

   842      This testCase WILL FAIL.

   843      Double click on the TestCase class or open a TestRunner to see me checking...

   844      - please add more methods like this..."

   845 

   846     |o|

   847 

   848     o := Array new:2.

   849     self assert: ( o size == 3 ).

   850 

   851     "

   852      self run:#test2

   853      self new test2

   854     "

   855 '

   856             forClass:nonMetaClass 

   857             inCategory:'tests'.

   858     ].

   859 

   860     ( nonMetaClass includesSelector:#test3 ) ifFalse:[

   861         self

   862             compile:

   863 'test3

   864     "This is a demonstration testCase - it is meant to be removed eventually..

   865      This testCase WILL generate an ERROR.

   866      Double click on the TestCase class or open a TestRunner to see me checking...

   867      - please add more methods like this..."

   868 

   869     |o|

   870 

   871     o := Array new:2.

   872     self assert: ( o foo ).

   873 

   874     "

   875      self run:#test3

   876      self new test3

   877     "

   878 '

   879             forClass:nonMetaClass 

   880             inCategory:'tests'.

   881     ].

   882 

   883     ( nonMetaClass includesSelector:#setUp ) ifFalse:[

   884         self

   885             compile:

   886 'setUp

   887     "common setup - invoked before testing."

   888 

   889     super setUp

   890 '

   891             forClass:nonMetaClass 

   892             inCategory:'initialize / release'.

   893     ].

   894 

   895     ( nonMetaClass includesSelector:#tearDown ) ifFalse:[

   896         self

   897             compile:

   898 'tearDown

   899     "common cleanup - invoked after testing."

   900 

   901     super tearDown

   902 '

   903             forClass:nonMetaClass 

   904             inCategory:'initialize / release'.

   905     ]

   906 !

   907 

   908 createVisitorMethodsIn:visitedClass andVisitorClass:visitorClass

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

   910 

   911     |sel|

   912 

   913     self assert:( visitedClass isMeta not ).

   914     self assert:( visitorClass isMeta not ).

   915 

   916     self startCollectChanges.

   917 

   918     sel := ('visit' , visitedClass nameWithoutPrefix , ':').

   919     self createAcceptVisitorMethod:sel in:visitedClass.

   920 

   921     (visitorClass includesSelector:sel) ifFalse:[

   922         self 

   923             compile:

   924 (('%1anObject 

   925     "dispatched back from the visited %2-object (visitor pattern)"

   926 

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

   928 

   929     ^ self visitObject:anObject

   930 ') bindWith:sel with:visitedClass nameWithoutPrefix asLowercaseFirst)

   931             forClass:visitorClass 

   932             inCategory:'visiting'.

   933     ].

   934 

   935     (visitorClass includesSelector:#'visitObject:') ifFalse:[

   936         self 

   937             compile:

   938 ('visitObject:anObject 

   939     "dispatched back from the visited objects (visitor pattern)"

   940 

   941     "general fallBack - please change as required"

   942 

   943     self halt:''not yet implemented''

   944 ')

   945             forClass:visitorClass 

   946             inCategory:'visiting'.

   947     ].

   948 

   949     (visitorClass includesSelector:#'visit:') ifFalse:[

   950         self 

   951             compile:

   952 ('visit:anObject 

   953     "visit anObject (visitor pattern).

   954      The object should call back one of my visitXXXX methods."

   955 

   956     ^ anObject acceptVisitor:self

   957 ')

   958             forClass:visitorClass 

   959             inCategory:'visiting'.

   960     ].

   961 

   962     self executeCollectedChangesNamed:('Add Visitor Pattern').

   963 !

   964 

   965 createWebApplicationCodeFor:aClass

   966     "create an empty webApplication framework"

   967 

   968     |nonMetaClass metaClass className txt|

   969 

   970     self startCollectChanges.

   971 

   972     nonMetaClass := aClass theNonMetaclass.

   973     metaClass := aClass theMetaclass.

   974     className := nonMetaClass name.

   975 

   976     (metaClass includesSelector:#pageSpec) ifFalse:[

   977         txt := self class initialPageSpecMethodSourceForWebApplications.

   978         self

   979             compile:(txt bindWith:className)

   980             forClass:metaClass 

   981             inCategory:'page specs'.

   982     ].

   983 

   984     self executeCollectedChangesNamed:('Add WebApplication Code for ' , className).

   985 

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

   987 !

   988 

   989 createWebServiceCodeFor:aClass

   990     "create an empty webService framework"

   991 

   992     |nonMetaClass metaClass className txt|

   993 

   994     self startCollectChanges.

   995 

   996     nonMetaClass := aClass theNonMetaclass.

   997     metaClass := aClass theMetaclass.

   998     className := nonMetaClass name.

   999 

  1000     (nonMetaClass includesSelector:#process:) ifFalse:[

  1001         txt :=

  1002 'process:aRequest

  1003     "This is the web services main processing method.

  1004      It will be invoked for every incoming webBrowser-request.

  1005      The argument, aRequest contains the parameters (url, fields, parameters etc.)."

  1006 

  1007     |response|

  1008 

  1009     response := aRequest response.

  1010     response nextPutLine:''<HTML>''.

  1011     response nextPutLine:''  <HEAD>''.

  1012     response nextPutLine:''  <TITLE>Hello</TITLE>''.

  1013     response nextPutLine:''  </HEAD>''.

  1014     response nextPutLine:''  <BODY>''.

  1015     response nextPutLine:''    <H1>Hello World !!</H1>''.

  1016     response nextPutLine:''  </BODY>''.

  1017     response nextPutLine:''</HTML>''.

  1018 '.

  1019         self

  1020             compile:txt

  1021             forClass:nonMetaClass 

  1022             inCategory:'response generation'.

  1023     ].

  1024 

  1025     (metaClass includesSelector:#linkName) ifFalse:[

  1026         txt :=

  1027 'linkName

  1028     "return the default linkName path (with slash)."

  1029 

  1030     ^ ''/NewService''

  1031 '.

  1032         self

  1033             compile:txt

  1034             forClass:metaClass 

  1035             inCategory:'defaults'.

  1036     ].

  1037 

  1038     (metaClass includesSelector:#settingsApplicationClass) ifFalse:[

  1039         txt :=

  1040 'settingsApplicationClass

  1041     "a SettingsApplication class - or nil (used in the settings dialog if non-nil)."

  1042 

  1043     ^ nil

  1044 '.

  1045         self

  1046             compile:txt

  1047             forClass:metaClass 

  1048             inCategory:'defaults'.

  1049     ].

  1050 

  1051 

  1052     self executeCollectedChangesNamed:('Add WebService Code for ' , className).

  1053 

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

  1055 !

  1056 

  1057 createWidgetCodeFor:aClass

  1058     "create usually required widget code (redraw, model update, event handling)"

  1059 

  1060     |nonMetaClass metaClass className compileTemplateAction|

  1061 

  1062     self startCollectChanges.

  1063 

  1064     nonMetaClass := aClass theNonMetaclass.

  1065     metaClass := aClass theMetaclass.

  1066     className := nonMetaClass name.

  1067 

  1068     compileTemplateAction := 

  1069         [:selector :templateSelector :category |

  1070             (nonMetaClass includesSelector:selector) ifFalse:[

  1071                 |txt|

  1072 

  1073                 txt := self perform:templateSelector.

  1074                 self

  1075                     compile:txt

  1076                     forClass:nonMetaClass 

  1077                     inCategory:category.

  1078             ]

  1079         ].

  1080 

  1081     #(

  1082         #'initialize'               #code_forWidget_initialize  'initialization & release'

  1083         #'update:with:from:'        #code_forWidget_update      'change & update'

  1084         #'redrawX:y:width:height:'  #code_forWidget_redraw      'drawing'

  1085         #'buttonPress:x:y:'         #code_forWidget_buttonPress 'event handling'

  1086         #'keyPress:x:y:'            #code_forWidget_keyPress    'event handling'

  1087         #'sizeChanged:'             #code_forWidget_sizeChanged 'event handling'

  1088     ) inGroupsOf:3 do:compileTemplateAction.

  1089 

  1090     self executeCollectedChangesNamed:('Add Widget Code for ' , className).

  1091 ! !

  1092 

  1093 !SmalltalkCodeGeneratorTool methodsFor:'code generation-basic'!

  1094 

  1095 createAccessMethodsFor:aCollectionOfVarNames in:aClass withChange:withChange asValueHolder:asValueHolder readersOnly:readersOnly writersOnly:writersOnly lazyInitialization:lazyInitialization

  1096     "workhorse for creating access methods for instvars."

  1097 

  1098     |classesClassVars generateCommentsForSetters generateCommentsForGetters|

  1099 

  1100     self startCollectChanges.

  1101 

  1102     generateCommentsForSetters := userPreferences generateCommentsForSetters.

  1103     generateCommentsForGetters := userPreferences generateCommentsForGetters.

  1104 

  1105     classesClassVars := aClass theNonMetaclass allClassVarNames.

  1106 

  1107     aCollectionOfVarNames do:[:name |

  1108         |source varType methodName defaultMethodName argName|

  1109 

  1110         varType := (classesClassVars includes:name) 

  1111                         ifTrue:['static'] 

  1112                         ifFalse:[

  1113                             (aClass isMeta ifTrue:['classInstVar'] ifFalse:['instance'])].

  1114 

  1115         methodName := name.

  1116         name isUppercaseFirst ifTrue:[

  1117             methodName := methodName asLowercaseFirst. 

  1118         ].

  1119         argName := 'something'.

  1120 

  1121         "/ the GETTER

  1122         writersOnly ifFalse:[

  1123             lazyInitialization ifTrue:[

  1124                 defaultMethodName := 'default' , name asUppercaseFirst.

  1125             ].

  1126 

  1127             "check, if method is not already present"

  1128             (aClass includesSelector:(methodName asSymbol)) ifFalse:[

  1129                 asValueHolder ifTrue:[

  1130                     source := methodName , '\'.

  1131                     generateComments ifTrue:[

  1132                         source := source , '    "return/create the ''%2'' value holder (automatically generated)"\\'. 

  1133                     ].

  1134                     source := source , '    %2 isNil ifTrue:[\'.

  1135                     lazyInitialization ifTrue:[