1#
2#
3# Mod�le HTG de base pour la g�n�ration de pages HTML
4# Doit �tre inclus en premier par le mod�le
5# Peut �tre compl�t� par des proc�dures issues du mod�le sp�cifique
6#
7# Historique
8#   1999/06/20 : pda          : s�paration pour permettre d'autres langages
9#   1999/07/02 : pda          : simplification
10#   1999/07/26 : pda          : ajout de lt et gt
11#   1999/09/12 : pda          : gestion minimale d'erreur
12#   2001/10/19 : pda          : ajout des "meta"
13#   2008/02/11 : pda/moindrot : ajout de rss et logo, et helem
14#   2008/02/18 : pda/moindrot : int�gration des bandeaux
15#
16
17##############################################################################
18# valeurs par d�faut
19##############################################################################
20
21set partie(header)  ""
22set partie(body-onload)  ""
23set partie(body-onunload)  ""
24
25# valeur par d�faut de "meta"
26set partie(meta) ""
27set partie(soustitre) 10
28set partie(currentcol) 0
29
30##############################################################################
31# proc�dures utilitaires
32##############################################################################
33
34
35proc check-int {v} {
36    if {! [regexp {^[0-9]+$} $v]} then {
37	error "$v is not a number"
38    }
39}
40
41# HTML element
42proc helem {tag content args} {
43    set tag [string tolower $tag]
44    set r "<$tag"
45    foreach {attr value} $args {
46	set attr [string tolower $attr]
47	append r " $attr=\"$value\""
48    }
49    append r ">$content"
50    # ne mettre une fermeture que pour les tags qui ne figurent pas
51    # dans la liste ci-dessous
52    if {[lsearch {img meta link} $tag] == -1} then {
53	append r "</$tag>"
54    }
55    return $r
56}
57
58###############################################################################
59# Mise en forme du texte
60###############################################################################
61
62proc htg_gras {} {
63    if [catch {set arg [htg getnext]} v] then {error $v}
64    set r [helem B $arg]
65    return $r
66}
67
68proc htg_teletype {} {
69    if [catch {set arg [htg getnext]} v] then {error $v}
70    set r [helem TT $arg]
71    return $r
72}
73
74proc htg_italique {} {
75    if [catch {set arg [htg getnext]} v] then {error $v}
76    set r [helem I $arg]
77    return $r
78}
79
80proc htg_souligne {} {
81    if [catch {set arg [htg getnext]} v] then {error $v}
82    set r [helem U $arg]
83    return $r
84}
85
86proc htg_retrait {} {
87    if [catch {set arg [htg getnext]} v] then {error $v}
88    set r [helem BLOCKQUOTE $arg]
89    return $r
90}
91
92proc htg_image {} {
93    if [catch {set source [htg getnext]} v] then {error $v}
94    if [catch {set texte  [htg getnext]} v] then {error $v}
95    set r [helem IMG "" SRC $source ALT $texte]
96    return $r
97}
98
99proc htg_liste {} {
100    if [catch {set arg [htg getnext]} v] then {error $v}
101    # Bidouille pour �viter de mettre des <P> � l'ext�rieur des <LI>
102    # On annule tous les sauts de paragraphe (qui sont hors des \item)
103    # et on remplace tous les "marqueurs" (cf htg_item) par des sauts de
104    # paragraphe
105    regsub -all "\n\n+" $arg "" arg
106    regsub -all "\r" $arg "\n\n" arg
107    set r [helem UL $arg]
108    return $r
109}
110
111proc htg_enumeration {} {
112    if [catch {set arg [htg getnext]} v] then {error $v}
113    # M�me bidouille que dans htg_liste
114    regsub -all "\n\n+" $arg "" arg
115    regsub -all "\r" $arg "\n\n" arg
116    set r [helem OL $arg]
117    return $r
118}
119
120proc htg_item {} {
121    if [catch {set arg [htg getnext]} v] then {error $v}
122    # Bidouille pour �viter de mettre des <P> � l'ext�rieur des <LI>
123    # On remplace tous les sauts de paragraphes par un caract�re "marqueur"
124    regsub -all "\n\n+" $arg "\r" arg
125    set r [helem LI $arg]
126    return $r
127}
128
129proc htg_titre {} {
130    if [catch {set niveau [htg getnext]} v] then {error $v}
131    check-int $niveau
132    if [catch {set texte  [htg getnext]} v] then {error $v}
133
134    set r [helem H$niveau $texte]
135    return $r
136}
137
138proc htg_verbatim {} {
139    if [catch {set texte  [htg getnext]} v] then {error $v}
140    set r [helem PRE $texte]
141    return $r
142}
143
144###############################################################################
145# Caract�res sp�ciaux
146###############################################################################
147
148proc htg_lt {} {
149    return {&lt;}
150}
151
152proc htg_gt {} {
153    return {&gt;}
154}
155
156proc htg_br {} {
157    return "<br>"
158}
159
160###############################################################################
161# URLs et liens
162###############################################################################
163
164proc htg_lien {} {
165    if [catch {set texte [htg getnext]} v] then {error $v}
166    if [catch {set url   [htg getnext]} v] then {error $v}
167    set r [helem A $texte HREF $url]
168    return $r
169}
170
171proc htg_liensecurise {} {
172    if [catch {set texte [htg getnext]} v] then {error $v}
173    if [catch {set url   [htg getnext]} v] then {error $v}
174    set r [helem A $texte CLASS auth HREF $url]
175    return $r
176}
177
178proc htg_ancre {} {
179    if [catch {set nom   [htg getnext]} v] then {error $v}
180    if [catch {set texte [htg getnext]} v] then {error $v}
181    set r [helem A $texte NAME $nom]
182    return $r
183}
184
185###############################################################################
186# Tableaux
187###############################################################################
188
189# <TABLE
190#	ALIGN=CENTER/LEFT/RIGHT			=> le tableau dans la page
191#	BGCOLOR=couleur
192#	BORDER=n
193#	BORDERCOLOR=?
194#	WIDTH=n%
195#
196# <TR
197#	ALIGN=CENTER/LEFT/RIGHT			=> le texte dans les cellules
198#	BGCOLOR=
199#	VALIGN=BASELINE/BOTTOM/CENTER/TOP	=> le texte dans les cellules
200#
201# <TD
202#	ALIGN=CENTER/LEFT/RIGHT			=> le texte dans la cellule
203#	BGCOLOR=
204#	COLSPAN=n
205#	ROWSPAN=n
206#	VALIGN=BASELINE/BOTTOM/CENTER/TOP
207#	WIDTH=n%
208
209proc htg_tableau {} {
210    if [catch {set attributs [htg getnext]} v] then {error $v}
211    if [catch {set defaut    [htg getnext]} v] then {error $v}
212    if [catch {set contenu   [htg getnext]} v] then {error $v}
213
214    #
215    # Rendre facilement accessible les attributs de la colonne num�ro i
216    #
217
218    set numcol 0
219    foreach a $defaut {
220	set attrcol($numcol) $a
221	incr numcol
222    }
223
224    #
225    # Parcourir les lignes et les cases, et les mettre en forme
226    #
227
228    set resultat ""
229    foreach ligne $contenu {
230	append resultat "<TR>"
231	set numcol 0
232	foreach case $ligne {
233	    set nbcol    [lindex $case 0]
234	    set attrcase [lindex $case 1]
235	    set texte    [lindex $case 2]
236
237	    set attrcase [fusion-attributs $attrcol($numcol) $attrcase]
238
239	    set colspan ""
240	    if {$nbcol > 1} then { set colspan "COLSPAN=$nbcol " }
241	    append resultat "<TD $colspan$attrcase>$texte</TD>"
242
243	    incr numcol $nbcol
244	}
245	append resultat "</TR>"
246    }
247
248    return "<TABLE $attributs>$resultat</TABLE>"
249}
250
251proc fusion-attributs {a1 a2} {
252    foreach a $a1 {
253	set cv [split $a =]
254	set c [lindex $cv 0]
255	set v [lindex $cv 1]
256	set tab($c) $v
257    }
258
259    foreach a $a2 {
260	set cv [split $a =]
261	set c [lindex $cv 0]
262	set v [lindex $cv 1]
263	set tab($c) $v
264    }
265
266    set r ""
267    foreach a [array names tab] {
268	append r "$a=$tab($a) "
269    }
270    return $r
271}
272
273#
274# Attributs des colonnes du tableau
275# Ceux-ci sont d�finis par \casedefauttableau {}, puis sont
276# renvoy�s � \tableau qui les propage ensuite vers les diff�rentes cases.
277# Chaque colonne poss�de plusieurs attributs (s�par�s par des espaces)
278# Les diff�rentes colonnes sont s�par�es par des ";"
279#
280
281proc htg_casedefauttableau {} {
282    if [catch {set attributs [htg getnext]} v] then {error $v}
283    return [list $attributs]
284}
285
286proc htg_bordure {} {
287    if [catch {set largeur [htg getnext]} v] then {error $v}
288    check-int $largeur
289    if [catch {set couleur [htg getnext]} v] then {error $v}
290
291    set bordercolor [test-couleur $couleur]
292    if {! [string equal $bordercolor ""]} {
293	set bordercolor "BORDERCOLOR=$bordercolor "
294    }
295    return "BORDER=$largeur $bordercolor"
296}
297
298# BASELINE/BOTTOM/CENTER/TOP
299proc htg_centragevertical {} {
300    if [catch {set centrage [htg getnext]} v] then {error $v}
301    return "VALIGN=$centrage "
302}
303
304# CENTER/LEFT/RIGHT
305proc htg_centragehorizontal {} {
306    if [catch {set centrage [htg getnext]} v] then {error $v}
307    return "ALIGN=$centrage "
308}
309
310proc htg_padding {} {
311    if [catch {set padding [htg getnext]} v] then {error $v}
312    return "CELLPADDING=$padding% "
313}
314
315proc htg_taille {} {
316    if [catch {set taille [htg getnext]} v] then {error $v}
317    return "WIDTH=$taille% "
318}
319
320proc htg_couleurfond {} {
321    if [catch {set couleur [htg getnext]} v] then {error $v}
322    set couleur [test-couleur $couleur]
323    return "BGCOLOR=$couleur "
324}
325
326array set tabcouleurs {
327    jaune	#FFFFCC
328    vertpale	#BDFFBD
329    vertfonce	#006600
330    gris	#CCCCCC
331    rouge	#FF0000
332    bleu	#0000FF
333}
334
335proc test-couleur {couleur} {
336    global tabcouleurs
337
338    set c [string tolower $couleur]
339    if {[info exists tabcouleurs($c)]} then {
340	set couleur $tabcouleurs($c)
341    }
342    return $couleur
343}
344
345
346#
347# Le contenu du tableau (les lignes et les cases) proprement dit
348# Une ligne est r�cup�r�e sous la forme d'une liste :	{case case ...}
349# o� chaque case est une liste :	{nbcols attributs texte}
350#
351
352proc htg_lignetableau {} {
353     if [catch {set texte [htg getnext]} v] then {error $v}
354     return [list $texte]
355}
356
357proc htg_casetableau {} {
358    if [catch {set attributs [htg getnext]} v] then {error $v}
359    if [catch {set texte     [htg getnext]} v] then {error $v}
360    return [list [list 1 $attributs $texte]]
361}
362
363proc htg_multicasetableau {} {
364    if [catch {set nbcol     [htg getnext]} v] then {error $v}
365    check-int $nbcol
366    if [catch {set attributs [htg getnext]} v] then {error $v}
367    if [catch {set texte     [htg getnext]} v] then {error $v}
368
369    return [list [list $nbcol $attributs $texte]]
370}
371
372##############################################################################
373# Gestion des bandeaux
374##############################################################################
375
376proc htg_bandeau {} {
377    global partie
378
379    if [catch {set titre   [htg getnext]} v] then {error $v}
380    if [catch {set contenu [htg getnext]} v] then {error $v}
381
382    set titre [nettoyer-html $titre]
383    regsub -all "\n" $titre "<br>" titre
384
385    set partie(titrebandeau) $titre
386    set partie(contenubandeau) $contenu
387
388    return {}
389}
390
391proc htg_elementbandeau {} {
392    global partie
393
394    if [catch {set titre [htg getnext]} v] then {error $v}
395    if [catch {set refs  [htg getnext]} v] then {error $v}
396
397    set sousmenu "smenu"
398    if {[string length $titre] > 0} then {
399	set id $partie(soustitre)
400        incr partie(soustitre)
401
402	set titre [helem DT $titre]
403	append sousmenu $id
404    }
405
406    set dd [helem DD [helem UL $refs] ID $sousmenu]
407
408    return "$titre$dd"
409}
410
411proc htg_reference {} {
412    if [catch {set texte [htg getnext]} v] then {error $v}
413    set r [helem LI $texte]
414    return $r
415}
416
417##############################################################################
418# Gestion des contextes
419##############################################################################
420
421# � sp�cifier dans le fichier .htgt
422proc htg_contexte {} {
423    global ctxt
424
425    if [catch {set valeur [htg getnext]} v] then {error $v}
426    set ctxt $valeur
427    return ""
428}
429
430# � sp�cifier dans le fond de page
431proc htg_contextepardefaut {} {
432    global ctxt
433
434    if [catch {set valeur [htg getnext]} v] then {error $v}
435    if {! [info exists ctxt]} then {
436	set ctxt $valeur
437    }
438    return ""
439}
440
441# proc�dure utilitaire
442proc dans-contexte {valeur} {
443    global ctxt
444
445    set r 0
446    if {[info exists ctxt]} then {
447	if {[lsearch $ctxt $valeur] != -1} then {
448	    set r 1
449	}
450    }
451    return $r
452}
453
454# � sp�cifier dans le fond de page
455proc htg_sicontexte {} {
456    if [catch {set valeur [htg getnext]} v] then {error $v}
457    if [catch {set code   [htg getnext]} v] then {error $v}
458    set r ""
459    if {[dans-contexte $valeur]} then {
460	set r $code
461    }
462    return $r
463}
464
465##############################################################################
466# Gestion des tags "meta"
467##############################################################################
468
469proc htg_metarefresh {} {
470    global partie
471
472    if [catch {set temps [htg getnext]} v] then {error $v}
473    append partie(meta) [helem META "" HTTP-EQUIV refresh CONTENT $temps]
474    append partie(meta) [helem META "" HTTP-EQUIV pragma  CONTENT "no-cache"]
475    append partie(meta) "\n"
476    return ""
477}
478
479##############################################################################
480# M�morisation des parties
481##############################################################################
482
483proc htg_set {} {
484    global partie
485
486    if [catch {set variable [htg getnext]} v] then {error $v}
487    if [catch {set partie($variable) [htg getnext]} v] then {error $v}
488    return {}
489}
490
491# ceci doit �tre d�fini au d�but de la page pour indiquer les param�tres
492# du flux RSS.
493proc htg_rss {} {
494    global partie
495
496    if [catch {set titre [htg getnext]} v] then {error $v}
497    if [catch {set lien  [htg getnext]} v] then {error $v}
498    set titre [nettoyer-html $titre]
499    regsub -all "\n\n+" $titre "<p>" titre
500    set partie(rss) [helem LINK "" \
501			    REL "alternate" TYPE "application/rss+xml" \
502			    TITLE $titre HREF $lien \
503			]
504    return {}
505}
506
507proc htg_partie {} {
508    global partie
509
510    if [catch {set id [htg getnext]} v] then {error $v}
511    if [catch {set texte [htg getnext]} v] then {error $v}
512    set texte [nettoyer-html $texte]
513    regsub -all "\n\n+" $texte "<p>" texte
514    set partie(id) $texte
515    return {}
516}
517
518proc htg_recuperer {} {
519    global partie
520
521    if [catch {set id [htg getnext]} v] then {error $v}
522    if {! [info exists partie($id)]} then {error "missing part '$id'"}
523    return $partie($id)
524}
525
526
527##############################################################################
528# Mise en forme HTML
529##############################################################################
530
531proc nettoyer-html {texte} {
532    # retirer les sauts de ligne en d�but et en fin de partie
533    regsub -all "\[ \t\n\]*$" $texte "" texte
534    regsub -all "^\[ \t\n\]*" $texte "" texte
535
536    # convertir les ~ en espaces ins�cables et les ~~ en ~
537    regsub -all {~} $texte {\&nbsp;} texte
538    regsub -all {\&nbsp;\&nbsp;} $texte {~} texte
539
540    # convertir les guillemets fran�ais
541    regsub -all {<<} $texte {�} texte
542    regsub -all {>>} $texte {�} texte
543
544    return $texte
545}
546