VL-Html

VLHtmlReport

Object subclass: #VLHtmlReport
	instanceVariableNames: 'stream '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
Cette classe permet de générer des fichiers html 
contenant la définition de classes.
[accessing]
categorie: uneCategorie
	
| doc n1 |
	[  
	doc := VLTagHtml nom: 'html'.
	doc contenu: (VLTagCollection with: (VLTagHtml nom: 'head')
		with: (VLTagHtml nom: 'body')).
	doc head contenu: ((VLContentTag with: uneCategorie asString) tag: 'title').
	doc body bgcolor: '"c0c0c0"'.
	doc body contenu: (n1 := (VLTagCollection with: 
		((VLContentTag with: uneCategorie asString) tag: 'H1'))).

	(Smalltalk organization superclassOrder: uneCategorie) do: 
		[:aClass | 
			n1 add: ((VLContentTag with: aClass name) tag: 'H2').
			n1 add: (self htmlClasse: aClass).
			aClass class nonTrivial ifTrue: [ n1 add: (self htmlClasse: aClass class) ]].
	doc printOn: stream.
	] valueNowOrOnUnwindDo: [
		stream close ]
close
	
stream close
htmlClasse: aClass
	
| n |
	n := VLTagCollection with:
		(((VLContentTag with: aClass definition) tag: 'b') tag: 'pre')
		with:
		(((VLContentTag with: aClass comment) tag: 'i') tag: 'pre').
	
	aClass organization categories do: 
		[:heading | n add: (self htmlProtocole: heading classe: aClass) ].
	^n
htmlMethod: selector classe: aClass
	
| source parser length table |
	source := (aClass sourceMethodAt: selector) asString.
	(parser := aClass parserClass new) parseSelector: source.
	length := parser endOfLastToken min: source size.
	table := (VLTableHtml new).
	table tr td contenu:
		(VLTagCollection 
		with: (((VLContentTag with: (source copyFrom: 1 to: length)) tag: 'b') tag: 'pre')
		with: ((VLContentTag with: (source copyFrom: length + 1  to: source size)) tag: 'pre')).
	table border: '"1"'; cellspacing: '"0"'; cellpadding: '"2"'.
	^ table
htmlProtocole: aSymbol classe: aClass
	
| n table |
	
	n := VLTagCollection with:
	"
	((VLContentTag with: 'classe ', aClass name, ' Protocole : [', aSymbol, ']') tag: 'H2').
	(aClass organization listAtCategoryNamed: aSymbol)
		do: [:sel | n add: (self htmlMethod: sel classe: aClass) ].
	^ n"

	(table := (((((VLContentTag with: '[', aSymbol, ']')) tag: 'b') tag: 'pre') tag: 'table')).
	table border: '"1"'; cellspacing: '"0"'; cellpadding: '"0"'.
	(aClass organization listAtCategoryNamed: aSymbol)
		do: [:sel | n add: (self htmlMethod: sel classe: aClass) ].
	^n
stream: aStream
	
stream := aStream
writeClasse: aClass
	
| doc n1 |
	[  
	doc := VLTagHtml nom: 'html'.
	doc contenu: (VLTagCollection with: (VLTagHtml nom: 'head')
		with: (VLTagHtml nom: 'body')).
	doc head contenu: ((VLContentTag with: aClass name) tag: 'title').
	doc body bgcolor: '"c0c0c0"'.
	doc body contenu: (n1 := (VLTagCollection with: 
		((VLContentTag with: aClass name) tag: 'H2'))).
	n1 add: (self htmlClasse: aClass).
	aClass class nonTrivial ifTrue: [ n1 add: (self htmlClasse: aClass class) ].
	"ws := WriteStream on: (String new: 100).
	aClass printOutOn: ws.
	n1 add: ((VLContentTag with: ws contents) tag: 'pre')."
	doc printOn: stream.
	] valueNowOrOnUnwindDo: [
		stream close ]
