/pliant/protocol/http/style/default.style
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	module "/pliant/language/compiler.pli"
17	module "/pliant/language/context.pli"
18	module "/pliant/language/stream.pli"
19	module "/pliant/language/parser.pli"
20	module "/pliant/language/parser/multiline.pli"
21	submodule "/pliant/language/type/text/language.pli"
22	module "/pliant/protocol/http/server.pli"
23	module "/pliant/admin/md5.pli"
24	module "common.pli"
25	submodule "common.style"
26	submodule "/pliant/graphic/color/rgb888.pli"
27
28	constant smart_input false
29	constant common_path "/common/"+string:pliant_release_number+"/"
30
31
32
33	#  new Pliant instructions
34
35
36	public
37
38	tag_prototype common
39	attr bgcolor ColorRGB888 (color rgb 255 255 255)
40	attr body Str
41	attr url_icon Str
42	attr has_html4 CBool true
43	attr head Str
44	attr css Str
45	attr header Str
46	attr footer Str
47	hidden
48
49	tag_prototype page_header
50	void
51	tag_prototype page_footer
52	void
53
54	tag_prototype link label href
55	attr label Str encode
56	attr href Str
57	attr section Str
58	attr options Str
59	attr relative
60	attr no_extension
61	attr help Str encode
62
63	tag_prototype section name
64	attr name Str encode
65
66	tag_prototype note label
67	attr label Str
68	attr help Str encode
69	subpage target
70
71	tag_prototype image src -> img
72	attr src Str
73
74	tag_prototype how target
75	attr target Str
76	attr section Str
77	attr options Str
78	attr relative
79	attr no_extension
80
81	tag_prototype title label
82	attr label Str encode
83	attr logo Str
84	attr link Str
85	attr small
86	sequence font
87	attr face Str
88	attr size Float 36
89	attr ssr Bool false # 'ssr' stands for 'server side rendering'
90	attr color ColorRGB888 (color rgb 0 0 0)
91	attr button Str
92	sequence bsize
93	attr bsize_x Float undefined
94	attr bsize_y Float undefined
95	sequence margin
96	attr margin_left Float undefined
97	attr margin_top Float undefined
98	attr margin_right Float undefined
99	attr margin_bottom Float undefined
100	attr round Int 0
101	attr bgcolor ColorRGB888 (color rgb 255 255 255)
102
103	tag_prototype chapter label
104	attr label Str encode
105
106	tag_prototype header label
107	attr label Str encode
108	attr level Int 0
109	body
110	sequence font
111	attr face Str
112	attr size Float 36
113	attr ssr Bool false
114	sequence factor
115	attr factor1 Float 4/5
116	attr factor2 Float 3/5
117	attr factor3 Float 2/5
118	attr color ColorRGB888 (color rgb 0 0 0)
119	attr tabulation Int 3
120	sequence shade
121	attr shade1 Float 0
122	attr shade2 Float 0
123	attr shade3 Float 0
124	attr button Str
125	sequence bsize
126	attr bsize_x Float undefined
127	attr bsize_y Float undefined
128	sequence margin
129	attr margin_left Float undefined
130	attr margin_top Float undefined
131	attr margin_right Float undefined
132	attr margin_bottom Float undefined
133	attr round Int 0
134	attr bgcolor ColorRGB888 (color rgb 255 255 255)
135	sequence bgshade
136	attr bgshade1 Float 0
137	attr bgshade2 Float 0
138	attr bgshade3 Float 0
139
140	method p header h
141	arg_rw HtmlPage p ; arg Str h
142	p header h
143	void
144
145	tag_prototype para -> p
146	body
147	newline
148
149	tag_prototype eol -> br
150	newline
151
152	tag_prototype center
153	body
154
155	tag_prototype bold -> b
156	body
157
158	tag_prototype italic -> i
159	body
160
161	tag_prototype big
162	body
163
164	tag_prototype small
165	body
166
167	tag_prototype fixed
168	body
169	attr is_active CBool false
170
171	tag_prototype font
172	sequence font
173	attr face Str
174	attr size Float 12
175	attr ssr Bool false
176	attr color ColorRGB888 (color rgb 0 0 0)
177	attr linebreak CBool true
178	body
179
180	tag_prototype highlight label
181	attr label Str encode
182	attr size Str "-2"
183	attr color ColorRGB888 (color rgb 255 0 0)
184
185	tag_prototype list -> ul
186	body
187	newline
188
189	tag_prototype item -> li
190	body
191	newline
192
193	tag_prototype table
194	attr columns Int undefined
195	attr padding Int 4 -> cellpadding
196	attr spacing Int 0 -> cellspacing
197	attr border Int 1
198	body
199	newline
200	attr cursor Int undefined
201
202	tag_prototype row -> tr
203	body
204	newline
205
206	tag_prototype cell -> td
207	attr header
208	attr color ColorRGB888 -> bgcolor
209	body
210	newline
211	attr header_color ColorRGB888 (color rgb 208 208 208)
212	attr header_shade Float -0.1
213
214	tag_prototype box
215	attr header Str encode
216	attr color ColorRGB888 (color rgb 255 255 255)
217	attr transparent
218	attr button Str
219	sequence bsize
220	attr bsize_x Float undefined
221	attr bsize_y Float undefined
222	sequence margin
223	attr margin_left Float undefined
224	attr margin_top Float undefined
225	attr margin_right Float undefined
226	attr margin_bottom Float undefined
227	attr round Int 0
228	attr width Str
229	attr left
230	attr right
231	sequence hfont
232	attr hface Str
233	attr hsize Float 36
234	attr hssr Bool false
235	attr hcolor ColorRGB888 (color rgb 0 0 0)
236	body
237	newline
238
239	tag_prototype button label
240	attr label Str encode
241	attr noeol
242	subpage target
243	sequence font
244	attr face Str
245	attr size Float
246	attr ssr Bool false
247	attr tcolor ColorRGB888 (color rgb 0 0 0)
248	attr extend Float undefined
249	attr center CBool true
250	attr button Str
251	sequence bsize
252	attr bsize_x Float undefined
253	attr bsize_y Float undefined
254	sequence margin
255	attr margin_left Float undefined
256	attr margin_top Float undefined
257	attr margin_right Float undefined
258	attr margin_bottom Float undefined
259	attr bcolor ColorRGB888
260
261	tag_prototype icon src
262	attr src Str
263	attr help Str encode
264	subpage target
265	sequence isize
266	attr isize_x Float undefined
267	attr isize_y Float undefined
268	attr dull Float undefined
269	attr button Str
270	sequence bsize
271	attr bsize_x Float undefined
272	attr bsize_y Float undefined
273	sequence margin
274	attr margin_left Float undefined
275	attr margin_top Float undefined
276	attr margin_right Float undefined
277	attr margin_bottom Float undefined
278	attr bcolor ColorRGB888
279
280
281	tag_prototype input
282	attr label Str encode
283	attr type Str
284	attr name Str
285	attr value Str encode
286	attr length Int undefined -> size
287	attr database
288	attr is_read_only CBool false
289
290	tag_prototype textarea
291	attr label Str encode
292	attr name Str
293	attr value Str
294	attr columns Int -> cols
295	attr rows Int
296	attr database
297
298	tag_prototype select_begin
299	attr label Str encode
300	attr name Str
301	attr value Str encode
302	attr database
303	attr is_active CBool false
304	attr selected_label Str
305	tag_prototype select_end
306	attr database
307
308	tag_prototype option label value
309	attr label Str encode
310	attr value Str encode
311
312	tag_prototype pdata
313	attr label Str encode
314	attr path Str
315	attr value Str encode
316	attr length Int
317	attr columns Int
318	attr rows Int
319
320	tag_prototype listing
321	body
322
323
324
325	#  style setup
326
327
328	method p standard_html_hook text
329	arg_rw HtmlPage p ; arg Str text
330	p:http_stream writechars text
331
332	method p standard_text_hook text
333	arg_rw HtmlPage p ; arg Str text
334	if (p attribute font ssr)
335	var Str extra := " font [dq]"+(p attribute font face)+"[dq] "+string:(p attribute font size)+" color [dq]"+string:(p attribute font color)+"[dq] bgcolor [dq]"+string:(p attribute common bgcolor)+"[dq]"
336	var Str sentence := html_decode text
337	if not (p attribute font linebreak)
338	p:http_stream writechars "<img src=[dq]"+common_path+(http_encode "text "+string:sentence+extra)+"[dq] border=[dq]0[dq] align=[dq]middle[dq]>"
339	else
340	while sentence<>""
341	if (sentence 0 1)<>" "
342	var Int i := sentence search " " sentence:len
343	p:http_stream writechars "<img src=[dq]"+common_path+(http_encode "text "+string:(sentence 0 i)+extra)+"[dq] border=[dq]0[dq] align=[dq]middle[dq]>"
344	sentence := sentence i sentence:len
345	else
346	p:http_stream writechars " "
347	sentence := sentence 1 sentence:len
348	eif (p attribute fixed is_active)
349	p:http_stream writechars (replace text " " "&nbsp;")
350	else
351	p:http_stream writechars text
352
353	method page standard_begin_hook
354	arg_rw HtmlPage page
355	implicit page
356	write "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 4.01 Transitional//EN[dq]>[lf]"
357	write "<html>[lf]"
358	write "<head>[lf]"
359	if (attribute common url_icon)<>""
360	write "<link rel=[dq]icon[dq] type=[dq]image/png[dq] href=[dq]"+(attribute common url_icon)+"[dq]>[lf]"
361	write "<script src=[dq]"+common_path+"pliant.js[dq] language=[dq]JavaScript[dq] type=[dq]text/javascript[dq]></script>[lf]"
362	if (attribute common head)<>""
363	write (attribute common head) ; write "[lf]"
364	if (attribute common css)<>""
365	write "<style type=[dq]text/css[dq]>[lf]"
366	write (attribute common css) ; write "[lf]"
367	write "</style>[lf]"
368	write "</head>[lf]"
369	write "<body"
370	write " onLoad=[dq]refresh(false)[dq]"
371	var ColorRGB888 bg := attribute common bgcolor
372	if bg:r<>255 or bg:g<>255 or bg:b<>255
373	write " bgcolor=[dq]"+(string bg "html")+"[dq]"
374	if (attribute common body)<>""
375	write " "+(attribute common body)
376	write ">[lf]"
377	# write "<!-- "+http_request:query_first_line+" -->[lf]"
378	var Str enctype := ""
379	if browser="konqueror"
380	enctype := " enctype [dq]multipart/form-data[dq]"
381	write "<form name=[dq]pliant[dq] method=[dq]POST[dq]"+enctype+" onSubmit=[dq]return complete(this)[dq]>[lf]"
382	write "<input type=[dq]hidden[dq] name=[dq]_pliant_x[dq] value=[dq][dq]>[lf]"
383	write "<input type=[dq]hidden[dq] name=[dq]_pliant_y[dq] value=[dq][dq]>[lf]"
384	write "<input type=[dq]hidden[dq] name=[dq]_[dq] value=[dq][dq]>[lf]"
385	var Pointer:ColorRGB888 fc :> attribute font color
386	if (attribute font face)<>"" or fc:r<>0 or fc:g<>0 or fc:b<>0
387	write "<font face=[dq]"+(attribute font face)+"[dq] color=[dq]"+(string fc "html")+"[dq]>"
388	if (attribute common header)<>""
389	write (attribute common header) ; write "[lf]"
390	page_header
391
392	method page standard_end_hook
393	arg_rw HtmlPage page
394	implicit page
395	if not request:answer_header_sent or request:answer_footer_sent
396	return
397	page_footer
398	if (attribute common footer)<>""
399	write (attribute common footer) ; write "[lf]"
400	var Pointer:ColorRGB888 fc :> attribute font color
401	if (attribute font face)<>"" or fc:r<>0 or fc:g<>0 or fc:b<>0
402	write "</font>[lf]"
403	write "</form>[lf]"
404	write "</body>[lf]"
405	write "</html>[lf]"
406
407	function full_url target has_section section has_options options relative no_extension -> url
408	arg Str target section options ; arg CBool has_section has_options relative no_extension ; arg Str url
409	url := http_encode target
410	var Str without_path := url (url search_last "/" -1)+1 url:len
411	if not no_extension and without_path:len<>0 and (without_path search "." -1)=(-1) and (without_path search ":" -1)=(-1)
412	url += ".html"
413	if has_section
414	url += "#"+http_encode:section
415	if has_options
416	url += "?"+http_encode:options
417	if relative
418	url := replace url ":" "%3A"
419
420	style_setup
421	text_hook :> the_function '. standard_text_hook' HtmlPage Str
422	begin_hook :> the_function '. standard_begin_hook' HtmlPage
423	end_hook :> the_function '. standard_end_hook' HtmlPage
424
425	push input is_read_only false
426	tag_attributes_setup
427
428	tag_html page_header
429	void
430	tag_html page_footer
431	void
432
433	tag_html link
434	write "<a href=[dq]"+(full_url href has:section section has:options (attribute link options) has:relative has:no_extension)+"[dq]" # using 'attribute link options' instead of simply 'options' is required in order not to get page:options
435	if help<>""
436	write " title=[dq]"+help+"[dq]"
437	write_attributes
438	write ">"
439	write label
440	write "</a>"
441
442	tag_html section
443	write "<a name=[dq]"+name+"[dq]></a>"
444
445	tag_html note
446	write "<a href=[dq]"+request:encoded_path+"?"+target+"[dq]"
447	if help<>""
448	write " title=[dq]"+help+"[dq]"
449	write ">"+label+"</a>[lf]"
450
451	tag_html image
452	write "<img src=[dq]"+src+"[dq]"
453	write_attributes
454	write ">"
455
456	tag_html how
457	write "<a href=[dq]"+(full_url target has:section section has:options (attribute how options) has:relative has:no_extension)+"[dq]>"
458	write "<img src=[dq]"+common_path+"icon/how.png[dq] border=[dq]0[dq]>"
459	write "</a>"
460
461	tag_html title
462	head "<title>"+label+"</title>[lf]"
463	if has:logo
464	write "<table width=[dq]100%[dq]><tr><td width=[dq]100%[dq]>"
465	if button<>"" or round>0
466	box button button bsize bsize_x bsize_y margin margin_left margin_top margin_right margin_bottom round round color bgcolor width "100%"
467	center
468	font font face size ssr color color linebreak false
469	text html_decode:label
470	else
471	if ssr
472	var Str url := "text "+(string html_decode:label)+" font [dq]"+face+"[dq] "+string:size+" color [dq]"+string:color+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
473	write "<center><img src=[dq]"+common_path+http_encode:url+"[dq]></center>"
474	else
475	write "<h1><center>"+label+"</center></h1>"
476	if has:logo
477	write "</td><td>"
478	if has:link
479	write "<a href=[dq]"+link+"[dq]>"
480	write "<img src=[dq]"+logo+"[dq]"+(shunt has:link " border=[dq]0[dq]" "")+">"
481	if has:link
482	write "</a>"
483	write "</td></tr></table>"
484	write "<br>[lf]"
485
486	tag_html chapter
487	write "<br><br>[lf]"
488	if (attribute header button)<>"" or (attribute header round)>0
489	box button (attribute header button) bsize (attribute header bsize_x) (attribute header bsize_y) margin (attribute header margin_left) (attribute header margin_top) (attribute header margin_right) (attribute header margin_bottom) round (attribute header round) color (attribute header bgcolor) width "100%"
490	font font (attribute header face) (attribute header size) (attribute header ssr) color (attribute header color) linebreak false
491	if (attribute header ssr)
492	text (repeat (attribute header tabulation) " ")+html_decode:label
493	else
494	fixed text:(repeat (attribute header tabulation) " ") ; text html_decode:label
495	else
496	if (attribute header ssr)
497	var Str url := "text "+(string html_decode:label)+" font [dq]"+(attribute header face)+"[dq] "+string:(attribute title size)+" color [dq]"+string:(attribute header color)+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
498	write "<p><img src=[dq]"+common_path+http_encode:url+"[dq]></p>[lf]"
499	else
500	write "<h1>"+label+"</h1>[lf]"
501
502	tag_html_open header
503	write "<br>[lf]"
504	push level level+1
505	var Float f := shunt level=1 factor1 level=2 factor2 factor3
506	if button<>"" or round>0
507	box button button bsize bsize_x*f bsize_y*f margin margin_left*f margin_top*f margin_right*f margin_bottom*f round (cast round*f Int) color (shade bgcolor (shunt level=1 bgshade1 level=2 bgshade2 bgshade3)) width "100%"
508	font font face size*f ssr color (shade color (shunt level=1 shade1 level=2 shade2 shade3)) linebreak false
509	if ssr
510	text (repeat tabulation " ")+html_decode:label
511	else
512	fixed text:(repeat tabulation " ") ; text html_decode:label
513	else
514	if ssr
515	var Str url := "text "+(string html_decode:label)+" font [dq]"+face+"[dq] "+(string size*f)+" color [dq]"+string:color+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
516	write "<p><img src=[dq]"+common_path+http_encode:url+"[dq]></p>[lf]"
517	else
518	write "<h"+(string level+1)+">"+label+"</h"+(string level+1)+">[lf]"
519	tag_html_close header
520	void
521
522	tag_html_open big
523	write "<font size=[dq]+1[dq]>"
524	tag_html_close big
525	write "</font>"
526
527	tag_html small
528	write "<font size=[dq]-1[dq]>"
529	tag_html_close small
530	write "</font>"
531
532	tag_html_open fixed
533	write "<tt>"
534	push is_active true
535	tag_html_close fixed
536	write "</tt>"
537
538	tag_html_open font
539	if (attribute common has_html4)
540	var Str st := ""
541	if has:face
542	st += "font-family: "+face+"; "
543	if has:size
544	st += "font-size: "+(string size "fixed 0")+"pt; "
545	if has:color
546	st += "color: "+(string color "html")+"; "
547	write "<span style=[dq]"
548	write (st 0 (max st:len-2 0))
549	write "[dq]>"
550	else
551	write "<font"
552	if has:face
553	write " face=[dq]"+face+"[dq]"
554	if has:size
555	write " size=[dq]"+(string size "fixed 0")+"pt[dq]"
556	if has:color
557	write " color=[dq]"+(string color "html")+"[dq]"
558	write_attributes
559	write ">"
560	# if (attributes option "bold")
561	#   write "<b>"
562	tag_html_close font
563	# if (attributes option "bold")
564	#   write "</b>"
565	if (attribute common has_html4)
566	write "</span>"
567	else
568	write "</font>"
569
570	tag_html highlight
571	write "<tt> </tt>"
572	write "<font size=[dq]"+size+"[dq] color=[dq]"+(string color "html")+"[dq]><b>"
573	write label
574	write "</b></font>"
575
576	tag_html_open table
577	push cursor (shunt has:columns (cast 0 Int) undefined)
578	write "<table border=[dq]"+string:border+"[dq] cellpadding=[dq]"+string:padding+"[dq] cellspacing=[dq]"+string:spacing+"[dq]"
579	write_attributes
580	write ">[lf]"
581	tag_html_close table
582	write "</table>[lf]"
583
584	tag_html_open cell
585	if (attribute table cursor)<>undefined and (attribute table cursor)%(attribute table columns)=0
586	write "<tr>[lf]"
587	write "<td"
588	if has:color
589	write " bgcolor=[dq]"+(string color "html")+"[dq]"
590	push common bgcolor color
591	eif has:header
592	# write " bgcolor=[dq]"+(string header_color "html")+"[dq]"
593	write " bgcolor=[dq]"+(string (shade (attribute common bgcolor) header_shade) "html")+"[dq]"
594	write_attributes
595	write ">"
596	var Pointer:ColorRGB888 fc :> attribute font color
597	if (attribute font face)<>"" or fc:r<>0 or fc:g<>0 or fc:b<>0
598	write "<font face=[dq]"+(attribute font face)+"[dq] color=[dq]"+(string fc "html")+"[dq]>"
599	tag_html_close cell
600	var Pointer:ColorRGB888 fc :> attribute font color
601	if (attribute font face)<>"" or fc:r<>0 or fc:g<>0 or fc:b<>0
602	write "</font>"
603	write "</td>[lf]"
604	if (attribute table cursor)<>undefined
605	attribute table cursor += 1
606	if (attribute table cursor)%(attribute table columns)=0
607	write "</tr>[lf]"
608
609	tag_html_open box
610	var ColorRGB888 c := color
611	var ColorRGB888 c2 := shade c 0.5
612	if not has:header
613	c2 := c
614	var CBool colored := not has:transparent and (button<>"" or round>0 or (memory_different addressof:color ColorRGB888:size addressof:(attribute common bgcolor) ColorRGB888:size))
615	write "<table cellspacing=[dq]0[dq] cellpadding=[dq]"+string:(shunt button<>"" or round>0 (cast 0 Int) (attribute table padding))+"[dq]"
616	if has:width
617	write " width=[dq]"+width+"[dq]"
618	if has:left
619	write " align=[dq]left[dq]"
620	if has:right
621	write " align=[dq]right[dq]"
622	# write_attributes
623	write "><tr>[lf]"
624	if button<>""
625	var Str opt := " button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" color [dq]"+string:c+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
626	write "<td><img src=[dq]"+common_path+"border%200"+http_encode:opt+"[dq]></td>[lf]"
627	write "<td background=[dq]"+common_path+"border%201"+http_encode:opt+"[dq]></td>[lf]"
628	write "<td><img src=[dq]"+common_path+"border%202"+http_encode:opt+"[dq]></td>[lf]"
629	write "</tr><tr>[lf]"
630	if has:header
631	write "<td background=[dq]"+common_path+"border%203"+http_encode:opt+"[dq]></td>[lf]"
632	write "<td bgcolor=[dq]#"+string:c+"[dq]><center>"
633	if hssr
634	var Str url := "text "+(string html_decode:header)+" font [dq]"+hface+"[dq] "+string:hsize+" color [dq]"+string:hcolor+"[dq] bgcolor [dq]"+string:c+"[dq]"
635	write "<img src=[dq]"+common_path+http_encode:url+"[dq]>"
636	else
637	write header
638	write "</center></td>[lf]"
639	write "<td background=[dq]"+common_path+"border%205"+http_encode:opt+"[dq]></td>[lf]"
640	write "</tr><tr>[lf]"
641	write "<td><img src=[dq]"+common_path+"border%203"+http_encode:opt+"[dq]></td>[lf]"
642	write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
643	write "<td><img src=[dq]"+common_path+"border%205"+http_encode:opt+"[dq]></td>[lf]"
644	write "</tr><tr>[lf]"
645	var Str opt := " button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" color [dq]"+string:c2+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
646	write "<td><img src=[dq]"+common_path+"border%203"+http_encode:opt+"[dq]></td>[lf]"
647	write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
648	write "<td><img src=[dq]"+common_path+"border%205"+http_encode:opt+"[dq]></td>[lf]"
649	write "</tr><tr>[lf]"
650	write "<td background=[dq]"+common_path+"border%203"+http_encode:opt+"[dq]></td>[lf]"
651	eif round>0
652	var Str opt := " size "+string:round+" "+string:round+" color [dq]"+string:c+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
653	write "<td><img src=[dq]"+common_path+"corner%200"+http_encode:opt+"[dq]></td>[lf]"
654	write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
655	write "<td><img src=[dq]"+common_path+"corner%201"+http_encode:opt+"[dq]></td>[lf]"
656	write "</tr><tr>[lf]"
657	if has:header
658	write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
659	write "<td bgcolor=[dq]#"+string:c+"[dq]><center>"
660	if hssr
661	var Str url := "text "+(string html_decode:header)+" font [dq]"+hface+"[dq] "+string:hsize+" color [dq]"+string:hcolor+"[dq] bgcolor [dq]"+string:c+"[dq]"
662	write "<img src=[dq]"+common_path+http_encode:url+"[dq]>"
663	else
664	write header
665	write "</center></td>[lf]"
666	write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
667	write "</tr><tr>[lf]"
668	write "<td colspan=[dq]3[dq] height=[dq]"+string:round+"[dq] bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
669	write "</tr><tr>[lf]"
670	write "<td colspan=[dq]3[dq] height=[dq]"+string:round+"[dq] bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
671	write "</tr><tr>[lf]"
672	write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
673	else
674	if has:header
675	write "<td"+(shunt colored " bgcolor=[dq]#"+string:c+"[dq]" "")+"><center>"
676	if hssr
677	var Str url := "text "+(string html_decode:header)+" font [dq]"+hface+"[dq] "+string:hsize+" color [dq]"+string:hcolor+"[dq] bgcolor [dq]"+string:c+"[dq]"
678	write "<img src=[dq]"+common_path+http_encode:url+"[dq]>"
679	else
680	write header
681	write "</center></td>[lf]"
682	write "</tr><tr>[lf]"
683	write "<td width=[dq]100%[dq] height=[dq]100%[dq]"
684	if colored
685	write " bgcolor=[dq]#"+string:c2+"[dq]"
686	write ">"
687	tag_stack mark
688	if colored
689	push common bgcolor c2
690	tag_html_close box
691	tag_stack rewind
692	write "</td>[lf]"
693	var ColorRGB888 c := color
694	var ColorRGB888 c2 := shade c 0.5
695	if not has:header
696	c2 := c
697	if button<>""
698	var Str opt := " button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" color [dq]"+string:c2+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
699	write "<td background=[dq]"+common_path+"border%205"+http_encode:opt+"[dq]></td>[lf]"
700	write "</tr><tr>[lf]"
701	write "<td><img src=[dq]"+common_path+"border%206"+http_encode:opt+"[dq]></td>[lf]"
702	write "<td background=[dq]"+common_path+"border%207"+http_encode:opt+"[dq]></td>[lf]"
703	write "<td><img src=[dq]"+common_path+"border%208"+http_encode:opt+"[dq]></td>[lf]"
704	eif round>0
705	var Str opt := " size "+string:round+" color [dq]"+string:c2+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
706	write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
707	write "</tr><tr>[lf]"
708	write "<td><img src=[dq]"+common_path+"corner%202"+http_encode:opt+"[dq]></td>[lf]"
709	write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
710	write "<td><img src=[dq]"+common_path+"corner%203"+http_encode:opt+"[dq]></td>[lf]"
711	write "</tr></table>[lf]"
712
713	tag_html input
714	write label
715	write "<input type=[dq]"+type+"[dq] name=[dq]"+name+"[dq] value=[dq]"+value+"[dq]"
716	if length=defined
717	write " size=[dq]"+string:length+"[dq]"
718	if has:database
719	write (shunt browser="konqueror" " onFocus=[dq]textin(this)[dq] onBlur=[dq]textout(this)[dq]" " onChange=[dq]change(this)[dq]")
720	write_attributes
721	if smart_input and (bgcolor:r<>255 or bgcolor:g<>255 or bgcolor:b<>255)
722	write " style=[dq]border: 0; background-color: #"+string:(shade bgcolor 0.25)+"[dq]"
723	write ">[lf]"
724
725	tag_html textarea
726	write label
727	write "<textarea name=[dq]"+name+"[dq] cols=[dq]"+string:columns+"[dq] rows=[dq]"+string:rows+"[dq] wrap=[dq]off[dq]"
728	if has:database
729	write (shunt browser="konqueror" " onFocus=[dq]textin(this)[dq] onBlur=[dq]textout(this)[dq]" " onChange=[dq]change(this)[dq]")
730	if smart_input and (bgcolor:r<>255 or bgcolor:g<>255 or bgcolor:b<>255)
731	write " style=[dq]border: 0; background-color: #"+string:(shade bgcolor 0.25)+"[dq]"
732	write_attributes
733	write ">"
734	write value
735	write "</textarea>[lf]"
736
737	tag_html select_begin
738	write label
739	write "<select name=[dq]"+name+"[dq]"
740	if has:database
741	write (shunt browser="konqueror" " onFocus=[dq]textin(this)[dq] onBlur=[dq]textout(this)[dq]" " onChange=[dq]change(this)[dq]")
742	if smart_input and (bgcolor:r<>255 or bgcolor:g<>255 or bgcolor:b<>255)
743	write " style=[dq]border-width: 0; background-color: #"+string:(shade bgcolor 0.25)+"[dq]"
744	write ">[lf]"
745	tag_html select_end
746	write "</select>[lf]"
747
748	tag_html option
749	if (attribute select_begin is_active)
750	write "<option"
751	if value=(attribute select_begin value)
752	write " selected"
753	write " value=[dq]"+value+"[dq]"
754	write ">"
755	write label
756	write "</option>[lf]"
757	else
758	if value=(attribute select_begin value)
759	attribute select_begin selected_label := label
760
761	tag_html pdata
762	if has:rows
763	write label+"[lf]"
764	write "<table><tr><td><pre>[lf]"
765	else
766	write label+"<tt>[lf]"
767	write "<pdata path=[dq]"+path+"[dq]>"+value+"</pdata>[lf]"
768	if has:rows
769	write "</pre></td></tr></table>[lf]"
770	else
771	write "</tt>[lf]"
772
773
774	tag_html button
775	if button=""
776	write "<input type=[dq]submit[dq] name=[dq]"+target+"[dq] value=[dq]"+label+"[dq]>[lf]"
777	else
778	var Str action := "[dq]button_pressed('"+target+"')[dq]"
779	var Str event := shunt browser="netscape" "onMouseUp" "onClick"
780	var Str url := common_path+"button"+(http_encode " [dq]"+html_decode:label+"[dq] font [dq]"+face+"[dq] "+string:size+(shunt extend=defined " extend "+string:extend "")+(shunt center " center" "")+" tcolor [dq]"+string:tcolor+"[dq] button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" bcolor [dq]"+string:bcolor+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]")
781	write "<img src=[dq]"+url+"[dq] align=[dq]middle[dq] "+event+"="+action+">"
782	if not has:noeol
783	write "<br>[lf]"
784
785	tag_html icon
786	var Str action := "[dq]button_pressed('"+target+"')[dq]"
787	var Str event := shunt browser="netscape" "onMouseUp" "onClick"
788	var Str url := src
789	if button<>""
790	url := common_path+"icon"+(http_encode " [dq]"+src+"[dq]"+(shunt isize_x=defined " isize "+string:isize_x+" "+string:isize_y "")+(shunt dull=defined " dull "+string:dull "")+" button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" bcolor [dq]"+string:bcolor+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]")
791	write "<img src=[dq]"+url+"[dq] align=[dq]middle[dq] title=[dq]"+help+"[dq] "+event+"="+action+">"
792
793	tag_html_open listing
794	write "<p>[lf]<tt>[lf]"
795	push fixed is_active true
796	tag_html_close listing
797	write "</tt>[lf]</p>[lf]"
798
799
800
801	# input fields
802
803
804	method p set_read_only c
805	arg_rw HtmlPage p ; arg CBool c
806	if c
807	p attribute input is_read_only := true
808
809	method p read_only_begin
810	arg_rw HtmlPage p
811	p:tag_stack mark
812	p push input is_read_only true
813
814	method p read_only_begin c
815	arg_rw HtmlPage p ; arg CBool c
816	p:tag_stack mark
817	if c
818	p push input is_read_only true
819
820	method p read_only_end
821	arg_rw HtmlPage p
822	p:tag_stack rewind
823
824	meta '. read_only' e
825	if e:size<1 or not (e:0 cast HtmlPage)
826	return
827	if e:(e:size-1):ident="{}"
828	if e:size=2
829	e:(e:size-1) compile ?
830	e suckup e:0
831	e add (instruction (the_function '. read_only_begin' HtmlPage) e:0:result)
832	e suckup e:(e:size-1)
833	e add (instruction (the_function '. read_only_end' HtmlPage) e:0:result)
834	e set_void_result
835	eif e:size=3 and (e:1 cast CBool)
836	e:(e:size-1) compile ?
837	e suckup e:0
838	e suckup e:1
839	e add (instruction (the_function '. read_only_begin' HtmlPage CBool) e:0:result e:1:result)
840	e suckup e:(e:size-1)
841	e add (instruction (the_function '. read_only_end' HtmlPage) e:0:result)
842	e set_void_result
843	eif e:size=2 and (e:1 cast CBool)
844	e suckup e:0
845	e suckup e:1
846	e add (instruction (the_function '. set_read_only' HtmlPage CBool) e:0:result e:1:result)
847	e set_void_result
848
849	method p is_read_only -> c
850	arg_rw HtmlPage p ; arg CBool c
851	c := p attribute input is_read_only
852
853	export '. read_only' '. is_read_only'
854
855
856	constant to_index (the_function '. to string' Universal Str -> Str):generic_index
857
858	function to_string data options function -> string
859	arg Universal data ; arg Str options ; arg Function function ; arg Str string
860	indirect
861
862	method p html_input ident data fun label length flags
863	arg_rw HtmlPage p ; arg Str ident ; arg Universal data ; arg Function fun ; arg Str label ; arg Int length ; arg uInt flags
864	p input label label type (shunt (flags .and. 2)=0 "text" "password") name ident value (to_string data "raw" fun) length length
865	if (flags .and. 1)<>0
866	p eol
867
868	if database
869
870	method p data_input d label length flags
871	arg_rw HtmlPage p ; arg Data_ d ; arg Str label ; arg Int length ; arg uInt flags
872	if (d:interface get d addressof:(var Str value) Str)=failure
873	value := ""
874	if (p attribute input is_read_only)
875	p pdata label label path d:path value value
876	else
877	var Str dpath := replace (replace d:path "&#" "(") ";" ")"
878	p input label label type (shunt (flags .and. 2)=0 "text" "password") name "/"+(p:request generate_signature d:path)+dpath value value length length database
879	if (flags .and. 1)<>0
880	p eol
881
882	meta '. input' e
883	if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast Str)
884	return
885	e:2:compile ?
886	var CBool data := database and e:2:is_data
887	if not data
888	var Str name := shunt e:2:size=0 e:2:ident e:2:(e:2:size-1):ident
889	if name=""
890	return
891	var Link:Type type :> e:2:result:type:real_data_type
892	if not (e:2 cast type)
893	return
894	var Pointer:Function function :> type get_generic_method to_index
895	if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
896	return
897	notify_editable_variable e:2
898	var uInt flags := 1
899	var Link:Argument length :> argument constant Int undefined
900	var Int i := 3
901	while i<e:size
902	if e:i:ident="noeol"
903	flags := flags .and. .not. 1
904	i += 1
905	eif e:i:ident="password"
906	flags := flags .or. 2
907	i += 1
908	eif e:i:ident="length" and i+1<e:size and (e:(i+1) cast Int)
909	e suckup e:(i+1)
910	length :> e:(i+1) result
911	i += 2
912	else
913	return
914	e suckup e:0 ; e suckup e:1 ; e suckup e:2
915	if database and data
916	e add (instruction (the_function '. data_input' HtmlPage Data_ Str Int uInt) e:0:result e:2:result e:1:result length (argument constant uInt flags))
917	else
918	e add (instruction (the_function '. html_input' HtmlPage Str Universal Function Str Int uInt) e:0:result (argument constant Str name) e:2:result (argument mapped_constant Function function) e:1:result length (argument constant uInt flags))
919	e set_void_result
920
921
922	method p html_text_input label ident value nx ny
923	arg_rw HtmlPage p ; arg Str label ident value ; arg Int nx ny
924	p textarea label label name ident columns nx rows ny value value
925
926	if database
927
928	method p data_text_input label d nx ny
929	arg_rw HtmlPage p ; arg Str label ; arg Data_ d ; arg Int nx ny
930	if (d:interface get d addressof:(var Str value) Str)=failure
931	value := ""
932	if (p attribute input is_read_only)
933	p pdata label label path d:path value value columns nx rows ny
934	else
935	var Str dpath := replace (replace d:path "&#" "(") ";" ")"
936	p textarea label label name "/"+(p:request generate_signature d:path)+dpath value value columns nx rows ny database
937
938	meta '. text_input' e
939	if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast Str)
940	return
941	e:2:compile ?
942	var CBool data := database and e:2:is_data
943	if not data
944	var Str name := shunt e:2:size=0 e:2:ident e:2:(e:2:size-1):ident
945	if name=""
946	return
947	if not (e:2 cast Str)
948	return
949	notify_editable_variable e:2
950	var Bool eol := true
951	var Link:Argument cols :> argument constant Int undefined
952	var Link:Argument rows :> argument constant Int undefined
953	var Int i := 3
954	while i<e:size
955	if e:i:ident="noeol"
956	eol := false
957	i += 1
958	eif e:i:ident="columns" and i+1<e:size and (e:(i+1) cast Int)
959	e suckup e:(i+1)
960	cols :> e:(i+1) result
961	i += 2
962	eif e:i:ident="rows" and i+1<e:size and (e:(i+1) cast Int)
963	e suckup e:(i+1)
964	rows :> e:(i+1) result
965	i += 2
966	else
967	return
968	e suckup e:0 ; e suckup e:1 ; e suckup e:2
969	if database and data
970	e add (instruction (the_function '. data_text_input' HtmlPage Str Data_ Int Int) e:0:result e:1:result e:2:result cols rows)
971	else
972	e add (instruction (the_function '. html_text_input' HtmlPage Str Str Str Int Int) e:0:result e:1:result (argument constant Str name) e:2:result cols rows)
973	if eol
974	e add (instruction (the_function '. text' HtmlPage Str) e:0:result (argument constant Str "[lf]"))
975	e set_void_result
976
977
978	method p html_select_begin label ident data fun
979	arg_rw HtmlPage p ; arg Str label ; arg Str ident ; arg Universal data ; arg Function fun
980	p:tag_stack mark
981	p push select_begin value html_encode:(to_string data "raw" fun)
982	p push select_begin is_active true
983	p select_begin label label name ident
984
985	method p html_select_end
986	arg_rw HtmlPage p
987	p select_end
988	p:tag_stack rewind
989
990	if database
991
992	method p data_select_begin label d
993	arg_rw HtmlPage p ; arg Str label ; arg Data_ d
994	if (d:interface get d addressof:(var Str value) Str)=failure
995	value := ""
996	p:tag_stack mark
997	p push select_begin value html_encode:value
998	if (p attribute input is_read_only)
999	p push select_begin is_active false
1000	p push select_begin label html_encode:label
1001	p push pdata path d:path
1002	p push select_begin selected_label ""
1003	else
1004	p push select_begin is_active true
1005	var Str dpath := replace (replace d:path "&#" "(") ";" ")"
1006	p select_begin label label name "/"+(p:request generate_signature d:path)+dpath value value database
1007
1008	method p data_select_end
1009	arg_rw HtmlPage p
1010	if (p attribute input is_read_only)
1011	p pdata label html_decode:(p attribute select_begin label) path (p attribute pdata path) value html_decode:(p attribute select_begin selected_label)
1012	else
1013	p select_end database
1014	p:tag_stack rewind
1015
1016	meta '. select' e
1017	if e:size<4 or not (e:0 cast HtmlPage) or not (e:1 cast Str)
1018	return
1019	e:2:compile ?
1020	var CBool data := database and e:2:is_data
1021	if not data
1022	var Str name := shunt e:2:size=0 e:2:ident e:2:(e:2:size-1):ident
1023	if name=""
1024	return
1025	var Link:Type type :> e:2:result:type:real_data_type
1026	if not (e:2 cast type)
1027	return
1028	var Pointer:Function function :> type get_generic_method to_index
1029	if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
1030	return
1031	notify_editable_variable e:2
1032	var Bool eol := true
1033	var Int i := 3
1034	while i<e:size-1
1035	if e:i:ident="noeol"
1036	eol := false
1037	i += 1
1038	else
1039	return
1040	(e e:size-1) compile ?
1041	e suckup e:0 ; e suckup e:1 ; e suckup e:2
1042	if database and data
1043	e add (instruction (the_function '. data_select_begin' HtmlPage Str Data_) e:0:result e:1:result e:2:result)
1044	else
1045	e add (instruction (the_function '. html_select_begin' HtmlPage Str Str Universal Function) e:0:result e:1:result (argument constant Str name) e:2:result (argument mapped_constant Function function))
1046	e suckup (e e:size-1)
1047	if database and data
1048	e add (instruction (the_function '. data_select_end' HtmlPage) e:0:result)
1049	else
1050	e add (instruction (the_function '. html_select_end' HtmlPage) e:0:result)
1051	if eol
1052	e add (instruction (the_function '. text' HtmlPage Str) e:0:result (argument constant Str "[lf]"))
1053	e set_void_result
1054
1055
1056	method p html_file_upload label ident
1057	arg_rw HtmlPage p ; arg Str label ident
1058	p input label label type "file" name "file upload "+ident
1059
1060	meta '. file_upload' e
1061	if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast Str) or not (e:2 cast Str)
1062	return
1063	var Str name := shunt e:2:size=0 e:2:ident e:2:(e:2:size-1):ident
1064	if name=""
1065	return
1066	var Bool eol := true
1067	var Int i := 3
1068	while i<e:size
1069	if e:i:ident="noeol"
1070	eol := false
1071	i += 1
1072	else
1073	return
1074	e suckup e:0 ; e suckup e:1 ; e suckup e:2
1075	e add (instruction (the_function '. html_file_upload' HtmlPage Str Str) e:0:result e:1:result (argument constant Str name))
1076	if eol
1077	e add (instruction (the_function '. text' HtmlPage Str) e:0:result (argument constant Str "[lf]"))
1078	e set_void_result
1079	notify_editable_variable e:2
1080
1081	export '. input' '. text_input' '. select' '. option' '. file_upload'
1082
1083
1084
1085	#  listing
1086
1087
1088	method p listing_text1 l
1089	arg_rw HtmlPage p ; arg Str l
1090	if { var Int i := l search "`" -1 ; i>=0 }
1091	var Int j := i+1
1092	while j<l:len and ( (l:j>="a" and l:j<="z") or  (l:j>="A" and l:j<="Z") or (l:j>="0" and l:j<="9") or l:j="_" )
1093	j += 1
1094	if j=i+1
1095	j := i+2
1096	p text (l 0 i) ; p italic (p text (l i+1 j-i-1)) ; p listing_text1 (l j l:len)
1097	else
1098	p text l
1099
1100	method p listing_text2 l
1101	arg_rw HtmlPage p ; arg Str l
1102	if { var Int i := l search "¤" -1 ; i>=0 }
1103	var Int j := i+1
1104	while j<l:len and ( (l:j>="a" and l:j<="z") or  (l:j>="A" and l:j<="Z") or (l:j>="0" and l:j<="9") or l:j="_" )
1105	j += 1
1106	if j=i+1
1107	j := i+2
1108	p listing_text1 (l 0 i) ; p bold (p text (l i+1 j-i-1)) ; p listing_text2 (l j l:len)
1109	else
1110	p listing_text1 l
1111
1112	method p listing list
1113	arg_rw HtmlPage p ; arg List:Str list
1114	strong_definition
1115	p listing
1116	var Pointer:Str l :> list first
1117	while exists:l
1118	if { var Int i := l option_position "#" -1 ; i<>-1 }
1119	p listing_text2 (l 0 i)
1120	p font color (color hsl 200 75 50)
1121	p italic
1122	p text (l i l:len)
1123	else
1124	p listing_text2 l
1125	p eol
1126	l :> list next l
1127
1128	multiline_keyword listing
1129	export '. listing'
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139