/pliant/protocol/http/style/common.pli
1	module "/pliant/language/compiler.pli"
2	module "/pliant/language/context.pli"
3	module "/pliant/language/stream.pli"
4	module "/pliant/admin/file.pli"
5	module "/pliant/protocol/http/server.pli"
6	module "/pliant/admin/md5.pli"
7	submodule "/pliant/graphic/color/rgb888.pli"
8	submodule "/pliant/protocol/http/stack.pli"
9
10	public
11	constant database true
12
13	if database
14	submodule "/pliant/storage/database.pli"
15	module "/pliant/language/data/string_cast.pli"
16
17
18	constant to_index (the_function '. to string' Universal Str -> Str):generic_index
19
20	function to_string data options function -> string
21	arg Universal data ; arg Str options ; arg Function function ; arg Str string
22	indirect
23
24	public
25	gvar Dictionary tag_attr_dict
26	gvar Sem tag_attr_dict_sem
27
28	type TagAttribute
29	field Int index <- undefined ; field Link:Type type ; field Arrow default
30	field Str pliant_id ; field Str html_id
31	field CBool encode <- false
32	field uInt flag <- 0
33	field Array:Str sequence
34
35	type TagPrototype
36	if pliant_debugging_level>=1
37	field ListingPosition position
38	field Int tag_open_index tag_close_index
39	field Str pliant_id html_id
40	field Dictionary attributes
41	field Array:Str required
42	field CBool subpage <- false ; field Int subpage_index ; field Str subpage_id
43	field CBool body <- false
44	field CBool hidden <- false
45	field CBool newline <- false
46
47	export TagPrototype
48
49	if pliant_debugging_level>=1
50
51	'pliant watch' TagPrototype true := "000080"
52
53	method ht 'get position' -> pos
54	oarg TagPrototype ht; arg ListingPosition pos
55	return ht:position
56
57
58
59	#  styling
60
61
62	method p request -> r
63	arg HtmlPage p ; arg_C HttpRequest r
64	r :> p http_request
65
66	method p server -> s
67	arg HtmlPage p ; arg_C HttpServer s
68	s :> p:http_request server
69
70	method p browser -> b
71	arg HtmlPage p ; arg_C Str b
72	b :> p:http_request browser_model
73
74	method p variable name -> value
75	arg HtmlPage p ; arg Str name value
76	if ("&"+p:request:form+"&"+p:request:encoded_options+"&" parse any (pattern "&"+name+"=") any:value "&" any)
77	value := replace http_decode:value "[cr][lf]" "[lf]"
78	else
79	value := ""
80
81	export '. request' '. server' '. browser' '. variable'
82
83
84	method p write raw
85	arg_rw HtmlPage p ; arg Str raw
86	p:http_stream writechars raw
87
88	method p write_attributes
89	arg_rw HtmlPage p
90	p:tag_stack walk (var Str id) (var Str value)
91	while (p:tag_stack another id value)
92	p write " "
93	p write id
94	p write "=[dq]"
95	p write value
96	p write "[dq]"
97
98	export '. write' '. write_attributes'
99
100
101	method p map_attribute index -> a
102	arg HtmlPage p ; arg Int index ; arg Address a
103	a := p:tag_stack map index
104
105	meta '' e
106	if e:size=2 and e:1:is_pure_ident
107	var Link:TagPrototype t :> (pliant_general_dictionary first "pliant current tag") map TagPrototype
108	if exists:t and (entry_type addressof:t)=TagPrototype
109	var Link:TagAttribute a :> (t:attributes first e:1:ident) map TagAttribute
110	if exists:a and (exists a:type) and (e:0 cast HtmlPage)
111	e suckup e:0
112	var Link:Argument r :> argument local (pointerto a:type)
113	e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int a:index) r)
114	e set_result r access_read+access_write
115	eif t:subpage and e:1:ident=t:subpage_id and (e:0 cast HtmlPage)
116	e suckup e:0
117	var Link:Argument r :> argument local Pointer:Str
118	e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int t:subpage_index) r)
119	e set_result r access_read+access_write
120
121	meta '. attribute' e
122	if e:size=3 and e:1:is_pure_ident and e:2:is_pure_ident
123	var Pointer:Arrow c :> e:module first ". "+e:1:ident
124	while c<>null and entry_type:c<>TagPrototype
125	c :> e:module next ". "+e:1:ident c
126	if c<>null
127	var Link:TagPrototype t :> c map TagPrototype
128	var Link:TagAttribute a :> (t:attributes first e:2:ident) map TagAttribute
129	if exists:a and (exists a:type) and (e:0 cast HtmlPage)
130	e suckup e:0
131	var Link:Argument r :> argument local (pointerto a:type)
132	e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int a:index) r)
133	e set_result r access_read+access_write
134	eif t:subpage and e:2:ident=t:subpage_id and (e:0 cast HtmlPage)
135	e suckup e:0
136	var Link:Argument r :> argument local Pointer:Str
137	e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int t:subpage_index) r)
138	e set_result r access_read+access_write
139
140	method p push_attribute index value type
141	arg_rw HtmlPage p ; arg Int index ; arg Universal value ; arg Type type
142	p:tag_stack push index addressof:value type
143
144	meta '. push' e
145	if e:size=3 and e:1:is_pure_ident
146	var Link:TagPrototype t :> (pliant_general_dictionary first "pliant current tag") map TagPrototype
147	if exists:t and (entry_type addressof:t)=TagPrototype
148	var Link:TagAttribute a :> (t:attributes first e:1:ident) map TagAttribute
149	if exists:a and (exists a:type) and (e:0 cast HtmlPage) and (e:2 cast a:type)
150	e suckup e:0
151	e suckup e:2
152	e add (instruction (the_function '. push_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:2:result (argument mapped_constant Type a:type))
153	e set_void_result
154	eif e:size=4 and e:1:is_pure_ident and e:2:is_pure_ident
155	var Pointer:Arrow c :> e:module first ". "+e:1:ident
156	while c<>null and entry_type:c<>TagPrototype
157	c :> e:module next ". "+e:1:ident c
158	if c<>null
159	var Link:TagPrototype t :> c map TagPrototype
160	var Link:TagAttribute a :> (t:attributes first e:2:ident) map TagAttribute
161	if exists:a and (exists a:type) and (e:0 cast HtmlPage) and (e:3 cast a:type)
162	e suckup e:0
163	e suckup e:3
164	e add (instruction (the_function '. push_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:3:result (argument mapped_constant Type a:type))
165	e set_void_result
166
167	meta has e
168	if e:size=1 and e:0:is_pure_ident
169	var Link:TagPrototype t :> (pliant_general_dictionary first "pliant current tag") map TagPrototype
170	if exists:t and (entry_type addressof:t)=TagPrototype
171	var Link:TagAttribute a :> (t:attributes first e:0:ident) map TagAttribute
172	if exists:a and a:flag<>0
173	e compile_as (expression immediat (flags .and. flag)<>0 substitute flag (expression constant a:flag near e))
174
175	export '. attribute' '' '. push' has
176
177
178	method p tag_hook_prototype tag flags fun
179	arg_rw HtmlPage p ; arg TagPrototype tag ; arg uInt flags ; arg Function fun
180	indirect
181
182	method p record_tag_hook index hook
183	arg_rw HtmlPage p ; arg Int index ; arg Function hook
184	var Pointer:Function ptr :> hook
185	p:tag_stack push index (addressof Pointer:Function ptr) Pointer:Function
186
187	named_expression tag_html_prototype
188	method page 'pliant style tag function' tag flags
189	arg_rw HtmlPage page ; arg TagPrototype tag ; arg uInt flags
190	body
191
192	function tag_html_meta e open
193	arg_rw Expression e ; arg CBool open
194	if e:size=3 and (e:0 cast HtmlPage) and e:1:is_pure_ident and e:2:ident="{}"
195	var Pointer:Arrow c :> pliant_general_dictionary first ". "+e:1:ident
196	while c<>null and entry_type:c<>TagPrototype
197	c :>  pliant_general_dictionary next ". "+e:1:ident c
198	if c<>null and entry_type:c=TagPrototype
199	var Link:TagPrototype t :> c map TagPrototype
200	var Address mark := e:module mark
201	e:module define "pliant current tag" addressof:t
202	var Link:Expression ee :> expression duplicate tag_html_prototype substitute body e:2 near e
203	error_push_record (var ErrorRecord er) error_filter_all
204	ee compile
205	if er:id<>error_id_noerror
206	console er:message eol
207	er id := error_id_noerror
208	e suckup_error ee
209	error_pull_record er
210	var Link:Function f :> (pliant_general_dictionary first ". pliant style tag function") map Function
211	e:module rewind mark
212	if exists:f
213	var Link:Expression body :> null map Expression
214	var Bool ok := track_expression tag_html_prototype "body" ee body
215	check ok
216	copy_properties body e:2
217	pliant_general_dictionary remove ". pliant style tag function" addressof:f
218	e suckup e:0
219	e add (instruction (the_function '. record_tag_hook' HtmlPage Int Function) e:0:result (argument constant Int (shunt open t:tag_open_index t:tag_close_index)) (argument mapped_constant Function f))
220	e set_void_result
221
222	meta '. tag_html' e
223	tag_html_meta e true
224
225	meta '. tag_html_open' e
226	tag_html_meta e true
227
228	meta '. tag_html_close' e
229	tag_html_meta e false
230
231	export '. tag_html' '. tag_html_open' '. tag_html_close'
232
233
234
235	#  subpages helpers
236
237
238	function new_button_id e -> id
239	arg Str id ; arg_rw Expression e
240	if false
241	var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
242	part get_function
243	if c=null or entry_type:c<>Function
244	return ""
245	var Link:Function current_function :> c map Function
246	if (current_function:name parse word:"frozen" word:"expression" any)
247	c :> pliant_general_dictionary next "pliant function" c
248	restart get_function
249	var Pointer:Int counter :> current_function:properties kmap "pliant style standard button counter" Int 0
250	var Pointer:Int counter :> e:module:properties kmap "pliant style standard button counter" Int 0
251	counter += 1
252	var Str name := replace e:module:name " (internals)" ""
253	var Str filename := replace name ".html" ".page"
254	var Str timestamp := string (file_query filename standard):datetime
255	timestamp := replace timestamp " " ""
256	timestamp := replace timestamp "/" ""
257	timestamp := replace timestamp ":" ""
258	timestamp := replace timestamp "?" ""
259	id := name+"/"+timestamp+"/"+string:counter
260
261
262	function update_button_types
263	var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
264	if c=null or entry_type:c<>Function
265	return
266	var Link:Function current_function :> c map Function
267	var Link:List buttons :> current_function:properties kmap "pliant button types" List
268	c :> buttons first
269	while c<>null
270	if entry_type:c=Type
271	var Pointer:Type type :> c map Type
272	for (var Int i) 0 type:nb_fields-1
273	var Pointer:TypeField tf :> type field i
274	if tf:name<>"page"
275	if ((current_function:properties kmap "pliant editable variables" Dictionary) first tf:name)<>null
276	tf:properties kmap "pliant editable" CBool := true
277	c :> buttons next c
278
279	function notify_button_type t
280	arg_rw Type t
281	var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
282	if c=null or entry_type:c<>Function
283	return
284	var Link:Function current_function :> c map Function
285	var Link:List buttons :> current_function:properties kmap "pliant button types" List
286	buttons append addressof:t
287	update_button_types
288
289	function notify_editable_variable e
290	arg_rw Expression e
291	var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
292	if c=null or entry_type:c<>Function
293	return
294	var Link:Function current_function :> c map Function
295	if e:result:name<>""
296	(current_function:properties kmap "pliant editable variables" Dictionary) kmap e:result:name CBool := true
297	update_button_types
298
299
300	function html_reset_context context
301	arg_w Str context
302	context := ""
303
304	function html_add_to_context context ident data fun
305	arg_rw Str context ; arg Str ident ; arg Universal data ; arg Function fun
306	context += "&"+ident+"="+http_encode:(to_string data "raw" fun)
307
308	if database
309
310	function data_add_to_context context ident data
311	arg_rw Str context ; arg Str ident ; arg Data_ data
312	context += "&"+ident+"="+(http_encode data:path)
313
314	named_expression button_framework
315	body
316
317	function button_expression e options button_id ctx -> ok
318	arg_rw Expression e ; arg Str options ; arg_w Str button_id ; arg_w Link:Argument ctx ; arg CBool ok
319	ok := false
320	var Link:Function current_function
321	var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
322	if c<>null and entry_type:c=Function
323	current_function :> c map Function
324	else
325	current_function :> new Function
326	var Int index := options option "index" Int e:size-1
327	var Link:Expression body :> expression duplicate button_framework substitute body e:index near e:index
328	var List expressions byaddress ; var List functions ; var Link:Type type
329	expressions append addressof:body
330	byaddress append addressof:(new Ident (cast "page" Ident))
331	body freeze expressions byaddress functions type ?
332	copy_properties body:0 e:index
333	var CBool stay := false
334	for (var Int i) 0 body:size-1
335	if body:i:is_pure_ident and (body:i:ident="reload_page" or body:i:ident="goto_backward" or body:i:ident="close")
336	stay := true
337	if (stay or (options option "stay")) and not (options option "nostay")
338	type:properties kmap "http stay" Void := void
339	ctx :> argument local Str
340	e add (instruction (the_function html_reset_context Str) ctx)
341	for (var Int i) 0 type:nb_fields-1
342	var Pointer:TypeField tf :> type field i
343	if tf:name<>"page"
344	var Link:Expression id :> expression ident tf:name near body
345	id compile ?
346	var CBool data := database and id:is_data
347	if database and data
348	e suckup id
349	e add (instruction (the_function data_add_to_context Str Str Data_) ctx (argument constant Str tf:name) id:result)
350	eif ((current_function:properties kmap "pliant editable variables" Dictionary) first tf:name)=null
351	var Pointer:Type t :> id:result:type real_data_type
352	if not (id cast t)
353	error error_id_compile "Cannot cast '"+tf:name+"' to a real data that could be passed back when the button is pressed."
354	return
355	var Pointer:Function fun :> t get_generic_method to_index
356	if not exists:fun or fun=(the_function '. to string' Universal Str -> Str)
357	error error_id_compile "Cannot convert '"+tf:name+"' to a string that could be passed back when the button is pressed."
358	return
359	e suckup id
360	e add (instruction (the_function html_add_to_context Str Str Universal Function) ctx (argument constant Str tf:name) id:result (argument mapped_constant Function fun))
361	button_id := new_button_id e
362	var Link:Function sub_function :> functions:first map Function
363	# var Pointer:Arrow c :> current_function:properties first "style"
364	# while c<>null
365	#   if entry_type:c=Str
366	#     sub_function:properties insert "style" false c
367	#   c :> current_function:properties next "style" c
368	http_record_dynamic_page button_id sub_function type
369	notify_button_type type
370	ok := true
371
372	export new_button_id notify_editable_variable notify_button_type button_expression
373
374
375
376	#  new tags helper
377
378
379	method p tag_begin
380	arg_rw HtmlPage p
381	p:tag_stack mark
382
383	method p set_attribute index value type
384	arg_rw HtmlPage p ; arg Int index ; arg Universal value ; arg Type type
385	p:tag_stack push index addressof:value type
386
387	method p encode_attribute index value
388	arg_rw HtmlPage p ; arg Int index ; arg Str value
389	var Str encoded := html_encode value
390	p:tag_stack push index addressof:encoded Str
391
392	method p set_extra id value
393	arg_rw HtmlPage p ; arg Str id value
394	p:tag_stack set id value
395
396	method p set_extra id u f
397	arg_rw HtmlPage p ; arg Str id ; arg Universal u ; arg Function f
398	p:tag_stack set id (to_string u "html" f)
399
400	method p set_subpage index id context
401	arg_rw HtmlPage p ; arg Int index ; arg Str id context
402	var Str url := p:button_header+id+"*"+(p:request cipher context)+"*"+(p:request generate_signature id+" "+context)
403	p:tag_stack push index addressof:url Str
404
405	method p tag_open tag flags
406	arg_rw HtmlPage p ; arg TagPrototype tag ; arg uInt flags
407	p tag_hook_prototype tag flags ((p:tag_stack map tag:tag_open_index) map Pointer:Function)
408
409	method p tag_close tag flags
410	arg_rw HtmlPage p ; arg TagPrototype tag ; arg uInt flags
411	p tag_hook_prototype tag flags ((p:tag_stack map tag:tag_close_index) map Pointer:Function)
412	p:tag_stack rewind
413
414	method p tag_end
415	arg_rw HtmlPage p
416	p:tag_stack rewind
417
418	function active_type t access e
419	arg TagPrototype t ; arg Int access ; arg_rw Expression e
420	if t:hidden
421	return
422	if e:size<1 or not (e:0 cast HtmlPage)
423	return
424	e suckup e:0
425	e add (instruction (the_function '. tag_begin' HtmlPage) e:0:result)
426	var uInt flags := 0
427	var Int i := 1 ; var Int stop := e:size-(shunt t:body or t:subpage 1 0)
428	for (var Int j) 0 t:required:size-1
429	var Link:TagAttribute a :> (t:attributes first t:required:j) map TagAttribute
430	if (exists a:type)
431	if i>=stop or not (e:i cast a:type)
432	return
433	e suckup e:i
434	if a:encode
435	if a:type=Str
436	e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:result)
437	else
438	return
439	else
440	e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:i:result (argument mapped_constant Type a:type))
441	eif i>=stop or e:i:ident<>a:pliant_id
442	return
443	flags += a flag
444	i += 1
445	while i<stop
446	if e:i:is_pure_ident
447	var Link:TagAttribute a :> (t:attributes first e:i:ident) map TagAttribute
448	if exists:a
449	if a:sequence:size>0
450	for (var Int j) 0 a:sequence:size-1
451	var Link:TagAttribute b :> (t:attributes first a:sequence:j) map TagAttribute
452	if not exists:b or not (exists b:type)
453	return
454	i += 1
455	if i>=stop or not (e:i cast b:type)
456	return
457	e suckup e:i
458	if b:encode
459	if b:type=Str
460	e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int b:index) e:i:result)
461	else
462	return
463	else
464	e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int b:index) e:i:result (argument mapped_constant Type b:type))
465	flags += b flag
466	eif (exists a:type)
467	i += 1
468	if i>=stop or not (e:i cast a:type)
469	return
470	e suckup e:i
471	if a:encode
472	if a:type=Str
473	e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:result)
474	else
475	return
476	else
477	e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:i:result (argument mapped_constant Type a:type))
478	flags += a flag
479	else
480	i += 1
481	if i>=stop
482	return
483	e:i compile ?
484	var Pointer:Type rt :> e:i:result:type:real_data_type
485	e:i cast rt ?
486	e suckup e:i
487	if rt<>Str
488	var Link:Function function :> rt get_generic_method to_index
489	if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
490	return
491	e add (instruction (the_function '. set_extra' HtmlPage Str Universal Function) e:0:result (argument constant Str e:(i-1):ident) e:i:result (argument mapped_constant Function function))
492	else
493	e add (instruction (the_function '. set_extra' HtmlPage Str Str) e:0:result (argument constant Str e:(i-1):ident) e:i:result)
494	eif e:i:ident="style" and e:i:size>=3 and e:i:0:is_pure_ident
495	var Pointer:Arrow c :> e:module first ". "+e:i:0:ident
496	while c<>null and entry_type:c<>TagPrototype
497	c :> e:module next ". "+e:i:0:ident c
498	if c=null
499	return
500	var Int j := 1
501	while j<e:i:size
502	var Link:TagAttribute a :> ((c map TagPrototype):attributes first e:i:j:ident) map TagAttribute
503	if not exists:a
504	return
505	if a:sequence:size>0
506	for (var Int k) 0 a:sequence:size-1
507	var Link:TagAttribute b :> ((c map TagPrototype):attributes first a:sequence:k) map TagAttribute
508	if not exists:b or not (exists b:type)
509	return
510	j += 1
511	if j>=e:i:size or not (e:i:j cast b:type)
512	return
513	e suckup e:i:j
514	if b:encode
515	if b:type=Str
516	e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int b:index) e:i:j:result)
517	else
518	return
519	else
520	e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int b:index) e:i:j:result (argument mapped_constant Type b:type))
521	eif (exists a:type)
522	j += 1
523	if j>=e:i:size or not (e:i:j cast a:type)
524	return
525	e suckup e:i:j
526	if a:encode
527	if a:type=Str
528	e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:j:result)
529	else
530	return
531	else
532	e add (instruction (the_function '. set_attribute' HtmlPage Int Universal Type) e:0:result (argument constant Int a:index) e:i:j:result (argument mapped_constant Type a:type))
533	else
534	return
535	j += 1
536	else
537	return
538	i += 1
539	if i<>stop
540	return
541	if t:subpage
542	if not (button_expression e "" (var Str button_id) (var Link:Argument ctx))
543	return
544	e add (instruction (the_function '. set_subpage' HtmlPage Int Str Str) e:0:result (argument constant Int t:subpage_index) (argument constant Str button_id) ctx)
545	e add (instruction (the_function '. tag_open' HtmlPage TagPrototype uInt) e:0:result (argument mapped_constant TagPrototype t) (argument constant uInt flags))
546	if t:body
547	e:i compile ?
548	e suckup e:i
549	if t:tag_close_index<>undefined
550	e add (instruction (the_function '. tag_close' HtmlPage TagPrototype uInt) e:0:result (argument mapped_constant TagPrototype t) (argument constant uInt flags))
551	else
552	e add (instruction (the_function '. tag_end' HtmlPage) e:0:result)
553	e set_void_result
554
555
556	function the_tag e -> t
557	arg Expression e ; arg_C TagPrototype t
558	var Pointer:Arrow c :> pliant_general_dictionary first "pliant current html tag"
559	if c<>null and entry_type:c=TagPrototype
560	t :> c map TagPrototype
561	else
562	t :> null map TagPrototype
563
564	meta sequence e
565	if e:size<>2 or not e:0:is_pure_ident
566	return
567	var Link:TagPrototype t :> the_tag e
568	if not exists:t
569	return
570	if e:size<1 or not e:0:is_pure_ident
571	return
572	var Address mark := e:module mark
573	var Link:TagAttribute a :> new TagAttribute
574	a pliant_id := e:0 ident ; a html_id := a pliant_id
575	e:module define "pliant current html sequence" addressof:a
576	e:1 compile
577	e:module rewind mark ?
578	if (t:attributes first a:pliant_id)=null
579	a flag := 2^t:attributes:count
580	t:attributes insert a:pliant_id true addressof:a
581	e set_void_result
582
583	meta attr e
584	var Link:TagPrototype t :> the_tag e
585	if not exists:t
586	return
587	if e:size<1 or not e:0:is_pure_ident
588	return
589	var Link:TagAttribute a :> new TagAttribute
590	a pliant_id := e:0 ident ; a html_id := a pliant_id
591	var Int i := 1
592	while i<e:size
593	if (exists a:type) and a:type=Str and e:i:ident="encode"
594	a encode := true ; i += 1
595	eif e:i:ident="->" and i+1<e:size and e:(i+1):ident<>""
596	a html_id := e:(i+1) ident ; i += 2
597	eif (e:i constant Type)<>null
598	a type :> (e:i constant Type) map Type ; i += 1
599	eif (exists a:type) and (e:i constant a:type)<>null
600	a default := entry_new a:type
601	a:type copy_instance (e:i constant a:type) a:default
602	i += 1
603	else
604	return
605	if (t:attributes first a:pliant_id)=null
606	a flag := 2^t:attributes:count
607	t:attributes insert a:pliant_id true addressof:a
608	var Pointer:Arrow c :> pliant_general_dictionary first "pliant current html sequence"
609	if c<>null and entry_type:c=TagAttribute
610	(c map TagAttribute) sequence += a pliant_id
611	e set_void_result
612
613	meta subpage e
614	var Link:TagPrototype t :> the_tag:e
615	if exists:t and e:size=1 and e:0:ident<>""
616	t subpage := true
617	t subpage_id := e:0 ident
618	e set_void_result
619
620	meta body e
621	var Link:TagPrototype t :> the_tag e
622	if exists:t and e:size=0
623	t body := true
624	e set_void_result
625
626	meta newline e
627	var Link:TagPrototype t :> the_tag e
628	if exists:t and e:size=0
629	t newline := true
630	e set_void_result
631
632	meta hidden e
633	var Link:TagPrototype t :> the_tag e
634	if exists:t and e:size=0
635	t hidden := true
636	e set_void_result
637
638	method p default_tag_hook t flags
639	arg_rw HtmlPage p ; arg TagPrototype t ; arg uInt flags
640	p write "<"
641	p write t:html_id
642	p write_attributes
643	if t:newline
644	p write ">[lf]"
645	else
646	p write ">"
647
648	method p default_tag_open_hook t flags
649	arg_rw HtmlPage p ; arg TagPrototype t ; arg uInt flags
650	p write "<"
651	p write t:html_id
652	p write_attributes
653	p write ">"
654
655	method p default_tag_close_hook t flags
656	arg_rw HtmlPage p ; arg TagPrototype t ; arg uInt flags
657	p write "</"
658	p write t:html_id
659	# p write_attributes
660	if t:newline
661	p write ">[lf]"
662	else
663	p write ">"
664
665	method t record_attributes
666	arg_rw TagPrototype t
667	each a t:attributes type TagAttribute
668	if a:index=undefined
669	if (exists a:type)
670	a index := tag_stack_slot a:type a:default
671	else
672	a index := -1
673	tag_attr_dict_sem request
674	tag_attr_dict insert t:pliant_id+"/"+a:pliant_id true addressof:a
675	tag_attr_dict_sem release
676
677
678	meta tag_prototype e
679	if e:size<2 or not e:0:is_pure_ident
680	return
681	var Pointer:Arrow c :> pliant_general_dictionary first ". "+e:0:ident
682	while c<>null and entry_type:c<>TagPrototype
683	c :>  pliant_general_dictionary next ". "+e:0:ident c
684	var Link:TagPrototype t
685	if c<>null
686	t :> c map TagPrototype
687	else
688	t :> new TagPrototype
689	if pliant_debugging_level>=1
690	t position := e:position
691	t pliant_id := e:0 ident ; t html_id := t pliant_id
692	var Int i := 1
693	while i<e:size-1
694	if e:i:ident="->"
695	if i+1<e:size and e:(i+1):ident<>""
696	t html_id := e:(i+1) ident
697	i += 2
698	else
699	return
700	eif e:i:is_pure_ident
701	if c=null
702	t required += e:i:ident
703	i += 1
704	else
705	return
706	var Address mark := e:module mark
707	e:module define "pliant current html tag" addressof:t
708	e:(e:size-1):compile ?
709	e:module rewind mark
710	for (var Int j) 0 t:required:size-1
711	if (t:attributes first t:required:j)=null
712	return
713	t record_attributes
714	if c=null
715	if t:body
716	var Pointer:Function f :> the_function '. default_tag_open_hook' HtmlPage TagPrototype uInt
717	t tag_open_index := tag_stack_slot Pointer:Function (addressof Pointer:Function f)
718	var Pointer:Function f :> the_function '. default_tag_close_hook' HtmlPage TagPrototype uInt
719	t tag_close_index := tag_stack_slot Pointer:Function (addressof Pointer:Function f)
720	else
721	var Pointer:Function f :> the_function '. default_tag_hook' HtmlPage TagPrototype uInt
722	t tag_open_index := tag_stack_slot Pointer:Function (addressof Pointer:Function f)
723	t tag_close_index := undefined
724	if t:subpage
725	t subpage_index := tag_stack_slot Str null
726	e define ". "+e:0:ident addressof:t e:module:actual
727	e set_void_result
728
729	export tag_prototype sequence attr subpage body newline hidden
730
731
732	constant from_index (the_function '. from string' Universal Str Str CBool Int Int -> Status):generic_index
733
734	function from_string data string options may_skip skiped offset function -> status
735	arg Universal data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Function function ; arg Status status
736	indirect
737
738	method page parse_parameter values a attr_id tag_id -> status
739	arg_rw HtmlPage page ; arg_rw Str values ; arg TagAttribute a ; arg Str attr_id tag_id ; arg ExtendedStatus status
740	if not exists:a
741	return (failure "Unknown attribute '"+attr_id+"' in tag '"+tag_id+"'")
742	if a:sequence:size>0
743	for (var Int k) 0 a:sequence:size-1
744	var Link:TagAttribute b :> (tag_attr_dict first tag_id+"/"+a:sequence:k) map TagAttribute
745	status := page parse_parameter values b attr_id tag_id
746	if status=failure
747	return
748	return
749	if not (exists a:type)
750	return (failure "Unsupported attribute '"+attr_id+"' in tag '"+tag_id+"'")
751	var Pointer:Function fun :> a:type get_generic_method from_index
752	if not exists:fun or fun=(the_function '. from string' Universal Str Str CBool Int Int -> Status)
753	return (failure "Don't know how to parse attribute '"+attr_id+"' in tag '"+tag_id+"'")
754	if (values parse "(" any:(var Str value) ")" any:(var Str remain))
755	value := string value
756	status := page parse_parameter value a attr_id tag_id
757	values := remain
758	return
759	var Arrow obj := entry_new a:type
760	status := from_string (obj map Universal) values "" true (var Int skiped) (var Int offset) fun
761	if status=failure
762	var Status retry := from_string (obj map Universal) values "raw" true (var Int skiped) (var Int offset) fun
763	if retry=success and ((values skiped offset-skiped) search " " -1)=(-1)
764	status := success
765	if status=success
766	page:tag_stack push a:index obj a:type
767	values := values offset values:len
768	else
769	status := failure "Incorrect value provided for attribute '"+attr_id+"' in tag '"+tag_id+"'[lf]"
770
771	method page tag_attributes_setup
772	arg_rw HtmlPage page
773	var ExtendedStatus status := success
774	tag_attr_dict_sem rd_request
775	part parse
776	var Pointer:Str opt :> page:http_request:style_options
777	var Int i := 0
778	while { while (opt i 1)=" " { i += 1 } ; i<opt:len }
779	var Int j := i+((opt i opt:len) search "[lf]" opt:len-i)
780	if opt:i<>"#" and ((opt i j-i) parse any:(var Str tag_id) _ any:(var Str all))
781	while { while (all 0 1)=" " { all := all 1 all:len } ; if (all 0 1)="#" { all := "" } ; all<>"" }
782	if (all parse any:(var Str attr_id) _ any:(var Str values))
783	var Link:TagAttribute a :> (tag_attr_dict first tag_id+"/"+attr_id) map TagAttribute
784	status := page parse_parameter values a attr_id tag_id
785	else
786	status := failure "No attribute provided for tag '"+tag_id+"'"
787	if status=failure
788	leave parse
789	all := values
790	i := j+1
791	tag_attr_dict_sem rd_release
792	page:http_request style_options := shunt status=success "" status:message
793	if status=failure
794	console status:message eol
795
796	export '. tag_attributes_setup'
797
798
799
800
801
802
803
804
805
806
807