VLHtmlReport class
	instanceVariableNames: ''
[instance creation]
on: aFileName
	
| w x |
	w := (aFileName asFilename writeStream).
	x := self new.
	x stream: w.
	^x
on: aFileName categorie: uneCategorie
	
^(self on: aFileName) categorie: uneCategorie
on: aFileName classe: aClass
	
^(self on: aFileName) writeClasse: aClass
[example]
exemple
	
"VLHtmlReport on: 'toto.html' classe: VLHtmlReport"
	"VLHtmlReport on: 'toto.html' classe: VLTagAttribut"
exemple02
	
"VLHtmlReport on: 'toto.html' classe: VLHtmlReport"
	"VLHtmlReport on: 'toto.html' classe: VLTagAttribut"
	"VLHtmlReport on: 'toto.html' categorie: self category"

VLTagAttribut

Object subclass: #VLTagAttribut
	instanceVariableNames: 'nom valeur '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
[accessing]
nom: unNom 
	
nom := unNom
nom: unNom valeur: uneValeur
	
self nom: unNom; valeur: uneValeur
valeur
	
^valeur
valeur: uneValeur
	
valeur := uneValeur
[printing]
printOn: aStream
	
aStream nextPutAll:  nom, '=', valeur
VLTagAttribut class
	instanceVariableNames: ''
[instance creation]
nom: unNom valeur: uneValeur
	
^self new nom: unNom valeur: uneValeur

VLTagHtml

Object subclass: #VLTagHtml
	instanceVariableNames: 'nom attributs contenu '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
[accessing]
at: clef
	
^ (attributs at: clef asSymbol ifAbsent: [ ^nil ]) valeur
at: clef put: valeur
	
(attributs at: clef asSymbol ifAbsent: [ 
		attributs at: clef asSymbol put: (VLTagAttribut nom: clef valeur: valeur).
		^valeur ]) valeur: valeur
contenu
	
^ contenu
contenu: aCollection
	
contenu := aCollection
doesNotUnderstand: aMessage
	
| attribValue aTag |
	aMessage selector numArgs = 0 ifTrue: [
		"#toto numArgs"
		(attribValue := self at: aMessage selector) notNil ifTrue: [ ^ attribValue ].

		(aTag := self findTag: aMessage selector asString) notNil ifTrue: [ ^aTag ].
		^ super doesNotUnderstand: aMessage ].
	aMessage selector numArgs = 1 ifTrue: [
		"#toto: numArgs"
		^ self at: (aMessage selector copyFrom: 1 to: aMessage selector size - 1) put: aMessage arguments first.
		"1 toto: 4" ].
	^ super doesNotUnderstand: aMessage
findTag: unNom
	
^ contenu detect: [:each |
		each nom = unNom ] ifNone: [ ]
nom
	
^nom
nom: unNom
	
nom := unNom
[printing]
printOn: aStream
	
aStream nextPutAll: '<', nom .
	
	attributs do: [:each | aStream nextPutAll: ' '. each printOn: aStream]
		"separatedBy: [ aStream nextPutAll: ' ' ]".
	aStream nextPutAll: '>'.
	contenu printOn: aStream.
	aStream nextPutAll: ''
[instance creation]
attributsParDefaut
	
self class attributsParDefaut keysAndValuesDo: [:clef :valeur |
		attributs at: clef put: (VLTagAttribut nom: clef valeur: valeur) ]
contenuParDefaut
	
^ VLUndefinedTag new
initialize
	
attributs := Dictionary new.
	self attributsParDefaut.
	contenu := self contenuParDefaut
similaire
	
^self class nom: nom
tag: unNom
	
| x |
	unNom = 'table' ifTrue: [ x := VLTableHtml new. 
		x tr td contenu: self.
		^x ].
	unNom = 'tr' ifTrue: [ x := VLTrHtml new.
		x td  contenu: self.
		^x ].
	x := VLTagHtml nom: unNom.
	x contenu: self.
	^ x
