/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    :> http_request 
 65    
 66  method p server -> s 
 67    arg HtmlPage p ; arg_C HttpServer s 
 68    :> p:http_request server 
 69     
 70  method p browser -> b 
 71    arg HtmlPage p ; arg_C Str b 
 72    :> 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      write " " 
 93      write id 
 94      write "=[dq]" 
 95      write value 
 96      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    := p:tag_stack map index 
 104   
 105  meta '' e 
 106    if e:size=and e:1:is_pure_ident 
 107      var Link:TagPrototype :> (pliant_general_dictionary first "pliant current tag"map TagPrototype 
 108      if exists:and (entry_type addressof:t)=TagPrototype 
 109        var Link:TagAttribute :> (t:attributes first e:1:ident) map TagAttribute 
 110        if exists:and (exists a:type) and (e:cast HtmlPage) 
 111          suckup e:0 
 112          var Link:Argument :> argument local (pointerto a:type) 
 113          add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int a:index) r) 
 114          set_result access_read+access_write 
 115        eif t:subpage and e:1:ident=t:subpage_id and (e:cast HtmlPage) 
 116          suckup e:0 
 117          var Link:Argument :> argument local Pointer:Str 
 118          add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int t:subpage_index) r) 
 119          set_result access_read+access_write 
 120   
 121  meta '. attribute' e 
 122    if e:size=and e:1:is_pure_ident and e:2:is_pure_ident 
 123      var Pointer:Arrow :> e:module first ". "+e:1:ident 
 124      while c<>null and entry_type:c<>TagPrototype 
 125        :> e:module next ". "+e:1:ident c 
 126      if c<>null 
 127        var Link:TagPrototype :> map TagPrototype 
 128        var Link:TagAttribute :> (t:attributes first e:2:ident) map TagAttribute 
 129        if exists:and (exists a:type) and (e:cast HtmlPage) 
 130          suckup e:0 
 131          var Link:Argument :> argument local (pointerto a:type) 
 132          add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int a:index) r) 
 133          set_result access_read+access_write 
 134        eif t:subpage and e:2:ident=t:subpage_id and (e:cast HtmlPage) 
 135          suckup e:0 
 136          var Link:Argument :> argument local Pointer:Str 
 137          add (instruction (the_function '. map_attribute' HtmlPage Int -> Address) e:0:result (argument constant Int t:subpage_index) r) 
 138          set_result 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=and e:1:is_pure_ident 
 146      var Link:TagPrototype :> (pliant_general_dictionary first "pliant current tag"map TagPrototype 
 147      if exists:and (entry_type addressof:t)=TagPrototype 
 148        var Link:TagAttribute :> (t:attributes first e:1:ident) map TagAttribute 
 149        if exists:and (exists a:type) and (e:cast HtmlPage) and (e:cast a:type) 
 150          suckup e:0 
 151          suckup e:2 
 152          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          set_void_result 
 154    eif e:size=and e:1:is_pure_ident and e:2:is_pure_ident 
 155      var Pointer:Arrow :> e:module first ". "+e:1:ident 
 156      while c<>null and entry_type:c<>TagPrototype 
 157        :> e:module next ". "+e:1:ident c 
 158      if c<>null 
 159        var Link:TagPrototype :> map TagPrototype 
 160        var Link:TagAttribute :> (t:attributes first e:2:ident) map TagAttribute 
 161        if exists:and (exists a:type) and (e:cast HtmlPage) and (e:cast a:type) 
 162          suckup e:0 
 163          suckup e:3 
 164          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          set_void_result 
 166   
 167  meta has e 
 168    if e:size=and e:0:is_pure_ident 
 169      var Link:TagPrototype :> (pliant_general_dictionary first "pliant current tag"map TagPrototype 
 170      if exists:and (entry_type addressof:t)=TagPrototype 
 171        var Link:TagAttribute :> (t:attributes first e:0:ident) map TagAttribute 
 172        if exists:and a:flag<>0 
 173          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=and (e:cast HtmlPage) and e:1:is_pure_ident and e:2:ident="{}" 
 195      var Pointer:Arrow :> pliant_general_dictionary first ". "+e:1:ident 
 196      while c<>null and entry_type:c<>TagPrototype 
 197        :>  pliant_general_dictionary next ". "+e:1:ident c 
 198      if c<>null and entry_type:c=TagPrototype 
 199        var Link:TagPrototype :> 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          suckup_error ee 
 209        error_pull_record er 
 210        var Link:Function :> (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          suckup e:0 
 219          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          set_void_result 
 221   
 222  meta '. tag_html' e 
 223    tag_html_meta true 
 224   
 225  meta '. tag_html_open' e 
 226    tag_html_meta true 
 227   
 228  meta '. tag_html_close' e 
 229    tag_html_meta 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 :> pliant_general_dictionary first "pliant function" 
 264    if c=null or entry_type:c<>Function 
 265      return 
 266    var Link:Function current_function :> map Function 
 267    var Link:List buttons :> current_function:properties kmap "pliant button types" List 
 268    :> buttons first 
 269    while c<>null 
 270      if entry_type:c=Type 
 271        var Pointer:Type type :> map Type 
 272        for (var Int i) 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      :> buttons next c 
 278   
 279  function notify_button_type t 
 280    arg_rw Type t 
 281    var Pointer:Arrow :> pliant_general_dictionary first "pliant function" 
 282    if c=null or entry_type:c<>Function 
 283      return 
 284    var Link:Function current_function :> 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 :> pliant_general_dictionary first "pliant function" 
 292    if c=null or entry_type:c<>Function 
 293      return 
 294    var Link:Function current_function :> 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 :> pliant_general_dictionary first "pliant function" 
 322    if c<>null and entry_type:c=Function 
 323      current_function :> 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:e:index 
 333    var CBool stay := false 
 334    for (var Int i) 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    add (instruction (the_function html_reset_context Str) ctx) 
 341    for (var Int i) 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          suckup id 
 349          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 :> 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 :> 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          suckup id 
 360          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 "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    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    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<or not (e:cast HtmlPage) 
 423      return 
 424    suckup e:0 
 425    add (instruction (the_function '. tag_begin' HtmlPage) e:0:result) 
 426    var uInt flags := 0 
 427    var Int := 1 ; var Int stop := e:size-(shunt t:body or t:subpage 1 0) 
 428    for (var Int j) t:required:size-1 
 429      var Link:TagAttribute :> (t:attributes first t:required:j) map TagAttribute 
 430      if (exists a:type) 
 431        if i>=stop or not (e:cast a:type) 
 432          return 
 433        suckup e:i 
 434        if a:encode 
 435          if a:type=Str 
 436            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          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 += flag 
 444      += 1 
 445    while i<stop 
 446      if e:i:is_pure_ident 
 447        var Link:TagAttribute :> (t:attributes first e:i:ident) map TagAttribute 
 448        if exists:a 
 449          if a:sequence:size>0 
 450            for (var Int j) a:sequence:size-1 
 451              var Link:TagAttribute :> (t:attributes first a:sequence:j) map TagAttribute 
 452              if not exists:or not (exists b:type) 
 453                return 
 454              += 1 
 455              if i>=stop or not (e:cast b:type) 
 456                return 
 457              suckup e:i 
 458              if b:encode 
 459                if b:type=Str 
 460                  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                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 += flag 
 466          eif (exists a:type) 
 467            += 1 
 468            if i>=stop or not (e:cast a:type) 
 469              return 
 470            suckup e:i 
 471            if a:encode 
 472              if a:type=Str 
 473                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              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 += flag 
 479        else 
 480          += 1 
 481          if i>=stop 
 482            return 
 483          e:compile ? 
 484          var Pointer:Type rt :> e:i:result:type:real_data_type 
 485          e:cast rt ? 
 486          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            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            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>=and e:i:0:is_pure_ident 
 495        var Pointer:Arrow :> e:module first ". "+e:i:0:ident 
 496        while c<>null and entry_type:c<>TagPrototype 
 497          :> e:module next ". "+e:i:0:ident c 
 498        if c=null 
 499          return 
 500        var Int := 1 
 501        while j<e:i:size 
 502          var Link:TagAttribute :> ((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) a:sequence:size-1 
 507              var Link:TagAttribute :> ((map TagPrototype):attributes first a:sequence:k) map TagAttribute 
 508              if not exists:or not (exists b:type) 
 509                return 
 510              += 1 
 511              if j>=e:i:size or not (e:i:cast b:type) 
 512                return 
 513              suckup e:i:j 
 514              if b:encode 
 515                if b:type=Str 
 516                  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                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            += 1 
 523            if j>=e:i:size or not (e:i:cast a:type) 
 524              return 
 525            suckup e:i:j 
 526            if a:encode 
 527              if a:type=Str 
 528                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              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          += 1 
 536      else 
 537        return 
 538      += 1 
 539    if i<>stop 
 540      return 
 541    if t:subpage 
 542      if not (button_expression "" (var Str button_id) (var Link:Argument ctx)) 
 543        return 
 544      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    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:compile ? 
 548      suckup e:i 
 549    if t:tag_close_index<>undefined 
 550      add (instruction (the_function '. tag_close' HtmlPage TagPrototype uInt) e:0:result (argument mapped_constant TagPrototype t) (argument constant uInt flags)) 
 551    else 
 552      add (instruction (the_function '. tag_end' HtmlPage) e:0:result) 
 553    set_void_result 
 554   
 555   
 556  function the_tag e -> t 
 557    arg Expression e ; arg_C TagPrototype t 
 558    var Pointer:Arrow :> pliant_general_dictionary first "pliant current html tag" 
 559    if c<>null and entry_type:c=TagPrototype 
 560      :> map TagPrototype 
 561    else 
 562      :> null map TagPrototype 
 563   
 564  meta sequence e 
 565    if e:size<>or not e:0:is_pure_ident 
 566      return 
 567    var Link:TagPrototype :> the_tag e 
 568    if not exists:t 
 569      return 
 570    if e:size<or not e:0:is_pure_ident 
 571      return 
 572    var Address mark := e:module mark 
 573    var Link:TagAttribute :> new TagAttribute 
 574    pliant_id := e:ident ; html_id := pliant_id 
 575    e:module define "pliant current html sequence" addressof:a 
 576    e:compile 
 577    e:module rewind mark ? 
 578    if (t:attributes first a:pliant_id)=null 
 579      flag := 2^t:attributes:count 
 580      t:attributes insert a:pliant_id true addressof:a 
 581    set_void_result 
 582   
 583  meta attr e 
 584    var Link:TagPrototype :> the_tag e 
 585    if not exists:t 
 586      return 
 587    if e:size<or not e:0:is_pure_ident 
 588      return 
 589    var Link:TagAttribute :> new TagAttribute 
 590    pliant_id := e:ident ; html_id := pliant_id 
 591    var Int := 1 
 592    while i<e:size 
 593      if (exists a:type) and a:type=Str and e:i:ident="encode" 
 594        encode := true ; += 1 
 595      eif e:i:ident="->" and i+1<e:size and e:(i+1):ident<>"" 
 596        html_id := e:(i+1) ident ; += 2 
 597      eif (e:constant Type)<>null 
 598        type :> (e:constant Type) map Type ; += 1 
 599      eif (exists a:type) and (e:constant a:type)<>null 
 600        default := entry_new a:type 
 601        a:type copy_instance (e:constant a:type) a:default 
 602        += 1 
 603      else 
 604        return 
 605    if (t:attributes first a:pliant_id)=null 
 606      flag := 2^t:attributes:count 
 607      t:attributes insert a:pliant_id true addressof:a 
 608      var Pointer:Arrow :> pliant_general_dictionary first "pliant current html sequence" 
 609      if c<>null and entry_type:c=TagAttribute 
 610        (map TagAttribute) sequence += pliant_id 
 611    set_void_result 
 612   
 613  meta subpage e 
 614    var Link:TagPrototype :> the_tag:e 
 615    if exists:and e:size=and e:0:ident<>"" 
 616      subpage := true 
 617      subpage_id := e:ident 
 618      set_void_result 
 619   
 620  meta body e 
 621    var Link:TagPrototype :> the_tag e 
 622    if exists:and e:size=0 
 623      body := true 
 624      set_void_result 
 625   
 626  meta newline e 
 627    var Link:TagPrototype :> the_tag e 
 628    if exists:and e:size=0 
 629      newline := true 
 630      set_void_result 
 631   
 632  meta hidden e 
 633    var Link:TagPrototype :> the_tag e 
 634    if exists:and e:size=0 
 635      hidden := true 
 636      set_void_result 
 637   
 638  method p default_tag_hook t flags 
 639    arg_rw HtmlPage p ; arg TagPrototype t ; arg uInt flags 
 640    write "<" 
 641    write t:html_id 
 642    write_attributes 
 643    if t:newline 
 644      write ">[lf]" 
 645    else 
 646      write ">" 
 647   
 648  method p default_tag_open_hook t flags 
 649    arg_rw HtmlPage p ; arg TagPrototype t ; arg uInt flags 
 650    write "<" 
 651    write t:html_id 
 652    write_attributes 
 653    write ">" 
 654   
 655  method p default_tag_close_hook t flags 
 656    arg_rw HtmlPage p ; arg TagPrototype t ; arg uInt flags 
 657    write "</" 
 658    write t:html_id 
 659    # p write_attributes 
 660    if t:newline 
 661      write ">[lf]" 
 662    else 
 663      write ">" 
 664   
 665  method t record_attributes 
 666    arg_rw TagPrototype t 
 667    each t:attributes type TagAttribute 
 668      if a:index=undefined 
 669        if (exists a:type) 
 670          index := tag_stack_slot a:type a:default 
 671        else 
 672          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<or not e:0:is_pure_ident 
 680      return 
 681    var Pointer:Arrow :> pliant_general_dictionary first ". "+e:0:ident 
 682    while c<>null and entry_type:c<>TagPrototype 
 683      :>  pliant_general_dictionary next ". "+e:0:ident c 
 684    var Link:TagPrototype t 
 685    if c<>null 
 686      :> map TagPrototype 
 687    else 
 688      :> new TagPrototype 
 689    if pliant_debugging_level>=1 
 690      position := e:position 
 691    pliant_id := e:ident ; html_id := pliant_id 
 692    var Int := 1 
 693    while i<e:size-1 
 694      if e:i:ident="->" 
 695        if i+1<e:size and e:(i+1):ident<>"" 
 696          html_id := e:(i+1) ident 
 697          += 2 
 698        else 
 699          return 
 700      eif e:i:is_pure_ident 
 701        if c=null 
 702          required += e:i:ident 
 703        += 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) t:required:size-1 
 711      if (t:attributes first t:required:j)=null 
 712        return 
 713    record_attributes 
 714    if c=null 
 715      if t:body 
 716        var Pointer:Function :> the_function '. default_tag_open_hook' HtmlPage TagPrototype uInt 
 717        tag_open_index := tag_stack_slot Pointer:Function (addressof Pointer:Function f) 
 718        var Pointer:Function :> the_function '. default_tag_close_hook' HtmlPage TagPrototype uInt 
 719        tag_close_index := tag_stack_slot Pointer:Function (addressof Pointer:Function f) 
 720      else 
 721        var Pointer:Function :> the_function '. default_tag_hook' HtmlPage TagPrototype uInt 
 722        tag_open_index := tag_stack_slot Pointer:Function (addressof Pointer:Function f) 
 723        tag_close_index := undefined 
 724      if t:subpage 
 725        subpage_index := tag_stack_slot Str null 
 726      define ". "+e:0:ident addressof:e:module:actual 
 727    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) a:sequence:size-1 
 744        var Link:TagAttribute :> (tag_attr_dict first tag_id+"/"+a:sequence:k) map TagAttribute 
 745        status := page parse_parameter values 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 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 := 0 
 778      while { while (opt 1)=" " { += 1 } ; i<opt:len } 
 779        var Int := i+((opt opt:len) search "[lf]" opt:len-i) 
 780        if opt:i<>"#" and ((opt j-i) parse any:(var Str tag_id) _ any:(var Str all)) 
 781          while { while (all 0 1)=" " { all := all 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 :> (tag_attr_dict first tag_id+"/"+attr_id) map TagAttribute 
 784              status := page parse_parameter values 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        := 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