[View] [Edit] [Lock] [References] [Attachments] [History] [Home] [Changes] [Search] [Help]
sample[VSE] HtmSt
The HtmSt framework implements a model of HTML elements. It was used looong time ago for generating static pages from VSE systems.
Code
"File: HtTools.st
__________________________________________________
@Alejandro Reimondo 12/18/96
This proyect sources are property of : Alejandro Reimondo
Its use is NOT legal without written rights.
__________________________________________________
"!
Object subclass: #HTMLSpecificationObject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''.
(Smalltalk at: #HTMLSpecificationObject) comment: '
Private,Development - Objects for reading HTML tags specification.
@1996, Alejandro F. Reimondo.-' !
HTMLSpecificationObject subclass: #HTMLSpecificationElement
instanceVariableNames:
' parent childs startToken className superclass conformanceLevel events comment tags endToken '
classVariableNames: ''
poolDictionaries: ''.
(Smalltalk at: #HTMLSpecificationElement) comment: '
Private,Development - Objects for modeling HTML element specification.' !
HTMLSpecificationObject subclass: #HTMLSpecificationReader
instanceVariableNames:
' title version author notifier debug sourceCode elements '
classVariableNames: ''
poolDictionaries: ''.
(Smalltalk at: #HTMLSpecificationReader) comment: '
Private,Development - Class for building Smalltalk code acording to specification file.' !
HTMLSpecificationObject subclass: #HTMLSpecificationSourceManager
instanceVariableNames:
' reader stream builtClasses builtMethods '
classVariableNames: ''
poolDictionaries: ''.
(Smalltalk at: #HTMLSpecificationSourceManager) comment: '
Private,Development - Source streamer & build tracker.' !
HTMLSpecificationObject subclass: #HTMLSpecificationTag
instanceVariableNames:
' property selector type alternatives comment parent '
classVariableNames: ''
poolDictionaries: ''.
(Smalltalk at: #HTMLSpecificationTag) comment: '
Private,Development - Objects for modeling HTML tags specification.' !
!HTMLSpecificationObject methods !
classReaderMethodsTag
" Private - Returns the selector to be used for signaling methods of a class in a class reader (fileIn).
This selector is platformDependent."
#platformDependent.
^ 'methods' "For Digitalk Smalltalks"
" 'methodsFor' For Dolphin Smalltalk"!
generateClassMethod: header
for: aClass
comment: aComment
implementation: implementation
onto: stream
" Private - Place class heading & method source code chunk onto stream. "
^self
generateMethod: header
for: aClass,' class'
comment: aComment
implementation: implementation
onto: stream!
generateMethod: header
comment: aComment
implementation: implementation
onto: stream
" Private - Place method source code chunk onto stream. "
stream
cr;nextPutAll: header;
cr;nextPutAll: ' " Generated '
,((aComment asStream nextLine includes: $-) ifTrue: [', '] ifFalse: ['- '])
,aComment,' "';
cr;nextChunkPut: ' ',implementation!
generateMethod: selector
for: aClass
comment: aComment
implementation: implementation
onto: sourceStream
" Private - Place class heading & method source code chunk onto stream. "
self
instanceHeader: aClass on: sourceStream;
generateMethod: selector
comment: aComment
implementation: implementation
onto: sourceStream.
sourceStream nextChunkPut: String new.
sourceStream methodBuilt: (Association key: aClass value: selector).!
instanceHeader: aClassName on: stream
" Private - Place instance header chunk onto stream. "
stream
cr;cr;
nextPut: $!!;space;
nextPutAll: aClassName; space;
nextPutAll: self classReaderMethodsTag;
nextPut: $!!! !
!HTMLSpecificationElement methods !
addTag: aTag
"Add a Tag to the receiver. "
self tags add: aTag.
aTag parent: self.!
children
"Returns the receiver's chils."
^self childs!
childs
"Returns the instance var of the receiver
for external manipulation"
childs isNil ifTrue: [ self initializeChilds ].
^childs!
className
"Returns the instance var of the receiver
for external manipulation"
^className!
className: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
className := anObject!
comment
"Returns the instance var of the receiver
for external manipulation"
^comment!
comment: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
comment := anObject!
conformanceLevel
"Returns the instance var of the receiver
for external manipulation"
^conformanceLevel!
conformanceLevel: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
conformanceLevel := anObject!
endToken
"Returns the instance var of the receiver
for external manipulation"
^endToken!
endToken: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
endToken := anObject!
events
"Returns the instance var of the receiver
for external manipulation"
^events!
events: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
events := anObject!
generateAditionalMethodsIn: stream
" Private - Built Smalltalk source code for aditional methods. "
self
generateUrlSelectorsMethodIn: stream;
generateEventsMethodIn: stream;
yourself.!
generateClassIn: stream
" Private - Built Smalltalk source code for class specification. "
| realClass |
self className isNil ifTrue: [
^self error: 'A class name must be provided for tag ',self startToken asString
].
self superclass isNil ifTrue: [ self superclass: #HTMLObject ].
realClass := Smalltalk at: className ifAbsent: [].
realClass isNil ifTrue: [ " if not present in this image, the class must be created. "
stream
nextChunkPut: self superclass asString
,' subclass: #',self className asString
,'\ instanceVariableNames: String new' withCrs
,'\ classVariableNames: String new' withCrs
,'\ poolDictionaries: String new.' withCrs;
classBuilt: className;
yourself
].
(self comment notNil
and: [ (realClass respondsTo: #comment)
and: [ realClass respondsTo: #comment:]])
ifTrue: [ stream nextChunkPut: self className,' comment: ',self generatedComment printString ].
self conformanceLevel ~= 0
ifTrue: [
self
generateClassMethod: #conformanceLevel
for: self className
comment: 'Returns the conformance level for this element instances.'
implementation: '^',self conformanceLevel asString
onto: stream;
yourself
].!
generateCodeIn: stream
" Built Smalltalk source code for the receiver onto stream in Chunk format. "
self
generateClassIn: stream;
generateTokenMethodsIn: stream;
generateMethodsIn: stream;
generateAditionalMethodsIn: stream;
yourself.
self children do: [:each| each generateCodeIn: stream ].!
generatedComment
" Private - Returns the comment with GENERATED tag."
^'Generated - ',self comment!
generateEventsMethodIn: stream
" Private - Built supportedEvents method if needed... "
self events size > 0 ifTrue: [
self
generateClassMethod: #supportedEvents
for: self className
comment: 'Private - Must return a collection with the events supported by receiver''s instances.'withCrs
implementation: '^super supportedEvents, #',self events asArray printString
onto: stream
].!
generateMethodsIn: stream
" Private - Built Smalltalk source code for property methods. "
self tags do: [:aTag| aTag generateCodeIn: stream for: className ].!
generateTokenMethodsIn: stream
" Private - Built Smalltalk source code for token specification. "
(self startToken notNil and: [(self startToken includes: $#) not])
ifTrue: [
self
generateClassMethod: #token
for: self className
comment: 'Private - The receiver must return the token to write receiver''s instances.'
implementation: '^',self startToken printString
onto: stream
].
"Build start-stop tag methods if needed"
self endToken = self startToken
ifFalse: [
self endToken size = 0 ifTrue: [ "this element does not need stop tag"
self
generateMethod: #stopTag
for: self className
comment: 'Private - The receiver don''t need the stop token to be filled out for ending a block write.'
implementation: '^nil'
onto: stream
]
ifFalse: [
self
generateMethod: #stopTag
for: self className
comment: 'Private - The receiver has a diferent ending tag.'
implementation: '^',self endToken
onto: stream
].
].!
generateUrlSelectorsMethodIn: stream
" Private - Built urlSelectors method if needed... "
| urlSelectors |
urlSelectors := self tags select: [:each| each hasAnURL ].
urlSelectors notEmpty ifTrue: [
urlSelectors := (urlSelectors collect: [:tag| tag selector ]) asSortedCollection.
self
generateClassMethod: #urlSelectors
for: self className
comment: 'Private - Must return a collection with the get & set selectors to be used when relocating properties.\ This method can be completed by subclasses.'withCrs
implementation: '^super urlSelectors, #',urlSelectors asArray printString
onto: stream
].!
initializeChilds
" Private - Initialize the receiver's childs holder. "
childs := OrderedCollection new.!
initializeTags
" Private - Initialize the receiver's tags holder. "
tags := OrderedCollection new.!
parent
"Returns the instance var of the receiver
for external manipulation"
^parent!
parent: anElement
"Sets the instance var of the receiver & update parent childs."
parent notNil ifTrue: [
parent childs remove: self ifAbsent: [].
].
parent := anElement.
anElement notNil ifTrue: [
anElement childs add: self
].!
startToken
"Returns the instance var of the receiver
for external manipulation"
^startToken!
startToken: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
startToken := anObject!
superclass
"Returns the instance var of the receiver
for external manipulation"
^superclass!
superclass: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
superclass := anObject!
tags
"Returns the instance var of the receiver
for external manipulation"
tags isNil ifTrue: [ self initializeTags ].
^tags!
token
"Returns the token of the receiver"
^self startToken!
validateHierarchyNotifying: aNotifier
" Validate receiver's hierarchy & tag methods notifying aNotifier. "
| tag current |
"validate tags for method building (consider implementation hierarchy for not implementing redundant methods)."
current := self parent.
current notNil ifTrue: [
self tags copy do: [:each|
[current notNil and: [
tag := current tags detect: [:one| one = each ] ifNone: [].
tag isNil ]] whileTrue: [ current := current parent ].
tag notNil ifTrue: [
aNotifier notify: self className asString,'>>',each selector
,' implemented by ',current className.
self tags remove: each ifAbsent: [].
].
].
].
self children do: [:child|
child validateHierarchyNotifying: aNotifier
].!
validateNotifying: aNotifier
" Validate the receiver notifying aNotifier if a anormal condition is found. "
self comment size = 0 ifTrue: [
aNotifier notify: 'Mising comment for ',self startToken
].
self tags do: [:tag| tag validateNotifying: aNotifier ].
self children do: [:child|
child validateNotifying: aNotifier
].! !
!HTMLSpecificationReader class methods !
buildGeneratedSLL
" Private , Packing - Build a Smalltalk Library with generated methods only.
HTMLSpecificationReader buildGeneratedSLL
"
| builder methods classes |
builder := (Smalltalk at: #SmalltalkLibraryBuilder
ifAbsent: [ self error: 'SmalltalkLibraryBuilder not present in this image.' ]) new.
builder
fileName: 'HtmSt2.SLL';
windowFeedback;
sourceSeparate;
includeSource: true;
yourself.
methods := self generatedMethods.
classes := methods asSet collect: [:mth| mth classField instanceClass ].
(self generatedClassesIn: classes)
do: [:aClass| builder addClass: aClass includeMethods: false ].
methods do: [:each| builder add: each ].
builder writeFile.!
categoriesOfMethod: aMethod
" Private , Development - Returns the categories of aCompiledMethod."
| stream categories token skipBlanks |
stream := aMethod source asStream.
skipBlanks := [
[stream atEnd not and: [stream peek isSeparator]]
whileTrue: [ stream next ]
].
categories := Set new.
[ skipBlanks value.
(stream peek = $") not and: [
token := stream nextWord. token notEmpty
and: [ stream peek = $: or: [token first isLetter not]]]
] whileTrue: [ stream next;nextWord ].
skipBlanks value.
stream peek = $" ifFalse: [
"method does not have a comment."
^categories
].
stream next.
stream := (stream upTo: $") asStream.
(stream contents includes: $-) ifFalse: [
"method does not have a categorized comment."
^categories
].
[ categories add: stream nextWord.
skipBlanks value.
stream peek = $, ] whileTrue: [ stream next ].
^categories
"
HTMLSpecificationReader categoriesOfMethod:
(HTMLSpecificationReader class compiledMethodAt: #categoriesOf:)
"!
confirm: text
" Private - Prompt the user to answer yes/no to text query.
Must return true or false. "
^MessageBox confirm: text!
fileIn
"Files in contents of the default specification file.
HTMLSpecificationReader fileIn.
"
^self fileIn: self pathName!
fileIn: pathName
"Files in contents of file pathName."
^self new fileIn: pathName!
fileOutGeneratedCode
" Private , Packing - Build a Smalltalk install file with generated classes and methods.
HTMLSpecificationReader fileOutGeneratedCode
"
| file methods classes toFileOut fileOut stream |
file := File newFile: 'HtmSt2.St'.
methods := self generatedMethods.
classes := methods asSet collect: [:mth| mth classField instanceClass ].
classes := self generatedClassesIn: classes.
classes := self sortForFileIn: classes asArray.
classes do: [:aClass|
file cr. aClass fileOutOn: file.
file nextChunkPut: String new.
].
fileOut := [:class|
toFileOut := methods select: [:one| one classField == class ].
toFileOut notEmpty ifTrue: [
file setToEnd;cr;cr;nextPut: $!!;
nextPutAll: ' ',class name , ' methods !!'.
toFileOut do: [:mth|
stream := ReadStream on: mth sourceString.
stream atEnd ifFalse: [
file cr.
[stream atEnd] whileFalse: [ file nextPutAll: (stream upTo: $!!) ].
file nextPut: $!!
].
].
file nextPutAll: ' !!'.
]
].
classes do: [:each|
fileOut
value: each class;
value: each
].
file close.!
generatedClassesIn: classes
" Private - Returns aColection with the classes that has been generated durend code generation."
^classes select: [:each| self isGenerated: each ]!
generatedMethods
" Private - Returns aColection with the generated methods in HTMLElement."
^self generatedMethodsIn: HTMLElement
" HTMLSpecificationReader generatedMethods "!
generatedMethodsIn: aClass
" Private - Returns aColection with the generated methods in aClass."
^self methodsWithCategory: 'Generated' in: aClass!
isGenerated: aClass
" Private - Returns true if aClass has been generated."
^(self nonGeneratedMethodsIn: aClass) isEmpty!
methodsWithCategory: aCategory in: aClass
" Private - Returns aColection with the methods with category aCategory
in class aClass and it's subclasses."
| result method |
result := Set new.
aClass withAllSubclasses do: [:each|
each selectors do: [:selector|
method := each compiledMethodAt: selector.
((self categoriesOfMethod: method) includes: aCategory)
ifTrue: [ result add: method ].
].
each class selectors do: [:selector|
method := each class compiledMethodAt: selector.
((self categoriesOfMethod: method) includes: aCategory)
ifTrue: [ result add: method ].
]
].
^result!
nonGeneratedMethodsIn: aClass
" Private - Returns all the non generated methods in aClass. "
| all generated |
all := OrderedCollection new.
all
addAll: (aClass selectors
collect: [:selector| aClass compiledMethodAt: selector ]);
addAll: (aClass class selectors
collect: [:selector| aClass class compiledMethodAt: selector ])
yourself.
generated := self generatedMethodsIn: aClass.
^all asArray reject: [:one| generated includes: one ]!
pathName
" Private - return the pathName of specification file. "
^'HTMLSpec.Txt'!
recompileAll
" Private , Checkin - Recompile all HTMLObject methods and it's subclasses methods.
HTMLSpecificationReader recompileAll
"
HTMLObject
compileAll;
compileAllSubclasses!
removeGeneratedClasses
" Private - Removes all the HTMLObject generated classes. "
| classes |
classes := self generatedClassesIn: self rootClass withAllSubclasses.
classes := self sortForFileIn: classes.
classes reverseDo: [:each| each removeFromSystem ]!
removeGeneratedCode
" Private - Removes all the generated methods & classes in HTMLElement
and it's subclasses when reading Specifications.
HTMLSpecificationReader removeGeneratedCode
"
(self confirm: 'Remove all generated source code in last Specification fileIn ?')
ifFalse: [ ^false ].
self
removeGeneratedMethods;
removeGeneratedClasses;
removeGeneratedComments;
yourself.
^true!
removeGeneratedComments
" Private - Removes all the generated comments in HTMLElement
and it's subclasses when reading Specifications. "
self rootClass withAllSubclasses do: [:each|
((each respondsTo: #comment) and: [each comment notNil])
ifTrue: [
each comment asStream nextWord = 'Generated'
ifTrue: [ each comment: nil ]
]
].!
removeGeneratedMethods
" Private - Removes all the generated methods in HTMLElement
and it's subclasses when reading Specifications."
self removeMethods: self generatedMethods
!
removeMethods: aMethodsCollection
" Private - Removes methods in aMethodsCollection."
aMethodsCollection do: [:method|
method classField removeSelector: method selector
].
!
rootClass
" Private - Returns the Root class for HTMLObjects."
^HTMLObject !
sortForFileIn: aCollection
" Private , Packing - Sort aCollection of classes for correct fileIn.
HTMLSpecificationReader sortForFileIn:
(#(HTMLSample HTMLBody Object HTMLObject ) collect: [:each| Smalltalk at: each])
"
| result conflictive allSuperclasses |
result := OrderedCollection new.
aCollection do: [:each|
conflictive := result
detect: [:one| one allSuperclasses includes: each ]
ifNone: [].
conflictive isNil
ifTrue: [ result add: each ]
ifFalse: [ result add: each before: conflictive ]
].
^result asArray!
usedClasses
" Private - Return the classes used in hand-written code.
HTMLSpecificationReader usedClasses
"
| classes method collect |
collect := [:aClass|
aClass selectors do: [:selector|
method := aClass compiledMethodAt: selector.
method do: [:literal|
(literal isAssociation and: [ literal value isClass ])
ifTrue: [ classes add: literal value ]
].
]
].
classes := Set new.
self rootClass withAllSubclasses do: [:cls|
collect
value: cls;
value: cls class;
yourself
].
^classes! !
!HTMLSpecificationReader methods !
author
"Returns the instance var of the receiver
for external manipulation"
^author!
author: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
author := anObject!
confirm: text
" Private - Prompt the user to answer yes/no to text query.
Must return true or false. "
^self class confirm: text!
debug
"Returns the instance var of the receiver
for external manipulation"
debug isNil ifTrue: [ debug := false ].
^debug!
debug: aStringOrABoolean
"Sets the instance var of the receiver
with aStringOrABoolean"
aStringOrABoolean isString ifTrue: [
^self debug: (#('yes' 'true' 'y' 't') includes: aStringOrABoolean asLowerCase)
].
debug := aStringOrABoolean!
dumpHiearchy: element level: level
" Private - Dump elements hiearchy. "
| line |
line := String new: level * 3.
line atAllPut: $ .
self notify: line,element className,' <',element startToken asString,'>'.
element childs do: [:each| self dumpHiearchy: each level: level + 1 ].!
elements
"Returns the instance var of the receiver
for external manipulation"
elements isNil ifTrue: [ self initializeElements ].
^elements!
endTagCharacter
" Private - Returns the character used for ending element tag specification."
^$>!
fileIn: pathName
"FileIn stream contents..."
| file |
pathName isStream
ifTrue: [ self fileInFrom: pathName ]
ifFalse: [
CursorManager execute
changeFor: [
file := File pathNameReadOnly: pathName.
self fileInFrom: file.
file close.
].
].!
fileInFrom: stream
" Private - FileIn stream contents. "
self loadHeaderFrom: stream.
[stream atEnd] whileFalse: [ self loadSpecificationFrom: stream ].
self validateHiearchy.
self elements do: [:each| each validateNotifying: self. ].
self elements do: [:each| self generateCodeFor: each ].
self fileInSourceCode.!
fileInSourceCode
" Private - FileIn Smalltalk source contained in the sourceCode. "
| fileStream fileName htmlSt2 |
(self confirm: 'File in generated source code ?')
ifFalse: [ ^self sourceCode edit ].
htmlSt2 := 'HTMLSt2'.
File remove: htmlSt2,'.Bak' ifAbsent: [].
fileName := htmlSt2,'.St'.
(File exists: fileName) ifTrue: [
File rename: fileName to: htmlSt2,'.Bak'
].
self sourceCode saveAs: fileName.
fileStream := File pathNameReadOnly: fileName.
((Smalltalk includesKey: #StReader)
and: [self confirm: 'Use StReader for fileIn generated source code ?'])
ifTrue: [
"Object Style St Reader is present. Use it for better fileIn..."
(Smalltalk at: #StReader) fileIn: fileStream
]
ifFalse: [ fileStream fileIn ].
fileStream close.
(self confirm: 'Build Bindable library (',htmlSt2,'.SLL) ?')
ifTrue: [ self sourceCode buildLibrary: htmlSt2,'.SLL' ].!
generateCodeFor: element
" Private - Generate Smalltalk code for current specification element. "
element generateCodeIn: self sourceCode.!
initializeElements
" Private - Initializes the receiver's elements collection. "
elements := OrderedCollection new.!
initializeNotifier
" Private - Open notifier window. "
notifier := TextWindow
windowLabeled: self title
frame: (0@0 extent: Display extent // (2 @ 1)).
notifier nextPutAll: self title.
self version notNil ifTrue: [
self notify: 'Version: ',self version asString
].
self author notNil ifTrue: [
self notify: 'Author: ',self version asString
].
notifier cr.
^notifier!
initializeSourceCode
" Private - Initializes the receiver's source code stream. "
sourceCode := HTMLSpecificationSourceManager for: self!
loadElementFrom: stream
" Private - Load an element specification contents from stream."
| element aTag |
stream next = self startTagCharacter ifFalse: [ self error: 'Invalid start element tag.'.^nil ].
element := HTMLSpecificationElement new.
element startToken: (stream upTo: self endTagCharacter) trimBlanks asUpperCase.
element startToken isEmpty ifTrue: [ element startToken: nil ].
element className: (self nextClassFrom: stream).
element superclass: (self nextClassFrom: stream).
element conformanceLevel: (self nextFieldFrom: stream) asInteger.
element events: (self nextAlternativesFrom: stream).
element comment: (stream nextLine collect: [:c| c = $' ifTrue: [$"] ifFalse: [c]]) withCrs.
self notify: (String with: self startTagCharacter)
, element startToken asString
, (String with: self endTagCharacter)
, element className asString,','
, element superclass asString.
[ self skipComments: stream.
stream countBlanks > 0 ] whileTrue: [
aTag := self nextTagFrom: stream nextLine asStream.
aTag notNil ifTrue: [ element addTag: aTag ].
].
stream next = self startTagCharacter ifFalse: [ self error: 'Invalid stop element tag.'.^nil ].
stream next = $/ ifFalse: [ self error: 'Invalid stop element tag. "/" spected.'.^nil ].
element endToken: (stream upTo: self endTagCharacter) trimBlanks asUpperCase.
element endToken isEmpty ifTrue: [ element endToken: nil ].
self notify: (String with: self startTagCharacter with: $/)
, element endToken asString
, (String with: self endTagCharacter).
^element!
loadHeaderFrom: stream
" Private - Load specification header.
Header must be lines with a single argument message to be sent to the receiver.
An Empty line ends with the header. "
| line selector argument lineNumber |
lineNumber := 1.
[stream atEnd] whileFalse: [
line := stream nextLine trimBlanks.
line isEmpty ifTrue: [ ^lineNumber ].
line first = $; "comment lines will be skipped"
ifFalse: [
(line includes: $:) ifFalse: [ ^self error: 'Header malformed. Line #',lineNumber asString ].
line := line asStream.
selector := ((line upTo: $:),':') asSymbol.
(self respondsTo: selector) ifFalse: [ ^self error: 'Invalid selector in header. Line #',lineNumber asString ].
argument := (line upTo: nil) trimBlanks.
self perform: selector with: argument.
].
lineNumber := lineNumber + 1.
].
^lineNumber!
loadSpecificationFrom: stream
" Private - Load specification contents.
Specification syntax:
stream will be scanned up to end.
empty lines will be ignored.
; at start indicates comment.
<startToken>className,[superClass],[conformanceLevel],[comment withCrs]
propertyName[#msgSelector],[Type[(alternatives)]],[comments withCrs]
</[stopToken]>
"
| token element |
self skipComments: stream.
token := stream peek.
token isSeparator "skip blanks"
ifTrue: [ stream next ]
ifFalse: [ "must be a tag start"
token = self startTagCharacter
ifFalse: [ self error: 'Start tag character spected.' ]
ifTrue: [
element := self loadElementFrom: stream.
element notNil ifTrue: [ self elements add: element].
].
].!
nextAlternativesFrom: stream
" Private - Get a list of alternatives from stream."
| result |
result := OrderedCollection new.
stream atEnd ifTrue: [ ^nil ].
stream countBlanks.
stream peek = $( ifFalse: [ ^nil ].
[stream atEnd not and: [(stream peek = $)) not]]
whileTrue: [
stream peek isLetter ifFalse: [ stream next;countBlanks ].
stream atEnd ifFalse: [ result add: stream nextWord ].
].
stream peek = $) ifTrue: [ stream next ].
^result!
nextClassFrom: stream
" Private - Returns the next class from stream or nil if atEnd. "
| className |
className := self nextFieldFrom: stream.
className size = 0 ifTrue: [ ^nil ].
(className size > 4 and: ['HTML' = (className copyFrom: 1 to: 4)])
ifTrue: [ ^className asSymbol ].
^('HTML',className) asSymbol
!
nextFieldFrom: stream
" Private - Returns the next field from stream or nil if atEnd. "
stream countBlanks.
stream atEnd ifTrue: [ ^nil ].
^(stream upTo: $,) trimBlanks!
nextTagFrom: stream
" Private - Returns the next HTML Tag specification. "
| tag aStream alternative |
stream atEnd ifTrue: [ ^nil ].
tag := HTMLSpecificationTag new.
tag property: (self nextFieldFrom: stream).
(tag property includes: $#)
ifTrue: [
aStream := ReadStream on: tag property.
tag property: (aStream upTo: $#).
tag selector: (aStream upTo: nil) trimBlanks.
].
tag selector: (tag selector size > 0
ifTrue: [ tag selector ] ifFalse: [ tag property ]) asSymbol.
tag type: (self nextFieldFrom: stream).
(tag type includes: $()
ifTrue: [
aStream := ReadStream on: tag type.
tag type: (aStream upTo: $() trimBlanks.
[aStream atEnd] whileFalse: [
alternative := (aStream upTo: $|) trimBlanks.
(alternative notEmpty and: [alternative last = $)])
ifTrue: [ alternative := alternative copyFrom: 1 to: alternative size - 1 ].
alternative isEmpty ifFalse: [
alternative := alternative asLowerCase.
alternative first isDigit ifTrue: [ alternative := alternative asNumber ].
tag alternatives add: alternative
].
]
].
tag comment: (stream nextLine collect: [:c| c = $" ifTrue: [$'] ifFalse: [c]]) withCrs.
self notify: ' ', tag property asString
,(tag selector asString = tag property ifFalse: [ '#',tag selector asString ] ifTrue: [String new])
,',',tag type asString
,(tag alternatives notNil ifTrue: [ tag alternatives asArray asString ] ifFalse: [String new])
.
^tag!
notifier
"Returns the instance var of the receiver
for external manipulation"
notifier isNil ifTrue: [ self initializeNotifier ].
^notifier!
notifier: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
notifier := anObject!
notify: aString
" Private - Notify aString into receiver's notifier device. "
self debug ifTrue: [
self notifier cr;nextPutAll: aString.
].!
skipComments: stream
" Private - Skip comments in stream. "
[ stream peek = $; ] whileTrue: [ stream nextLine ].!
sourceCode
"Returns the instance var of the receiver
for external manipulation"
sourceCode isNil ifTrue: [ self initializeSourceCode ].
^sourceCode!
startTagCharacter
" Private - Returns the character used for starting element tag specification."
^$<!
title
"Returns the instance var of the receiver
for external manipulation"
title isNil ifTrue: [ ^'Scanning HTML Specification.' ].
^title!
title: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
title := anObject!
validateHiearchy
" Private - Validates elements hiearchy and extract root elements. "
| parent |
elements copy do: [:element|
(element parent isNil and: [element superclass notNil])
ifTrue: [
parent := elements detect: [:one| one className = element superclass ] ifNone: [].
parent notNil ifTrue: [ element parent: parent ].
].
].
"Select only root elements"
elements := elements select: [:one| one parent isNil ].
"Dump element hierarchy."
self notify: String new;notify: 'Element hiearchy.'.
elements do: [:each |
each validateHierarchyNotifying: self.
self dumpHiearchy: each level: 1
].!
version
"Returns the instance var of the receiver
for external manipulation"
^version!
version: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
version := anObject! !
!HTMLSpecificationSourceManager class methods !
for: aReader
"Returns an nstance of the receiver working for aReader."
^self new
reader: aReader;
yourself! !
!HTMLSpecificationSourceManager methods !
buildLibrary: fileName
" Code generation, Library creation, Packing - Build a Smalltalk Library with generated methods & classes. "
| builder methods classes |
builder := (Smalltalk at: #SmalltalkLibraryBuilder
ifAbsent: [ self error: 'SmalltalkLibraryBuilder not present in this image.' ]) new.
builder
fileName: fileName;
windowFeedback;
sourceSeparate;
includeSource: true;
yourself.
self generatedClasses
do: [:aClass| builder addClass: aClass includeMethods: false ].
self generatedMethods
do: [:method| builder add: method ].
builder writeFile.!
builtClasses
" Private, Code generation - Returns the instance var of the receiver
for external manipulation"
builtClasses isNil ifTrue: [ self initializeBuiltClasses ].
^builtClasses!
builtMethods
" Private, Code generation - Returns the instance var of the receiver
for external manipulation"
builtMethods isNil ifTrue: [ self initializeBuiltMethods ].
^builtMethods!
classBuilt: aClassName
" Code generation - A new class has been generated and will be called aClassName when created."
self builtClasses add: aClassName.!
cr
"Delegate streaming behaviour to my stream."
^self stream cr!
edit
"Edit receiver's contents."
^self stream contents edit!
generatedClasses
" Private, Library creation - Returns the created classes."
| result key |
result := Set new.
self builtClasses do: [:each|
key := (each upTo: $ ) asSymbol.
(Smalltalk includesKey: key)
ifTrue: [ result add: (Smalltalk at: key) ].
].
^result!
generatedMethods
" Private, Library creation - Returns the created methods."
| result trace aClass selector |
result := OrderedCollection new: self builtMethods size.
self builtMethods do: [:assoc|
trace := assoc key asArrayOfSubstrings.
aClass := nil.
trace do: [:one|
aClass isNil
ifTrue: [ aClass := Smalltalk at: one asSymbol ]
ifFalse: [ aClass := aClass perform: one asSymbol ]
].
selector := assoc value upTo: $ .
selector isString
ifTrue: [
selector at: 1 put: selector first asLowerCase.
selector := selector asSymbol.
].
result add: (aClass compiledMethodAt: selector)
].
^result!
initializeBuiltClasses
" Private - Initialize the receiver's built classes container."
builtClasses := Set new.!
initializeBuiltMethods
" Private - Initialize the receiver's built methods container."
builtMethods := OrderedCollection new.!
initializeStream
" Private - Initialize the receiver's stream."
stream := ReadWriteStream on: String new.!
methodBuilt: anAssociation
"A new method has been generated and will be created as a method in class anAssociation key and selector anAssociation value."
self builtMethods add: anAssociation.!
nextChunkPut: aStream
"Delegate streaming behaviour to my stream."
^self stream nextChunkPut: aStream!
nextPut: aCharacter
"Delegate streaming behaviour to my stream."
^self stream nextPut: aCharacter!
nextPutAll: aStream
"Delegate streaming behaviour to my stream."
^self stream nextPutAll: aStream!
reader
"Returns the instance var of the receiver
for external manipulation"
^reader!
reader: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
reader := anObject!
saveAs: fileName
" Code generation - Save receiver's contents to a file.
Stream lines are Cr-Lf terminated."
| fileStream |
fileStream := File newFile: fileName.
self stream reset.
[self stream atEnd] whileFalse: [
fileStream nextPutAll: self stream nextLine;cr
].
fileStream close.!
space
"Delegate streaming behaviour to my stream."
^self stream space!
stream
"Returns the instance var of the receiver
for external manipulation"
stream isNil ifTrue: [ self initializeStream ].
^stream! !
!HTMLSpecificationTag methods !
= aTag
" Returns true if implementation of the receiver is equivalent to implementation of aTag. "
(aTag isKindOf: self species) ifFalse: [ ^false ].
^self selector = aTag selector
and: [ self property = aTag property
and: [ self type = aTag type
and: [ self alternatives = aTag alternatives
"comment is not important in this case..."
]]]!
alternatives
"Returns the instance var of the receiver
for external manipulation"
alternatives isNil ifTrue: [ self initializeAlternatives ].
^alternatives!
comment
"Returns the instance var of the receiver
for external manipulation"
^comment!
comment: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
comment := anObject!
generateAlternativeMethodsIn: stream for: aClassName
" Private - Built alternative comodity methods for this tag. "
self alternatives do: [:each|
each isString
ifTrue: [
self
generateMethod: each
for: aClassName
comment: 'Sets the ',self property,' property to ',each,'.'
implementation: '^self ',self selector,': ',each printString
onto: stream.
]
].!
generateBooleanCodeIn: stream for: aClassName
" Private - Built Smalltalk source code for boolean properties. "
| symbol |
symbol := self selector asString.
self
generateMethod: symbol
for: aClassName
comment: 'Enable the ',self property,' property.'
,(self comment size > 0 ifTrue: ['\ 'withCrs,self comment] ifFalse: [String new ])
implementation: '^self enableProperty: ',self property printString
onto: stream;
generateMethod: symbol,': aBoolean'
for: aClassName
comment: 'Sets the ',self property,' property to aBoolean.'
,(self comment size > 0 ifTrue: ['\ 'withCrs,self comment] ifFalse: [String new ])
implementation: '^self propertyAt: ',self property printString,' put: aBoolean'
onto: stream
yourself.
symbol size > 2
ifTrue: [
symbol := (symbol asString copyFrom: 1 to: 2) asLowerCase = 'no'
ifTrue: [ symbol copyFrom: 3 to: symbol size ]
ifFalse: [
symbol at: 1 put: symbol first asUpperCase.
'no',symbol
].
symbol at: 1 put: symbol first asLowerCase.
self
generateMethod: symbol
for: aClassName
comment: 'Disable the ',self property,' property.'
,(self comment size > 0 ifTrue: ['\ 'withCrs,self comment] ifFalse: [String new ])
implementation: '^self disableProperty: ',self property printString
onto: stream;
yourself.
].!
generateCodeIn: stream for: aClassName
" Private - Built Smalltalk source code for this tag. "
| validateSelector source expression |
self type = 'Boolean'
ifTrue: [ "Boolean properties have special protocoll."
^self generateBooleanCodeIn: stream for: aClassName
].
"buit comodity methods for alternatives...
(done here for secure overwrite of methods...)"
self
generateAlternativeMethodsIn: stream
for: aClassName.
"Normal get method."
self
generateMethod: self selector
for: aClassName
comment: 'Return the ',self property,' property (or nil).'
,(self comment size > 0 ifTrue: ['\ 'withCrs,self comment] ifFalse: [String new ])
implementation: '^self propertyAt: ',self property printString
onto: stream.
self type size > 0
ifTrue: [
validateSelector := ('validate',self type,':') asSymbol.
(HTMLElement includesSelector: validateSelector)
ifFalse: [
"This method MUST be implemented to use type as valid type
using the same pattern as validate...: methods in this class."
^self error: ' Method HTMLElement>>',validateSelector,' missing.'
].
].
source := String new.
expression := validateSelector notNil
ifTrue: [ "Validation needed for aValue for defined types."
self alternatives size > 0
ifTrue: [
self
generateValidationCodeFor: validateSelector
in: stream
for: aClassName.
].
'(self ',validateSelector,' aValue)'
]
ifFalse: [ "no type, can be of an enumerated type or no validated"
self alternatives size > 0
ifTrue: [ "enumerated types must be validated"
source := 'aValue notNil ifTrue: [\ (#'withCrs
,self alternatives asArray printString,' includes: aValue)'
,'\ ifFalse: [ self error: ''Invalid value for this property.'' ].\ ].\ 'withCrs.
].
'aValue'
].
source := source, 'self propertyAt: ',self property printString,' put: ',expression.
self
generateMethod: self selector,': aValue'
for: aClassName
comment: 'Sets the ',self property,' property with aValue.'
,(self comment size > 0 ifTrue: ['\ 'withCrs,self comment] ifFalse: [String new ])
implementation: source
onto: stream.
!
generateValidationCodeFor: validateSelector in: stream for: aClassName
" Private - Built Smalltalk source code for validating a set value. "
| validSelector |
validSelector := ('valid',self type,'s') asSymbol.
(HTMLElement class includesSelector: validSelector)
ifFalse: [
^self error: 'Message #',validSelector,' MUST be implemented as a HTMLElement class method.'
].
self
generateClassMethod: validSelector
for: aClassName
comment: 'Private - Must return valid ',self type,' values for receiver''s instances...'
implementation: '^#',self alternatives asArray printString
onto: stream.!
hasAnURL
" Returns true if the receiver's type determines an URL"
^self type = 'URL'!
initializeAlternatives
" Private - Initialize the receiver's alternatives holder. "
alternatives := OrderedCollection new.!
parent
"Returns the instance var of the receiver
for external manipulation"
^parent!
parent: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
parent := anObject!
property
"Returns the instance var of the receiver
for external manipulation"
^property!
property: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
property := anObject!
selector
"Returns the instance var of the receiver
for external manipulation"
^selector!
selector: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
selector := anObject!
type
"Returns the instance var of the receiver
for external manipulation"
^type!
type: anObject
"Sets the instance var of the receiver
with anObject. (No checking is done)"
type := anObject!
validateNotifying: aNotifier
" Validate the receiver notifying aNotifier if a anormal condition is found. "
self comment size = 0 ifTrue: [
aNotifier notify: ' Mising comment for tag ',self property,' in ',self parent token asString
].! !