--- a/CodeGeneratorTool.st Wed Sep 29 13:29:55 2004 +0200
+++ b/CodeGeneratorTool.st Thu Sep 30 12:31:18 2004 +0200
@@ -97,6 +97,12 @@
^ self new createVisitorMethodsIn:visitedClass andVisitorClass:visitorClass
!
+createWebApplicationCodeFor:aClass
+ "create an empty webApplication framework"
+
+ ^ self new createWebApplicationCodeFor:aClass
+!
+
initialMenuSpecMethodSourceForApplications
"return a menuSpec with typical stuff in it"
@@ -713,7 +719,7 @@
].
].
- self executeCollectedChangesNamed:('Add Application Code for ' , aClass theNonMetaclass name).
+ self executeCollectedChangesNamed:('Add Application Code for ' , className).
"Modified: / 1.2.1998 / 16:10:03 / cg"
!
@@ -721,12 +727,18 @@
createClassResponsibleProtocolFor:aClass
"create stubs for the required protocol"
+ |nonMetaClass metaClass className|
+
+ nonMetaClass := aClass theNonMetaclass.
+ metaClass := aClass theMetaclass.
+ className := nonMetaClass name.
+
self startCollectChanges.
- self privCreateClassResponsibleProtocolFor:aClass theNonMetaclass.
- self privCreateClassResponsibleProtocolFor:aClass theMetaclass.
+ self privCreateClassResponsibleProtocolFor:nonMetaClass.
+ self privCreateClassResponsibleProtocolFor:metaClass.
- self executeCollectedChangesNamed:('Add Required Protocol to ' , aClass theNonMetaclass name).
+ self executeCollectedChangesNamed:('Add Required Protocol to ' , className).
!
createClassTypeTestMethodsIn:aClass forClasses:subClasses
@@ -763,28 +775,34 @@
createDocumentationMethodsFor:aClass
"create empty documentation methods"
- |cls|
+ |nonMetaClass metaClass className|
- cls := aClass theMetaclass.
+ nonMetaClass := aClass theNonMetaclass.
+ metaClass := aClass theMetaclass.
+ className := nonMetaClass name.
self startCollectChanges.
- self createVersionMethodFor:cls.
- self createCopyrightMethodFor:aClass.
- self createDocumentationMethodFor:aClass.
- self createInitialHistoryMethodFor:aClass.
+ self createVersionMethodFor:metaClass.
+ self createCopyrightMethodFor:metaClass.
+ self createDocumentationMethodFor:metaClass.
+ self createInitialHistoryMethodFor:metaClass.
- self executeCollectedChangesNamed:('Add Documentation to ' , aClass theNonMetaclass name).
+ self executeCollectedChangesNamed:('Add Documentation to ' , className).
!
createStandardInitializationMethodsIn:aClass
"create a #new and #initialize methods (I'm tired of typing)"
- |code initializer m|
+ |nonMetaClass metaClass className code initializer m|
+
+ nonMetaClass := aClass theNonMetaclass.
+ metaClass := aClass theMetaclass.
+ className := nonMetaClass name.
self startCollectChanges.
- (aClass includesSelector:#'initialize') ifFalse:[
+ (nonMetaClass includesSelector:#'initialize') ifFalse:[
code :=
'initialize
"Invoked when a new instance is created."
@@ -794,7 +812,7 @@
"/ please change as required (and remove this comment)
'.
- m := aClass responseTo:#initialize.
+ m := nonMetaClass responseTo:#initialize.
m notNil ifTrue:[
m messagesSent size == 0 ifTrue:[
"/ inherits an empty initialize.
@@ -811,19 +829,19 @@
].
].
- aClass instVarNames do:[:eachInstVar |
+ 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).
].
self
compile:code
- forClass:aClass
+ forClass:nonMetaClass
inCategory:'initialization'.
].
- (aClass class includesSelector:#'new') ifFalse:[
- m := aClass class responseTo:#new.
+ (metaClass includesSelector:#'new') ifFalse:[
+ m := metaClass responseTo:#new.
m notNil ifTrue:[
(m sends:#initialize) ifTrue:[
(self confirm:'The inherited #new method already seems to invoke #initialize. Redefine ?')
@@ -838,11 +856,11 @@
'.
self
compile:code
- forClass:aClass class
+ forClass:metaClass
inCategory:'instance creation'.
].
- self executeCollectedChangesNamed:('Add Initialization to ' , aClass theNonMetaclass name).
+ self executeCollectedChangesNamed:('Add Initialization to ' , className).
"Created: / 11.10.2001 / 22:18:55 / cg"
!
@@ -850,18 +868,20 @@
createStandardPrintOnMethodIn:aClass
"create a #printOn: method (I'm tired of typing)"
- |code|
+ |code nonMetaClass|
+
+ nonMetaClass := aClass theNonMetaclass.
self startCollectChanges.
- (aClass includesSelector:#'printOn:') ifFalse:[
+ (nonMetaClass includesSelector:#'printOn:') ifFalse:[
code :=
'printOn:aStream
"append a printed representation if the receiver to the argument, aStream"
super printOn:aStream.
'.
- aClass instVarNames do:[:eachInstVarName |
+ nonMetaClass instVarNames do:[:eachInstVarName |
code := code , ' '.
code := code , 'aStream nextPutAll:'''.
code := code , eachInstVarName.
@@ -874,12 +894,12 @@
self
compile:code
- forClass:aClass
+ forClass:nonMetaClass
inCategory:'printing & storing'.
].
- self executeCollectedChangesNamed:('Add #printOn: to ' , aClass theNonMetaclass name).
+ self executeCollectedChangesNamed:('Add #printOn: to ' , nonMetaClass name).
"Created: / 11.10.2001 / 22:18:55 / cg"
!
@@ -1044,6 +1064,74 @@
].
self executeCollectedChangesNamed:('Add Visitor Pattern').
+!
+
+createWebApplicationCodeFor:aClass
+ "create an empty webApplication framework"
+
+ |nonMetaClass metaClass className txt|
+
+ self startCollectChanges.
+
+ nonMetaClass := aClass theNonMetaclass.
+ metaClass := aClass theMetaclass.
+ className := nonMetaClass name.
+
+ (nonMetaClass includesSelector:#process:) ifFalse:[
+ txt :=
+'process:aRequest
+ "This is the web applications main processing method.
+ It will be invoked for every incoming webBrowser-request.
+ The argument, aRequest contains the parameters (url, fields, parameters etc.)."
+
+ |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'.
+ ].
+
+ (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'.
+ ].
+
+
+ self executeCollectedChangesNamed:('Add WebApplication Code for ' , className).
+
+ "Modified: / 1.2.1998 / 16:10:03 / cg"
! !
!CodeGeneratorTool methodsFor:'code generation-basic'!
@@ -1209,7 +1297,10 @@
createValueHoldersFor:aCollectionOfVarNames in:aClass lazyInitialization:lazyInitialization
"workhorse for creating access methods for instvars."
- |classesClassVars generateComments generateCommentsForSetters generateCommentsForGetters|
+ |nonMetaClass metaClass classesClassVars generateComments generateCommentsForSetters generateCommentsForGetters|
+
+ nonMetaClass := aClass theNonMetaclass.
+ metaClass := aClass theMetaclass.
self startCollectChanges.
@@ -1217,7 +1308,7 @@
generateCommentsForSetters := UserPreferences current generateCommentsForSetters.
generateCommentsForGetters := UserPreferences current generateCommentsForGetters.
- classesClassVars := aClass theNonMetaclass allClassVarNames.
+ classesClassVars := nonMetaClass allClassVarNames.
aCollectionOfVarNames do:[:name |
|source varType methodName holderMethodName defaultMethodName|
@@ -1234,31 +1325,31 @@
].
methodName notNil ifTrue:[
- (aClass class includesSelector:(methodName asSymbol)) ifFalse:[
+ (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:aClass inCategory:('accessing').
+ self compile:source forClass:nonMetaClass inCategory:('accessing').
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
- (aClass class includesSelector:((methodName , ':') asSymbol)) ifFalse:[
+ (metaClass includesSelector:((methodName , ':') asSymbol)) ifFalse:[
source := '%1: newValue\'.
generateComments ifTrue:[
source := source , ' "set the value in ''%2''"\\'.
].
source := source , ' self %2 value: newValue'.
source := (source bindWith:methodName with:holderMethodName) withCRs.
- self compile:source forClass:aClass inCategory:('accessing').
+ self compile:source forClass:nonMetaClass inCategory:('accessing').
] ifTrue:[
Transcript showCR:'method ''', methodName , ':'' already present'
].
].
- (aClass class includesSelector:(holderMethodName asSymbol)) ifFalse:[
+ (metaClass includesSelector:(holderMethodName asSymbol)) ifFalse:[
source := '%1\'.
generateComments ifTrue:[
source := source , ' "return/create the valueHolder ''%1''"\\'.
@@ -1268,11 +1359,10 @@
source := source , ' ].\'.
source := source , ' ^ %1\'.
source := (source bindWith:holderMethodName) withCRs.
- self compile:source forClass:aClass inCategory:('accessing').
+ self compile:source forClass:nonMetaClass inCategory:('accessing').
] ifTrue:[
Transcript showCR:'method ''', methodName , ''' already present'
].
-
].
self executeCollectedChangesNamed:('Add ValueHolder').
@@ -1345,20 +1435,32 @@
"add documentation method containing doc template
but only if not already present."
- |userName loginName hostName emailAddress code|
+ |metaClass nonMetaClass userName loginName hostName emailAddress code existingComment|
+
+ metaClass := aClass theMetaclass.
+ nonMetaClass := aClass theNonMetaclass.
- (aClass includesSelector:#documentation) ifFalse:[
+ (metaClass includesSelector:#documentation) ifFalse:[
+ existingComment := nonMetaClass comment.
+ existingComment isEmptyOrNil ifTrue:[
+ (nonMetaClass isSubclassOf:HTTPService) ifTrue:[
+ existingComment := ' [start with:]
+ (self new)
+ registerServiceOn:(HTTPServer runningServerOnPort:9090)'.
+ ].
+ ].
+
userName := OperatingSystem getFullUserName.
loginName := OperatingSystem getLoginName.
hostName := OperatingSystem getHostName.
emailAddress := loginName , '@' , hostName.
"/ ugly; should ask the class for that
- aClass isJavaScriptClass ifTrue:[
+ metaClass isJavaScriptClass ifTrue:[
code :=
'function documentation() {
/*
-' , (aClass theNonMetaclass comment ? ' documentation to be added.') , '
+' , (existingComment ? ' documentation to be added.') , '
[author:]
' , userName
@@ -1377,7 +1479,7 @@
code:=
'documentation
"
-' , (aClass theNonMetaclass comment ? ' documentation to be added.') , '
+' , (existingComment ? ' documentation to be added.') , '
[author:]
' , userName
@@ -1395,7 +1497,7 @@
self
compile:code
- forClass:aClass
+ forClass:metaClass
inCategory:'documentation'.
].
!
@@ -1404,13 +1506,18 @@
"add examples method containing examples template
but only if not already present."
- |fragment|
+ |nonMetaclass fragment|
+
+ nonMetaclass := aClass theNonMetaclass.
+ (nonMetaclass isSubclassOf:ApplicationModel) ifFalse:[
+ ^ self
+ ].
(aClass includesSelector:#examples) ifFalse:[
- (aClass theNonMetaclass isSubclassOf:ApplicationModel) ifTrue:[
+ (nonMetaclass isSubclassOf:ApplicationModel) ifTrue:[
fragment := ' Starting the application:
[exBegin]
- ' , aClass theNonMetaclass name , ' open
+ ' , nonMetaclass name , ' open
[exEnd]
'
@@ -1658,5 +1765,5 @@
!CodeGeneratorTool class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/CodeGeneratorTool.st,v 1.29 2004-07-27 14:37:17 ca Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/CodeGeneratorTool.st,v 1.30 2004-09-30 10:31:18 ca Exp $'
! !
--- a/NewSystemBrowser.st Wed Sep 29 13:29:55 2004 +0200
+++ b/NewSystemBrowser.st Thu Sep 30 12:31:18 2004 +0200
@@ -5399,6 +5399,11 @@
translateLabel: true
)
(MenuItem
+ label: 'WebApplication'
+ itemValue: classMenuNewWebApplication
+ translateLabel: true
+ )
+ (MenuItem
label: 'Dialog'
itemValue: classMenuNewDialog
translateLabel: true
@@ -5692,7 +5697,7 @@
translateLabel: true
)
(MenuItem
- enabled: hasApplicationClassSelectedHolder
+ enabled: hasApplicationOrHTTPServiceClassSelectedHolder
label: 'Application Code'
itemValue: classMenuGenerateApplicationCode
translateLabel: true
@@ -11270,6 +11275,13 @@
"Created: / 4.2.2000 / 22:02:53 / cg"
!
+hasApplicationOrHTTPServiceClassSelectedHolder
+ ^ [ self hasApplicationClassSelected
+ | self hasWebApplicationClassSelected]
+
+ "Created: / 4.2.2000 / 22:02:53 / cg"
+!
+
hasAtMostOneClassesSelected
^ self selectedClasses value size <= 1
!
@@ -12482,6 +12494,14 @@
!
+hasWebApplicationClassSelected
+ |selectedClasses|
+
+ selectedClasses := self selectedClasses value.
+ selectedClasses size == 0 ifTrue:[^ false].
+ ^ selectedClasses conform:[:each | each theNonMetaclass isSubclassOf:HTTPService].
+!
+
haskellModulePresent
^ HaskellModule notNil and:[HaskellParser notNil]
!
@@ -16813,7 +16833,14 @@
self
generateUndoableChangeOverSelectedClasses:'Generate ApplicationCode in %(singleClassNameOrNumberOfClasses)'
via:[:generator :eachClass |
- generator createApplicationCodeFor:eachClass theNonMetaclass
+ |cls|
+
+ cls := eachClass theNonMetaclass.
+ (cls isSubclassOf:HTTPService) ifTrue:[
+ generator createWebApplicationCodeFor:cls.
+ ] ifFalse:[
+ generator createApplicationCodeFor:cls
+ ]
]
!
@@ -17467,6 +17494,18 @@
self codeAspect:#newTestCase.
!
+classMenuNewWebApplication
+ "create a class-definition prototype for a web application"
+
+ self
+ classClassDefinitionTemplateFor:HTTPActionService
+ in:(self theSingleSelectedCategory ? 'WebApplications')
+ asNamespace:false
+ private:false.
+
+ self codeAspect:#newWebApplication.
+!
+
classMenuPrimitiveCode:aspect
"show the classes primitiveFunction in the codeView.
Also, set accept action to change it."
@@ -35531,6 +35570,41 @@
^ returnValue.
!
+askForInitialApplicationCodeFor:aClass
+ |cls mcls codeAspect msg|
+
+ cls := aClass theNonMetaclass.
+ mcls := aClass theMetaclass.
+
+ codeAspect := self codeAspect.
+ codeAspect == #newApplication
+ ifTrue:[ msg := 'Generate initial application code ?' ].
+
+ codeAspect == #newDialog
+ ifTrue:[ msg := 'Generate initial dialog code ?' ].
+
+ codeAspect == #newWebApplication
+ ifTrue:[ msg := 'Generate initial webApplication code ?' ].
+
+ (msg notNil and:[self confirm:(resources string:msg)])
+ ifTrue:[
+ CodeGeneratorTool createDocumentationMethodsFor:mcls.
+ (codeAspect == #newWebApplication) ifTrue:[
+ CodeGeneratorTool createWebApplicationCodeFor:cls.
+ ] ifFalse:[
+ CodeGeneratorTool createExamplesMethodFor:mcls.
+ CodeGeneratorTool createApplicationCodeFor:cls.
+ ].
+ ^ self.
+ ].
+
+ (codeAspect == #newTestCase) ifTrue:[
+ CodeGeneratorTool createDocumentationMethodsFor:mcls.
+ CodeGeneratorTool createTestCaseSampleCodeFor:cls.
+ ^ self.
+ ]
+!
+
checkCodeQuality:code
|col|
@@ -35734,18 +35808,7 @@
returnValue ifTrue:[
cls := rslt theNonMetaclass.
mcls := rslt theMetaclass.
- (((self codeAspect == #newApplication) and:[self confirm:'Generate initial application code ?'])
- or:[ (self codeAspect == #newDialog) and:[self confirm:'Generate initial dialog code ?']])
- ifTrue:[
- CodeGeneratorTool createDocumentationMethodsFor:mcls.
- CodeGeneratorTool createExamplesMethodFor:mcls.
- CodeGeneratorTool createApplicationCodeFor:cls.
- ].
-
- (self codeAspect == #newTestCase) ifTrue:[
- CodeGeneratorTool createDocumentationMethodsFor:mcls.
- CodeGeneratorTool createTestCaseSampleCodeFor:cls.
- ]
+ self askForInitialApplicationCodeFor:mcls.
].
]
]
@@ -36291,7 +36354,7 @@
!NewSystemBrowser class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Attic/NewSystemBrowser.st,v 1.784 2004-09-29 11:29:55 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Attic/NewSystemBrowser.st,v 1.785 2004-09-30 10:31:10 ca Exp $'
! !
NewSystemBrowser initialize!
--- a/Tools__NewSystemBrowser.st Wed Sep 29 13:29:55 2004 +0200
+++ b/Tools__NewSystemBrowser.st Thu Sep 30 12:31:18 2004 +0200
@@ -5399,6 +5399,11 @@
translateLabel: true
)
(MenuItem
+ label: 'WebApplication'
+ itemValue: classMenuNewWebApplication
+ translateLabel: true
+ )
+ (MenuItem
label: 'Dialog'
itemValue: classMenuNewDialog
translateLabel: true
@@ -5692,7 +5697,7 @@
translateLabel: true
)
(MenuItem
- enabled: hasApplicationClassSelectedHolder
+ enabled: hasApplicationOrHTTPServiceClassSelectedHolder
label: 'Application Code'
itemValue: classMenuGenerateApplicationCode
translateLabel: true
@@ -11270,6 +11275,13 @@
"Created: / 4.2.2000 / 22:02:53 / cg"
!
+hasApplicationOrHTTPServiceClassSelectedHolder
+ ^ [ self hasApplicationClassSelected
+ | self hasWebApplicationClassSelected]
+
+ "Created: / 4.2.2000 / 22:02:53 / cg"
+!
+
hasAtMostOneClassesSelected
^ self selectedClasses value size <= 1
!
@@ -12482,6 +12494,14 @@
!
+hasWebApplicationClassSelected
+ |selectedClasses|
+
+ selectedClasses := self selectedClasses value.
+ selectedClasses size == 0 ifTrue:[^ false].
+ ^ selectedClasses conform:[:each | each theNonMetaclass isSubclassOf:HTTPService].
+!
+
haskellModulePresent
^ HaskellModule notNil and:[HaskellParser notNil]
!
@@ -16813,7 +16833,14 @@
self
generateUndoableChangeOverSelectedClasses:'Generate ApplicationCode in %(singleClassNameOrNumberOfClasses)'
via:[:generator :eachClass |
- generator createApplicationCodeFor:eachClass theNonMetaclass
+ |cls|
+
+ cls := eachClass theNonMetaclass.
+ (cls isSubclassOf:HTTPService) ifTrue:[
+ generator createWebApplicationCodeFor:cls.
+ ] ifFalse:[
+ generator createApplicationCodeFor:cls
+ ]
]
!
@@ -17467,6 +17494,18 @@
self codeAspect:#newTestCase.
!
+classMenuNewWebApplication
+ "create a class-definition prototype for a web application"
+
+ self
+ classClassDefinitionTemplateFor:HTTPActionService
+ in:(self theSingleSelectedCategory ? 'WebApplications')
+ asNamespace:false
+ private:false.
+
+ self codeAspect:#newWebApplication.
+!
+
classMenuPrimitiveCode:aspect
"show the classes primitiveFunction in the codeView.
Also, set accept action to change it."
@@ -35531,6 +35570,41 @@
^ returnValue.
!
+askForInitialApplicationCodeFor:aClass
+ |cls mcls codeAspect msg|
+
+ cls := aClass theNonMetaclass.
+ mcls := aClass theMetaclass.
+
+ codeAspect := self codeAspect.
+ codeAspect == #newApplication
+ ifTrue:[ msg := 'Generate initial application code ?' ].
+
+ codeAspect == #newDialog
+ ifTrue:[ msg := 'Generate initial dialog code ?' ].
+
+ codeAspect == #newWebApplication
+ ifTrue:[ msg := 'Generate initial webApplication code ?' ].
+
+ (msg notNil and:[self confirm:(resources string:msg)])
+ ifTrue:[
+ CodeGeneratorTool createDocumentationMethodsFor:mcls.
+ (codeAspect == #newWebApplication) ifTrue:[
+ CodeGeneratorTool createWebApplicationCodeFor:cls.
+ ] ifFalse:[
+ CodeGeneratorTool createExamplesMethodFor:mcls.
+ CodeGeneratorTool createApplicationCodeFor:cls.
+ ].
+ ^ self.
+ ].
+
+ (codeAspect == #newTestCase) ifTrue:[
+ CodeGeneratorTool createDocumentationMethodsFor:mcls.
+ CodeGeneratorTool createTestCaseSampleCodeFor:cls.
+ ^ self.
+ ]
+!
+
checkCodeQuality:code
|col|
@@ -35734,18 +35808,7 @@
returnValue ifTrue:[
cls := rslt theNonMetaclass.
mcls := rslt theMetaclass.
- (((self codeAspect == #newApplication) and:[self confirm:'Generate initial application code ?'])
- or:[ (self codeAspect == #newDialog) and:[self confirm:'Generate initial dialog code ?']])
- ifTrue:[
- CodeGeneratorTool createDocumentationMethodsFor:mcls.
- CodeGeneratorTool createExamplesMethodFor:mcls.
- CodeGeneratorTool createApplicationCodeFor:cls.
- ].
-
- (self codeAspect == #newTestCase) ifTrue:[
- CodeGeneratorTool createDocumentationMethodsFor:mcls.
- CodeGeneratorTool createTestCaseSampleCodeFor:cls.
- ]
+ self askForInitialApplicationCodeFor:mcls.
].
]
]
@@ -36291,7 +36354,7 @@
!NewSystemBrowser class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.784 2004-09-29 11:29:55 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.785 2004-09-30 10:31:10 ca Exp $'
! !
NewSystemBrowser initialize!