module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
module "/pliant/protocol/http/server.pli"
module "/pliant/admin/md5.pli"
submodule "/pliant/graphic/color/rgb888.pli"
submodule "/pliant/protocol/http/stack.pli"
public
constant database true
if database
submodule "/pliant/appli/database.pli"
module "/pliant/language/data/string_cast.pli"
constant to_index (the_function '. to string' Universal Str -> Str):generic_index
function to_string data options function -> string
arg Universal data ; arg Str options ; arg Function function ; arg Str string
indirect
public
gvar Dictionary html_attr_dict
gvar Sem html_attr_dict_sem
type HtmlAttribute
field Int index <- undefined ; field Link:Type type ; field Arrow default
field Str pliant_id ; field Str html_id
field CBool encode <- false
field uInt flag <- 0
field Array:Str sequence
type HtmlTag
if pliant_debugging_level>=1
field ListingPosition position
field Int tag_open_index tag_close_index
field Str pliant_id html_id
field Dictionary attributes
field Array:Str required
field CBool subpage <- false ; field Int subpage_index ; field Str subpage_id
field CBool body <- false
field CBool hidden <- false
field CBool newline <- false
export HtmlTag
if pliant_debugging_level>=1
'pliant watch' HtmlTag true := "000080"
method ht 'get position' -> pos
oarg HtmlTag ht; arg ListingPosition pos
return ht:position
#---------------------------------------------------------------------------
# styling
method p request -> r
arg HtmlPage p ; arg_C HttpRequest r
r :> p http_request
method p server -> s
arg HtmlPage p ; arg_C HttpServer s
s :> p:http_request server
method p browser -> b
arg HtmlPage p ; arg_C Str b
b :> p:http_request browser_model
method p variable name -> value
arg HtmlPage p ; arg Str name value
if ("&"+p:request:form+"&"+p:request:encoded_options+"&" parse any (pattern "&"+name+"=") any:value "&" any)
value := replace http_decode:value "[cr][lf]" "[lf]"
else
value := ""
export '. request' '. server' '. browser' '. variable'
method p write raw
arg_rw HtmlPage p ; arg Str raw
p:http_stream writechars raw
method p write_attributes
arg_rw HtmlPage p
p:html_stack walk (var Str id) (var Str value)
while (p:html_stack another id value)
p write " "
p write id
p write "=[dq]"
p write value
p write "[dq]"
export '. write' '. write_attributes'
method p map_attribute index -> a
arg HtmlPage p ; arg Int index ; arg Address a
a := p:html_stack map index
meta '' e
if e:size=2 and e:1:is_pure_ident
var Link:HtmlTag t :> (pliant_general_dictionary first "pliant current tag") map HtmlTag
if exists:t and (entry_type addressof:t)=HtmlTag
var Link:HtmlAttribute a :> (t:attributes first e:1:ident) map HtmlAttribute
if exists:a and (exists a:type) and (e:0 cast HtmlPage)
e suckup e:0
var Link:Argument r :> argument local (pointerto a:type)
e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int a:index) r)
e set_result r access_read+access_write
eif t:subpage and e:1:ident=t:subpage_id and (e:0 cast HtmlPage)
e suckup e:0
var Link:Argument r :> argument local Pointer:Str
e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int t:subpage_index) r)
e set_result r access_read+access_write
meta '. attribute' e
if e:size=3 and e:1:is_pure_ident and e:2:is_pure_ident
var Pointer:Arrow c :> e:module first ". "+e:1:ident
while c<>null and entry_type:c<>HtmlTag
c :> e:module next ". "+e:1:ident c
if c<>null
var Link:HtmlTag t :> c map HtmlTag
var Link:HtmlAttribute a :> (t:attributes first e:2:ident) map HtmlAttribute
if exists:a and (exists a:type) and (e:0 cast HtmlPage)
e suckup e:0
var Link:Argument r :> argument local (pointerto a:type)
e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int a:index) r)
e set_result r access_read+access_write
eif t:subpage and e:2:ident=t:subpage_id and (e:0 cast HtmlPage)
e suckup e:0
var Link:Argument r :> argument local Pointer:Str
e add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int t:subpage_index) r)
e set_result r access_read+access_write
method p push_attribute index value type
arg_rw HtmlPage p ; arg Int index ; arg Universal value ; arg Type type
p:html_stack push index addressof:value type
meta '. push' e
if e:size=3 and e:1:is_pure_ident
var Link:HtmlTag t :> (pliant_general_dictionary first "pliant current tag") map HtmlTag
if exists:t and (entry_type addressof:t)=HtmlTag
var Link:HtmlAttribute a :> (t:attributes first e:1:ident) map HtmlAttribute
if exists:a and (exists a:type) and (e:0 cast HtmlPage) and (e:2 cast a:type)
e suckup e:0
e suckup e:2
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))
e set_void_result
eif e:size=4 and e:1:is_pure_ident and e:2:is_pure_ident
var Pointer:Arrow c :> e:module first ". "+e:1:ident
while c<>null and entry_type:c<>HtmlTag
c :> e:module next ". "+e:1:ident c
if c<>null
var Link:HtmlTag t :> c map HtmlTag
var Link:HtmlAttribute a :> (t:attributes first e:2:ident) map HtmlAttribute
if exists:a and (exists a:type) and (e:0 cast HtmlPage) and (e:3 cast a:type)
e suckup e:0
e suckup e:3
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))
e set_void_result
meta has e
if e:size=1 and e:0:is_pure_ident
var Link:HtmlTag t :> (pliant_general_dictionary first "pliant current tag") map HtmlTag
if exists:t and (entry_type addressof:t)=HtmlTag
var Link:HtmlAttribute a :> (t:attributes first e:0:ident) map HtmlAttribute
if exists:a and a:flag<>0
e compile_as (expression immediat (flags .and. flag)<>0 substitute flag (expression constant a:flag near e))
export '. attribute' '' '. push' has
method p tag_hook_prototype tag flags fun
arg_rw HtmlPage p ; arg HtmlTag tag ; arg uInt flags ; arg Function fun
indirect
method p record_tag_hook index hook
arg_rw HtmlPage p ; arg Int index ; arg Function hook
var Pointer:Function ptr :> hook
p:html_stack push index (addressof Pointer:Function ptr) Link:Function
named_expression style_tag_prototype
method page 'pliant style tag function' tag flags
arg_rw HtmlPage page ; arg HtmlTag tag ; arg uInt flags
body
function style_tag_meta e open
arg_rw Expression e ; arg CBool open
if e:size=3 and (e:0 cast HtmlPage) and e:1:is_pure_ident and e:2:ident="{}"
var Pointer:Arrow c :> pliant_general_dictionary first ". "+e:1:ident
while c<>null and entry_type:c<>HtmlTag
c :> pliant_general_dictionary next ". "+e:1:ident c
if c<>null and entry_type:c=HtmlTag
var Link:HtmlTag t :> c map HtmlTag
var Address mark := e:module mark
e:module define "pliant current tag" addressof:t
var Link:Expression ee :> expression duplicate style_tag_prototype substitute body e:2 near e
error_push_record (var ErrorRecord er) error_filter_all
ee compile
if er:id<>error_id_noerror
console er:message eol
er id := error_id_noerror
e suckup_error ee
error_pull_record er
var Link:Function f :> (pliant_general_dictionary first ". pliant style tag function") map Function
e:module rewind mark
if exists:f
var Link:Expression body :> null map Expression
var Bool ok := track_expression style_tag_prototype "body" ee body
check ok
copy_properties body e:2
pliant_general_dictionary remove ". pliant style tag function" addressof:f
e suckup e:0
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))
e set_void_result
meta '. style_tag' e
style_tag_meta e true
meta '. style_open' e
style_tag_meta e true
meta '. style_close' e
style_tag_meta e false
export '. style_tag' '. style_open' '. style_close'
#---------------------------------------------------------------------------
# subpages helpers
function new_button_id e -> id
arg Str id ; arg_rw Expression e
if false
var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
part get_function
if c=null or entry_type:c<>Function
return ""
var Link:Function current_function :> c map Function
if (current_function:name parse word:"frozen" word:"expression" any)
c :> pliant_general_dictionary next "pliant function" c
restart get_function
var Pointer:Int counter :> current_function:properties kmap "pliant style standard button counter" Int 0
var Pointer:Int counter :> e:module:properties kmap "pliant style standard button counter" Int 0
counter += 1
var Str name := replace e:module:name " (internals)" ""
var Str filename := replace name ".html" ".page"
var Str timestamp := string (file_query filename standard):datetime
timestamp := replace timestamp " " ""
timestamp := replace timestamp "/" ""
timestamp := replace timestamp ":" ""
timestamp := replace timestamp "?" ""
id := name+"/"+timestamp+"/"+string:counter
function update_button_types
var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
if c=null or entry_type:c<>Function
return
var Link:Function current_function :> c map Function
var Link:List buttons :> current_function:properties kmap "pliant button types" List
c :> buttons first
while c<>null
if entry_type:c=Type
var Pointer:Type type :> c map Type
for (var Int i) 0 type:nb_fields-1
var Pointer:TypeField tf :> type field i
if tf:name<>"page"
if ((current_function:properties kmap "pliant editable variables" Dictionary) first tf:name)<>null
tf:properties kmap "pliant editable" CBool := true
c :> buttons next c
function notify_button_type t
arg_rw Type t
var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
if c=null or entry_type:c<>Function
return
var Link:Function current_function :> c map Function
var Link:List buttons :> current_function:properties kmap "pliant button types" List
buttons append addressof:t
update_button_types
function notify_editable_variable e
arg_rw Expression e
var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
if c=null or entry_type:c<>Function
return
var Link:Function current_function :> c map Function
if e:result:name<>""
(current_function:properties kmap "pliant editable variables" Dictionary) kmap e:result:name CBool := true
update_button_types
function html_reset_context context
arg_w Str context
context := ""
function html_add_to_context context ident data fun
arg_rw Str context ; arg Str ident ; arg Universal data ; arg Function fun
context += "&"+ident+"="+http_encode:(to_string data "raw" fun)
if database
function data_add_to_context context ident data
arg_rw Str context ; arg Str ident ; arg Data_ data
context += "&"+ident+"="+(http_encode data:path)
named_expression button_framework
body
function button_expression e options button_id ctx -> ok
arg_rw Expression e ; arg Str options ; arg_w Str button_id ; arg_w Link:Argument ctx ; arg CBool ok
ok := false
var Link:Function current_function
var Pointer:Arrow c :> pliant_general_dictionary first "pliant function"
if c<>null and entry_type:c=Function
current_function :> c map Function
else
current_function :> new Function
var Int index := options option "index" Int e:size-1
var Link:Expression body :> expression duplicate button_framework substitute body e:index near e:index
var List expressions byaddress ; var List functions ; var Link:Type type
expressions append addressof:body
byaddress append addressof:(new Ident (cast "page" Ident))
body freeze expressions byaddress functions type ?
copy_properties body:0 e:index
var CBool stay := false
for (var Int i) 0 body:size-1
if body:i:is_pure_ident and (body:i:ident="reload_page" or body:i:ident="goto_backward" or body:i:ident="close")
stay := true
if (stay or (options option "stay")) and not (options option "nostay")
type:properties kmap "http stay" Void := void
ctx :> argument local Str
e add (instruction (the_function html_reset_context Str) ctx)
for (var Int i) 0 type:nb_fields-1
var Pointer:TypeField tf :> type field i
if tf:name<>"page"
var Link:Expression id :> expression ident tf:name near body
id compile ?
var CBool data := database and id:is_data
if database and data
e suckup id
e add (instruction (the_function data_add_to_context Str Str Data_) ctx (argument constant Str tf:name) id:result)
eif ((current_function:properties kmap "pliant editable variables" Dictionary) first tf:name)=null
var Pointer:Type t :> id:result:type real_data_type
if not (id cast t)
error error_id_compile "Cannot cast '"+tf:name+"' to a real data that could be passed back when the button is pressed."
return
var Pointer:Function fun :> t get_generic_method to_index
if not exists:fun or fun=(the_function '. to string' Universal Str -> Str)
error error_id_compile "Cannot convert '"+tf:name+"' to a string that could be passed back when the button is pressed."
return
e suckup id
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))
button_id := new_button_id e
var Link:Function sub_function :> functions:first map Function
# var Pointer:Arrow c :> current_function:properties first "style"
# while c<>null
# if entry_type:c=Str
# sub_function:properties insert "style" false c
# c :> current_function:properties next "style" c
http_record_dynamic_page button_id e:position sub_function type
notify_button_type type
ok := true
export new_button_id notify_editable_variable notify_button_type button_expression
#---------------------------------------------------------------------------
# new tags helper
method p tag_begin
arg_rw HtmlPage p
p:html_stack mark
method p set_attribute index value type
arg_rw HtmlPage p ; arg Int index ; arg Universal value ; arg Type type
p:html_stack push index addressof:value type
method p encode_attribute index value
arg_rw HtmlPage p ; arg Int index ; arg Str value
var Str encoded := html_encode value
p:html_stack push index addressof:encoded Str
method p set_extra id value
arg_rw HtmlPage p ; arg Str id value
p:html_stack set id value
method p set_extra id u f
arg_rw HtmlPage p ; arg Str id ; arg Universal u ; arg Function f
p:html_stack set id (to_string u "html" f)
method p set_subpage index id context
arg_rw HtmlPage p ; arg Int index ; arg Str id context
|
var Str url := "button-0-0-"+id+"-"+(p:request cipher context)+"-"+(p:request generate_signature id+" "+context)
|
var Str url := "button*0*0*"+id+"*"+(p:request cipher context)+"*"+(p:request generate_signature id+" "+context)
|
p:html_stack push index addressof:url Str
method p tag_open tag flags
arg_rw HtmlPage p ; arg HtmlTag tag ; arg uInt flags
p tag_hook_prototype tag flags ((p:html_stack map tag:tag_open_index) map Pointer:Function)
method p tag_close tag flags
arg_rw HtmlPage p ; arg HtmlTag tag ; arg uInt flags
p tag_hook_prototype tag flags ((p:html_stack map tag:tag_close_index) map Pointer:Function)
p:html_stack rewind
method p tag_end
arg_rw HtmlPage p
p:html_stack rewind
function active_type t access e
arg HtmlTag t ; arg Int access ; arg_rw Expression e
if t:hidden
return
if e:size<1 or not (e:0 cast HtmlPage)
return
e suckup e:0
e add (instruction (the_function '. tag_begin' HtmlPage) e:0:result)
var uInt flags := 0
var Int i := 1 ; var Int stop := e:size-(shunt t:body or t:subpage 1 0)
for (var Int j) 0 t:required:size-1
var Link:HtmlAttribute a :> (t:attributes first t:required:j) map HtmlAttribute
if (exists a:type)
if i>=stop or not (e:i cast a:type)
return
e suckup e:i
if a:encode
if a:type=Str
e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:result)
else
return
else
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))
eif i>=stop or e:i:ident<>a:pliant_id
return
flags += a flag
i += 1
while i<stop
if e:i:is_pure_ident
var Link:HtmlAttribute a :> (t:attributes first e:i:ident) map HtmlAttribute
if exists:a
if a:sequence:size>0
for (var Int j) 0 a:sequence:size-1
var Link:HtmlAttribute b :> (t:attributes first a:sequence:j) map HtmlAttribute
if not exists:b or not (exists b:type)
return
i += 1
if i>=stop or not (e:i cast b:type)
return
e suckup e:i
if b:encode
if b:type=Str
e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int b:index) e:i:result)
else
return
else
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))
flags += b flag
eif (exists a:type)
i += 1
if i>=stop or not (e:i cast a:type)
return
e suckup e:i
if a:encode
if a:type=Str
e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:result)
else
return
else
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))
flags += a flag
else
i += 1
if i>=stop
return
e:i compile ?
var Pointer:Type rt :> e:i:result:type:real_data_type
e:i cast rt ?
e suckup e:i
if rt<>Str
var Link:Function function :> rt get_generic_method to_index
if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
return
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))
else
e add (instruction (the_function '. set_extra' HtmlPage Str Str) e:0:result (argument constant Str e:(i-1):ident) e:i:result)
eif e:i:ident="style" and e:i:size>=3 and e:i:0:is_pure_ident
var Pointer:Arrow c :> e:module first ". "+e:i:0:ident
while c<>null and entry_type:c<>HtmlTag
c :> e:module next ". "+e:i:0:ident c
if c=null
return
var Int j := 1
while j<e:i:size
var Link:HtmlAttribute a :> ((c map HtmlTag):attributes first e:i:j:ident) map HtmlAttribute
if not exists:a
return
if a:sequence:size>0
for (var Int k) 0 a:sequence:size-1
var Link:HtmlAttribute b :> ((c map HtmlTag):attributes first a:sequence:k) map HtmlAttribute
if not exists:b or not (exists b:type)
return
j += 1
if j>=e:i:size or not (e:i:j cast b:type)
return
e suckup e:i:j
if b:encode
if b:type=Str
e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int b:index) e:i:j:result)
else
return
else
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))
eif (exists a:type)
j += 1
if j>=e:i:size or not (e:i:j cast a:type)
return
e suckup e:i:j
if a:encode
if a:type=Str
e add (instruction (the_function '. encode_attribute' HtmlPage Int Str) e:0:result (argument constant Int a:index) e:i:j:result)
else
return
else
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))
else
return
j += 1
else
return
i += 1
if i<>stop
return
if t:subpage
if not (button_expression e "" (var Str button_id) (var Link:Argument ctx))
return
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)
e add (instruction (the_function '. tag_open' HtmlPage HtmlTag uInt) e:0:result (argument mapped_constant HtmlTag t) (argument constant uInt flags))
if t:body
e:i compile ?
e suckup e:i
if t:tag_close_index<>undefined
e add (instruction (the_function '. tag_close' HtmlPage HtmlTag uInt) e:0:result (argument mapped_constant HtmlTag t) (argument constant uInt flags))
else
e add (instruction (the_function '. tag_end' HtmlPage) e:0:result)
e set_void_result
function the_tag e -> t
arg Expression e ; arg_C HtmlTag t
var Pointer:Arrow c :> pliant_general_dictionary first "pliant current html tag"
if c<>null and entry_type:c=HtmlTag
t :> c map HtmlTag
else
t :> null map HtmlTag
meta sequence e
if e:size<>2 or not e:0:is_pure_ident
return
var Link:HtmlTag t :> the_tag e
if not exists:t
return
if e:size<1 or not e:0:is_pure_ident
return
var Address mark := e:module mark
var Link:HtmlAttribute a :> new HtmlAttribute
a pliant_id := e:0 ident ; a html_id := a pliant_id
e:module define "pliant current html sequence" addressof:a
e:1 compile
e:module rewind mark ?
if (t:attributes first a:pliant_id)=null
a flag := 2^t:attributes:count
t:attributes insert a:pliant_id true addressof:a
e set_void_result
meta attr e
var Link:HtmlTag t :> the_tag e
if not exists:t
return
if e:size<1 or not e:0:is_pure_ident
return
var Link:HtmlAttribute a :> new HtmlAttribute
a pliant_id := e:0 ident ; a html_id := a pliant_id
var Int i := 1
while i<e:size
if (exists a:type) and a:type=Str and e:i:ident="encode"
a encode := true ; i += 1
eif e:i:ident="->" and i+1<e:size and e:(i+1):ident<>""
a html_id := e:(i+1) ident ; i += 2
eif (e:i constant Type)<>null
a type :> (e:i constant Type) map Type ; i += 1
eif (exists a:type) and (e:i constant a:type)<>null
a default := entry_new a:type
a:type copy_instance (e:i constant a:type) a:default
i += 1
else
return
if (t:attributes first a:pliant_id)=null
a flag := 2^t:attributes:count
t:attributes insert a:pliant_id true addressof:a
var Pointer:Arrow c :> pliant_general_dictionary first "pliant current html sequence"
if c<>null and entry_type:c=HtmlAttribute
(c map HtmlAttribute) sequence += a pliant_id
e set_void_result
meta subpage e
var Link:HtmlTag t :> the_tag:e
if exists:t and e:size=1 and e:0:ident<>""
t subpage := true
t subpage_id := e:0 ident
e set_void_result
meta body e
var Link:HtmlTag t :> the_tag:e
if exists:t and e:size=0
t body := true
e set_void_result
meta newline e
var Link:HtmlTag t :> the_tag:e
if exists:t and e:size=0
t newline := true
e set_void_result
meta hidden e
var Link:HtmlTag t :> the_tag:e
if exists:t and e:size=0
t hidden := true
e set_void_result
method p default_tag_hook t flags
arg_rw HtmlPage p ; arg HtmlTag t ; arg uInt flags
p write "<"
p write t:html_id
p write_attributes
if t:newline
p write ">[lf]"
else
p write ">"
method p default_tag_open_hook t flags
arg_rw HtmlPage p ; arg HtmlTag t ; arg uInt flags
p write "<"
p write t:html_id
p write_attributes
p write ">"
method p default_tag_close_hook t flags
arg_rw HtmlPage p ; arg HtmlTag t ; arg uInt flags
p write "</"
p write t:html_id
# p write_attributes
if t:newline
p write ">[lf]"
else
p write ">"
method t record_attributes
arg_rw HtmlTag t
each a t:attributes type HtmlAttribute
if a:index=undefined
if (exists a:type)
a index := html_stack_slot a:type a:default
else
a index := -1
html_attr_dict_sem request
html_attr_dict insert t:pliant_id+"/"+a:pliant_id true addressof:a
html_attr_dict_sem release
meta html_tag e
if e:size<2 or not e:0:is_pure_ident
return
var Pointer:Arrow c :> pliant_general_dictionary first ". "+e:0:ident
while c<>null and entry_type:c<>HtmlTag
c :> pliant_general_dictionary next ". "+e:0:ident c
var Link:HtmlTag t
if c<>null
t :> c map HtmlTag
else
t :> new HtmlTag
if pliant_debugging_level>=1
t position := e:position
t pliant_id := e:0 ident ; t html_id := t pliant_id
var Int i := 1
while i<e:size-1
if e:i:ident="->"
if i+1<e:size and e:(i+1):ident<>""
t html_id := e:(i+1) ident
i += 2
else
return
eif e:i:is_pure_ident
if c=null
t required += e:i:ident
i += 1
else
return
var Address mark := e:module mark
e:module define "pliant current html tag" addressof:t
e:(e:size-1):compile ?
e:module rewind mark
for (var Int j) 0 t:required:size-1
if (t:attributes first t:required:j)=null
return
t record_attributes
if c=null
if t:body
var Pointer:Function f :> the_function '. default_tag_open_hook' HtmlPage HtmlTag uInt
t tag_open_index := html_stack_slot Pointer:Function (addressof Pointer:Function f)
var Pointer:Function f :> the_function '. default_tag_close_hook' HtmlPage HtmlTag uInt
t tag_close_index := html_stack_slot Pointer:Function (addressof Pointer:Function f)
else
var Pointer:Function f :> the_function '. default_tag_hook' HtmlPage HtmlTag uInt
t tag_open_index := html_stack_slot Pointer:Function (addressof Pointer:Function f)
t tag_close_index := undefined
if t:subpage
t subpage_index := html_stack_slot Str null
e define ". "+e:0:ident addressof:t e:module:actual
e set_void_result
export html_tag sequence attr subpage body newline hidden
constant from_index (the_function '. from string' Universal Str Str CBool Int Int -> Status):generic_index
function from_string data string options may_skip skiped offset function -> status
arg Universal data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Function function ; arg Status status
indirect
method page parse_parameter values a attr_id tag_id -> status
arg_rw HtmlPage page ; arg_rw Str values ; arg HtmlAttribute a ; arg Str attr_id tag_id ; arg ExtendedStatus status
if not exists:a
return (failure "Unknown attribute '"+attr_id+"' in tag '"+tag_id+"'")
if a:sequence:size>0
for (var Int k) 0 a:sequence:size-1
var Link:HtmlAttribute b :> (html_attr_dict first tag_id+"/"+a:sequence:k) map HtmlAttribute
status := page parse_parameter values b attr_id tag_id
if status=failure
return
return
if not (exists a:type)
return (failure "Unsupported attribute '"+attr_id+"' in tag '"+tag_id+"'")
var Pointer:Function fun :> a:type get_generic_method from_index
if not exists:fun or fun=(the_function '. from string' Universal Str Str CBool Int Int -> Status)
return (failure "Don't know how to parse attribute '"+attr_id+"' in tag '"+tag_id+"'")
if (values parse "(" any:(var Str value) ")" any:(var Str remain))
value := string value
status := page parse_parameter value a attr_id tag_id
values := remain
return
var Arrow obj := entry_new a:type
status := from_string (obj map Universal) values "" true (var Int skiped) (var Int offset) fun
if status=failure
var Status retry := from_string (obj map Universal) values "raw" true (var Int skiped) (var Int offset) fun
if retry=success and ((values skiped offset-skiped) search " " -1)=(-1)
status := success
if status=success
page:html_stack push a:index obj a:type
values := values offset values:len
else
status := failure "Incorrect value provided for attribute '"+attr_id+"' in tag '"+tag_id+"'[lf]"
method page html_attributes_setup
arg_rw HtmlPage page
var ExtendedStatus status := success
html_attr_dict_sem rd_request
part parse
var Pointer:Str opt :> page:http_request:style_options
var Int i := 0
while { while (opt i 1)=" " { i += 1 } ; i<opt:len }
var Int j := i+((opt i opt:len) search "[lf]" opt:len-i)
if opt:i<>"#" and ((opt i j-i) parse any:(var Str tag_id) _ any:(var Str all))
while { while (all 0 1)=" " { all := all 1 all:len } ; if (all 0 1)="#" { all := "" } ; all<>"" }
if (all parse any:(var Str attr_id) _ any:(var Str values))
var Link:HtmlAttribute a :> (html_attr_dict first tag_id+"/"+attr_id) map HtmlAttribute
status := page parse_parameter values a attr_id tag_id
else
status := failure "No attribute provided for tag '"+tag_id+"'"
if status=failure
leave parse
all := values
i := j+1
html_attr_dict_sem rd_release
page:http_request style_options := shunt status=success "" status:message
if status=failure
console status:message eol
export '. html_attributes_setup'
|