VLTagHtml class
	instanceVariableNames: 'attributsParDefaut '
[instance creation]
new
	
^super new initialize
nom: unNom
	
^  super new initialize nom: unNom
[class initialization]
initialize
	
"self initialize"
	attributsParDefaut := Dictionary new.
[class accessing]
attributsParDefaut
	
attributsParDefaut isNil ifTrue: [ attributsParDefaut := Dictionary new ].
	^ attributsParDefaut
[examples]
exemple01
	
| table |
	table := VLTableHtml new.
	table tr td bgcolor: '"FFaaFF"'.
	table inspect
exemple02
	
| table doc |
	doc := VLTagHtml nom: 'html'.
	doc contenu: (VLTagCollection with: (VLTagHtml nom: 'head')
		with: (VLTagHtml nom: 'body')).
	doc body background: '"fond.gif"'.
	table := VLTableHtml new.
	table tr td contenu: (VLTagCollection with: 'TEXTE').
	doc body contenu: table.
	doc inspect
exemple03
	
| table doc |
	doc := VLTagHtml nom: 'html'.
	doc contenu: (VLTagCollection with: (VLTagHtml nom: 'head')
		with: (VLTagHtml nom: 'body')).
	doc body background: '"fond.gif"'.
	table := VLTableHtml new.
	table tr td contenu: (VLTagCollection with: (VLContentTag contenu: 'TEXTE')).
	doc body contenu: table.
	doc inspect

VLTrHtml

VLTagHtml subclass: #VLTrHtml
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
[instance creation]
contenuParDefaut
	
^ VLTagCollection with: VLTdHtml new
VLTrHtml class
	instanceVariableNames: ''
[instance creation]
new
	
^ self nom: 'tr'

VLTdHtml

VLTagHtml subclass: #VLTdHtml
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
VLTdHtml class
	instanceVariableNames: ''
[instance creation]
new
	
^ self nom: 'td'

VLUndefinedTag

VLTagHtml subclass: #VLUndefinedTag
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
[instance creation]
initialize
[printing]
printOn: aStream

VLTagCollection

OrderedCollection variableSubclass: #VLTagCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
[printing]
printOn: aStream
	
self do: [:each | each printOn: aStream]
		separatedBy: [ aStream nextPutAll: ' '; cr; tab ].
[accessing]
add
	
self add: (self first similaire)

VLEmptyTag

VLUndefinedTag subclass: #VLEmptyTag
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
[printing]
printOn: aStream
	
aStream nextPutAll: '<', nom, '>'

VLHrTag

VLEmptyTag subclass: #VLHrTag
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
VLHrTag class
	instanceVariableNames: ''
[instance creation]
new
	
^ self nom: 'hr'

VLBrTag

VLEmptyTag subclass: #VLBrTag
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
VLBrTag class
	instanceVariableNames: ''
[instance creation]
new
	
^ self nom: 'br'

VLTableHtml

VLTagHtml subclass: #VLTableHtml
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
[instance creation]
contenuParDefaut
	
^ VLTagCollection with: VLTrHtml new
VLTableHtml class
	instanceVariableNames: ''
[instance creation]
new
	
^ self nom: 'table'
[class initialization]
initialize
	
"self initialize"
	attributsParDefaut := Dictionary new.
		attributsParDefaut 
			at: #width put: '"80%"';
			at: #bgcolor put: '"FFFFFF"';
			at: #border put: '"0"';
			at: #bordercolor put: '"000000"'

VLContentTag

VLTagHtml subclass: #VLContentTag
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VL-Html'
[instance creation]
contenuParDefaut
	
^ String new
[printing]
printOn: aStream
	
aStream nextPutAll: contenu
VLContentTag class
	instanceVariableNames: ''
[instance creation]
with: contenu
	
^self new contenu: contenu