Patch title: Release 89 bulk changes
Abstract:
File: /protocol/http/style/default.style
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/parser.pli"
module "/pliant/language/parser/multiline.pli"
module "/pliant/protocol/http/server.pli"
module "/pliant/admin/md5.pli"
module "common.pli"
submodule "common.style"
submodule "/pliant/graphic/color/rgb888.pli"

constant smart_input false
constant common_path "/common/"+string:pliant_release_number+"/"


#---------------------------------------------------------------------------
#  new Pliant instructions


public

  html_tag common
    attr bgcolor ColorRGB888 (color rgb 255 255 255)
    attr body Str
    attr url_icon Str
    attr has_html4 CBool true
    attr head Str
    attr css Str
    attr header Str
    attr footer Str
    hidden

  html_tag page_header
    void
  html_tag page_footer
    void

  html_tag link label target
    attr label Str encode
    attr target Str
    attr section Str
    attr options Str
    attr no_extension

  html_tag section name
    attr name Str encode

  html_tag note label
    attr label Str
    subpage target

  html_tag image src -> img
    attr src Str

  html_tag how target
    attr target Str
    attr section Str
    attr options Str
    attr no_extension

  html_tag title label
    attr label Str encode
    attr logo Str
    attr link Str
    attr small
    sequence font
      attr face Str
      attr size Float 36
      attr ssr Bool false # 'ssr' stands for 'server side rendering'
    attr color ColorRGB888 (color rgb 0 0 0)
    attr button Str
    sequence bsize
      attr bsize_x Float undefined
      attr bsize_y Float undefined
    sequence margin
      attr margin_left Float undefined
      attr margin_top Float undefined
      attr margin_right Float undefined
      attr margin_bottom Float undefined
    attr round Int 0
    attr bgcolor ColorRGB888 (color rgb 255 255 255) 

  html_tag chapter label
    attr label Str encode

  html_tag header label
    attr label Str encode
    attr level Int 0
    body
    sequence font
      attr face Str
      attr size Float 36
      attr ssr Bool false
    sequence factor
      attr factor1 Float 4/5
      attr factor2 Float 3/5
      attr factor3 Float 2/5
    attr color ColorRGB888 (color rgb 0 0 0)
    attr tabulation Int 3
    sequence shade
      attr shade1 Float 0
      attr shade2 Float 0
      attr shade3 Float 0
    attr button Str
    sequence bsize
      attr bsize_x Float undefined
      attr bsize_y Float undefined
    sequence margin
      attr margin_left Float undefined
      attr margin_top Float undefined
      attr margin_right Float undefined
      attr margin_bottom Float undefined
    attr round Int 0
    attr bgcolor ColorRGB888 (color rgb 255 255 255) 
    sequence bgshade
      attr bgshade1 Float 0
      attr bgshade2 Float 0
      attr bgshade3 Float 0

  method p header h
    arg_rw HtmlPage p ; arg Str h
    p header h
      void

  html_tag para -> p
    body
    newline

  html_tag eol -> br
    newline

  html_tag center
    body

  html_tag bold -> b
    body

  html_tag italic -> i
    body

  html_tag big
    body

  html_tag small
    body

  html_tag fixed
    body
    attr is_active CBool false

  html_tag font
    sequence font
      attr face Str
      attr size Float 12
      attr ssr Bool false
    attr color ColorRGB888 (color rgb 0 0 0)
    attr linebreak CBool true
    body

  html_tag highlight label
    attr label Str encode
    attr size Str "-2"
    attr color ColorRGB888 (color rgb 255 0 0)

  html_tag list -> ul
    body
    newline

  html_tag item -> li
    body
    newline

  html_tag table
    attr columns Int undefined
    attr padding Int 4 -> cellpadding
    attr spacing Int 0 -> cellspacing
    attr border Int 1
    body
    newline
    attr cursor Int undefined

  html_tag row -> tr
    body
    newline

  html_tag cell -> td
    attr header
    attr color ColorRGB888 -> bgcolor
    body
    newline
    attr header_color ColorRGB888 (color rgb 208 208 208)

  html_tag box
    attr header Str encode
    attr color ColorRGB888 (color rgb 255 255 255)
    attr transparent
    attr button Str
    sequence bsize
      attr bsize_x Float undefined
      attr bsize_y Float undefined
    sequence margin
      attr margin_left Float undefined
      attr margin_top Float undefined
      attr margin_right Float undefined
      attr margin_bottom Float undefined
    attr round Int 0
    attr width Str
    attr left
    attr right
    sequence hfont
      attr hface Str
      attr hsize Float 36
      attr hssr Bool false
    attr hcolor ColorRGB888 (color rgb 0 0 0)
    body
    newline

  html_tag button label
    attr label Str encode
    attr noeol
    subpage target
    sequence font
      attr face Str
      attr size Float
      attr ssr Bool false
    attr tcolor ColorRGB888 (color rgb 0 0 0)
    attr extend Float undefined
    attr center CBool true
    attr button Str
    sequence bsize
      attr bsize_x Float undefined
      attr bsize_y Float undefined
    sequence margin
      attr margin_left Float undefined
      attr margin_top Float undefined
      attr margin_right Float undefined
      attr margin_bottom Float undefined
    attr bcolor ColorRGB888

  html_tag icon src
    attr src Str
    attr help Str encode
    subpage target
    sequence isize
      attr isize_x Float undefined
      attr isize_y Float undefined
    attr dull Float undefined
    attr button Str
    sequence bsize
      attr bsize_x Float undefined
      attr bsize_y Float undefined
    sequence margin
      attr margin_left Float undefined
      attr margin_top Float undefined
      attr margin_right Float undefined
      attr margin_bottom Float undefined
    attr bcolor ColorRGB888


  html_tag input
    attr label Str encode
    attr type Str
    attr name Str
    attr value Str encode
    attr length Int undefined -> size
    attr database
    attr is_read_only CBool false

  html_tag textarea
    attr label Str encode
    attr name Str
    attr value Str
    attr columns Int -> cols
    attr rows Int
    attr database

  html_tag select_begin
    attr label Str encode
    attr name Str
    attr value Str encode
    attr database
    attr is_active CBool false
    attr selected_label Str
  html_tag select_end
    attr database

  html_tag option label value
    attr label Str encode
    attr value Str encode

  html_tag pdata
    attr label Str encode
    attr path Str
    attr value Str encode
    attr length Int
    attr columns Int
    attr rows Int

  html_tag listing
    body


#---------------------------------------------------------------------------
#  style setup


method p standard_html_hook text
  arg_rw HtmlPage p ; arg Str text
  p:http_stream writechars text

method p standard_text_hook text
  arg_rw HtmlPage p ; arg Str text
  if (p attribute font ssr)
    var Str extra := " font [dq]"+(p attribute font face)+"[dq] "+string:(p attribute font size)+" color [dq]"+string:(p attribute font color)+"[dq] bgcolor [dq]"+string:(p attribute common bgcolor)+"[dq]"
    var Str sentence := html_decode text
    if not (p attribute font linebreak)
      p:http_stream writechars "<img src=[dq]/common/"+(http_encode "text "+string:sentence+extra)+"[dq] border=[dq]0[dq] align=[dq]middle[dq]>"
      p:http_stream writechars "<img src=[dq]"+common_path+(http_encode "text "+string:sentence+extra)+"[dq] border=[dq]0[dq] align=[dq]middle[dq]>"
    else
      while sentence<>""
        if (sentence 0 1)<>" "
          var Int i := sentence search " " sentence:len
          p:http_stream writechars "<img src=[dq]/common/"+(http_encode "text "+string:(sentence 0 i)+extra)+"[dq] border=[dq]0[dq] align=[dq]middle[dq]>"
          p:http_stream writechars "<img src=[dq]"+common_path+(http_encode "text "+string:(sentence 0 i)+extra)+"[dq] border=[dq]0[dq] align=[dq]middle[dq]>"
          sentence := sentence i sentence:len
        else
          p:http_stream writechars " "
          sentence := sentence 1 sentence:len
  eif (p attribute fixed is_active)
    p:http_stream writechars (replace text " " "&nbsp;")
  else
    p:http_stream writechars text

method page standard_begin_hook
  arg_rw HtmlPage page
  implicit page
    write "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 4.01 Transitional//EN[dq]>[lf]"
    write "<html>[lf]"
    write "<head>[lf]"
    if (attribute common url_icon)<>""
      write "<link rel=[dq]icon[dq] type=[dq]image/png[dq] href=[dq]"+(attribute common url_icon)+"[dq]>[lf]"
    write "<script src=[dq]/common/pliant.js[dq] language=[dq]JavaScript[dq] type=[dq]text/javascript[dq]></script>[lf]"
    write "<script src=[dq]"+common_path+"pliant.js[dq] language=[dq]JavaScript[dq] type=[dq]text/javascript[dq]></script>[lf]"
    if (attribute common head)<>""
      write (attribute common head) ; write "[lf]"
    if (attribute common css)<>""
      write "<style type=[dq]text/css[dq]>[lf]"
      write (attribute common css) ; write "[lf]"
      write "</style>[lf]"
    write "</head>[lf]"
    write "<body"
    write " onLoad=[dq]refresh()[dq]"
    var ColorRGB888 bg := attribute common bgcolor
    if bg:r<>255 or bg:g<>255 or bg:b<>255
      write " bgcolor=[dq]"+(string bg "html")+"[dq]"
    if (attribute common body)<>""
      write " "+(attribute common body)
    write ">[lf]"
    # write "<!-- "+http_request:query_first_line+" -->[lf]"
    var Str enctype := ""
    if browser="konqueror"
      enctype := " enctype [dq]multipart/form-data[dq]"
    write "<form name=[dq]pliant[dq] method=[dq]POST[dq]"+enctype+" onSubmit=[dq]return complete(this)[dq]>[lf]"
    write "<input type=[dq]hidden[dq] name=[dq]_pliant_x[dq] value=[dq][dq]>[lf]"
    write "<input type=[dq]hidden[dq] name=[dq]_pliant_y[dq] value=[dq][dq]>[lf]"
    write "<input type=[dq]hidden[dq] name=[dq]_[dq] value=[dq][dq]>[lf]"
    var Pointer:ColorRGB888 fc :> attribute font color
    if (attribute font face)<>"" or fc:r<>0 or fc:g<>0 or fc:b<>0
      write "<font face=[dq]"+(attribute font face)+"[dq] color=[dq]"+(string fc "html")+"[dq]>"
    if (attribute common header)<>""
      write (attribute common header) ; write "[lf]"  
    page_header

method page standard_end_hook
  arg_rw HtmlPage page
  implicit page
    if not request:answer_header_sent or request:answer_footer_sent
      return
    page_footer
    if (attribute common footer)<>""
      write (attribute common footer) ; write "[lf]"   
    var Pointer:ColorRGB888 fc :> attribute font color
    if (attribute font face)<>"" or fc:r<>0 or fc:g<>0 or fc:b<>0
      write "</font>[lf]"
    write "</form>[lf]"
    write "</body>[lf]"
    write "</html>[lf]"

function full_url target has_section section has_options options no_extension -> url
  arg Str target section options ; arg CBool has_section has_options no_extension ; arg Str url
  url := http_encode target
  var Str without_path := url (url search_last "/" -1)+1 url:len
  if not no_extension and without_path:len<>0 and (without_path search "." -1)=(-1) and (without_path search ":" -1)=(-1)
    url += ".html"
  if has_section
    url += "#"+http_encode:section
  if has_options
    url += "?"+http_encode:options

style_setup
  text_hook :> the_function '. standard_text_hook' HtmlPage Str
  begin_hook :> the_function '. standard_begin_hook' HtmlPage
  end_hook :> the_function '. standard_end_hook' HtmlPage
  
  push input is_read_only false
  html_attributes_setup

  style_tag page_header
    void
  style_tag page_footer
    void

  style_tag link
    write "<a href=[dq]"+(full_url target has:section section has:options (attribute link options) has:no_extension)+"[dq]" # using 'attribute link options' instead of simply 'options' is required in order not to get page:options
    write_attributes
    write ">"
    write label
    write "</a>"

  style_tag section
    write "<a name=[dq]"+name+"[dq]></a>"

  style_tag note
    write "<a href=[dq]"+request:encoded_path+"?"+target+"[dq]>"+label+"</a>[lf]"

  style_tag image
    write "<img src=[dq]"+src+"[dq]"
    write_attributes
    write ">"

  style_tag how
    write "<a href=[dq]"+(full_url target has:section section has:options (attribute how options) has:no_extension)+"[dq]>"
    write "<img src=[dq]/common/icon/how.png[dq] border=[dq]0[dq]>"
    write "<img src=[dq]"+common_path+"icon/how.png[dq] border=[dq]0[dq]>"
    write "</a>"

  style_tag title
    head "<title>"+label+"</title>[lf]"
    if has:logo
      write "<table width=[dq]100%[dq]><tr><td width=[dq]100%[dq]>"
    if button<>"" or round>0
      box button button bsize bsize_x bsize_y margin margin_left margin_top margin_right margin_bottom round round color bgcolor width "100%"
        center
          font font face size ssr color color linebreak false
            text html_decode:label
    else
      if ssr
        var Str url := "text "+(string html_decode:label)+" font [dq]"+face+"[dq] "+string:size+" color [dq]"+string:color+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
        write "<center><img src=[dq]/common/"+http_encode:url+"[dq]></center>"
        write "<center><img src=[dq]"+common_path+http_encode:url+"[dq]></center>"
      else
        write "<h1><center>"+label+"</center></h1>"
    if has:logo
      write "</td><td>"
      if has:link
        write "<a href=[dq]"+link+"[dq]>"
      write "<img src=[dq]"+logo+"[dq]"+(shunt has:link " border=[dq]0[dq]" "")+">"
      if has:link
        write "</a>"
      write "</td></tr></table>"
    write "<br>[lf]"

  style_tag chapter
    write "<br><br>[lf]"
    if (attribute header button)<>"" or (attribute header round)>0
      box button (attribute header button) bsize (attribute header bsize_x) (attribute header bsize_y) margin (attribute header margin_left) (attribute header margin_top) (attribute header margin_right) (attribute header margin_bottom) round (attribute header round) color (attribute header bgcolor) width "100%"
        font font (attribute header face) (attribute header size) (attribute header ssr) color (attribute header color) linebreak false
          if (attribute header ssr)
            text (repeat (attribute header tabulation) " ")+html_decode:label
          else
            fixed text:(repeat (attribute header tabulation) " ") ; text html_decode:label
    else
      if (attribute header ssr)
        var Str url := "text "+(string html_decode:label)+" font [dq]"+(attribute header face)+"[dq] "+string:(attribute title size)+" color [dq]"+string:(attribute header color)+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
        write "<p><img src=[dq]/common/"+http_encode:url+"[dq]></p>[lf]"
        write "<p><img src=[dq]"+common_path+http_encode:url+"[dq]></p>[lf]"
      else
        write "<h1>"+label+"</h1>[lf]"

  style_open header
    write "<br>[lf]"
    push level level+1
    var Float f := shunt level=1 factor1 level=2 factor2 factor3
    if button<>"" or round>0
      box button button bsize bsize_x*f bsize_y*f margin margin_left*f margin_top*f margin_right*f margin_bottom*f round (cast round*f Int) color (shade bgcolor (shunt level=1 bgshade1 level=2 bgshade2 bgshade3)) width "100%"
        font font face size*f ssr color (shade color (shunt level=1 shade1 level=2 shade2 shade3)) linebreak false
          if ssr
            text (repeat tabulation " ")+html_decode:label
          else
            fixed text:(repeat tabulation " ") ; text html_decode:label
    else
      if ssr
        var Str url := "text "+(string html_decode:label)+" font [dq]"+face+"[dq] "+(string size*f)+" color [dq]"+string:color+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
        write "<p><img src=[dq]/common/"+http_encode:url+"[dq]></p>[lf]"
        write "<p><img src=[dq]"+common_path+http_encode:url+"[dq]></p>[lf]"
      else
        write "<h"+(string level+1)+">"+label+"</h"+(string level+1)+">[lf]"
  style_close header
    void

  style_open big
    write "<font size=[dq]+1[dq]>"
  style_close big
    write "</font>"

  style_tag small
    write "<font size=[dq]-1[dq]>"
  style_close small
    write "</font>"

  style_open fixed
    write "<tt>"
    push is_active true
  style_close fixed
    write "</tt>"

  style_open font
    if (attribute common has_html4)
      var Str st := ""
      if has:face
        st += "font-family: "+face+"; "
      if has:size
        st += "font-size: "+(string size "fixed 0")+"pt; "
      if has:color
        st += "color: "+(string color "html")+"; "
      write "<span style=[dq]"
      write (st 0 (max st:len-2 0))
      write "[dq]>"
    else
      write "<font"
      if has:face
        write " face=[dq]"+face+"[dq]"
      if has:size
        write " size=[dq]"+(string size "fixed 0")+"pt[dq]"
      if has:color
        write " color=[dq]"+(string color "html")+"[dq]"
      write_attributes
      write ">"
    # if (attributes option "bold")
    #   write "<b>"
  style_close font
    # if (attributes option "bold")
    #   write "</b>"
    if (attribute common has_html4)
      write "</span>"
    else
      write "</font>"

  style_tag highlight
    write "<tt> </tt>"
    write "<font size=[dq]"+size+"[dq] color=[dq]"+(string color "html")+"[dq]><b>"
    write label
    write "</b></font>"

  style_open table
    push cursor (shunt has:columns (cast 0 Int) undefined)
    write "<table border=[dq]"+string:border+"[dq] cellpadding=[dq]"+string:padding+"[dq] cellspacing=[dq]"+string:spacing+"[dq]"
    write_attributes
    write ">[lf]"
  style_close table
    write "</table>[lf]"

  style_open cell
    if (attribute table cursor)<>undefined and (attribute table cursor)%(attribute table columns)=0
      write "<tr>[lf]"
    write "<td"
    if has:color
      write " bgcolor=[dq]"+(string color "html")+"[dq]"
    eif has:header
      write " bgcolor=[dq]"+(string header_color "html")+"[dq]"
    write_attributes
    write ">"
    var Pointer:ColorRGB888 fc :> attribute font color
    if (attribute font face)<>"" or fc:r<>0 or fc:g<>0 or fc:b<>0
      write "<font face=[dq]"+(attribute font face)+"[dq] color=[dq]"+(string fc "html")+"[dq]>"
  style_close cell
    var Pointer:ColorRGB888 fc :> attribute font color
    if (attribute font face)<>"" or fc:r<>0 or fc:g<>0 or fc:b<>0
      write "</font>"
    write "</td>[lf]"
    if (attribute table cursor)<>undefined
      attribute table cursor += 1
      if (attribute table cursor)%(attribute table columns)=0
        write "</tr>[lf]"

  style_open box
    var ColorRGB888 c := color
    var ColorRGB888 c2 := shade c 0.5
    if not has:header
      c2 := c
    var CBool colored := not has:transparent and (button<>"" or round>0 or (memory_different addressof:color ColorRGB888:size addressof:(attribute common bgcolor) ColorRGB888:size))
    write "<table cellspacing=[dq]0[dq] cellpadding=[dq]"+string:(shunt button<>"" or round>0 (cast 0 Int) (attribute table padding))+"[dq]"
    if has:width
      write " width=[dq]"+width+"[dq]"
    if has:left
      write " align=[dq]left[dq]"
    if has:right
      write " align=[dq]right[dq]"
    # write_attributes
    write "><tr>[lf]"
    if button<>""
      var Str opt := " button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" color [dq]"+string:c+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
      write "<td><img src=[dq]/common/border%200"+http_encode:opt+"[dq]></td>[lf]"
      write "<td background=[dq]/common/border%201"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]/common/border%202"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]"+common_path+"border%200"+http_encode:opt+"[dq]></td>[lf]"
      write "<td background=[dq]"+common_path+"border%201"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]"+common_path+"border%202"+http_encode:opt+"[dq]></td>[lf]"
      write "</tr><tr>[lf]"
      if has:header
        write "<td background=[dq]/common/border%203"+http_encode:opt+"[dq]></td>[lf]"
        write "<td background=[dq]"+common_path+"border%203"+http_encode:opt+"[dq]></td>[lf]"
        write "<td bgcolor=[dq]#"+string:c+"[dq]><center>"
        if hssr
          var Str url := "text "+(string html_decode:header)+" font [dq]"+hface+"[dq] "+string:hsize+" color [dq]"+string:hcolor+"[dq] bgcolor [dq]"+string:c+"[dq]"
          write "<img src=[dq]/common/"+http_encode:url+"[dq]>"
          write "<img src=[dq]"+common_path+http_encode:url+"[dq]>"
        else
          write header
        write "</center></td>[lf]"
        write "<td background=[dq]/common/border%205"+http_encode:opt+"[dq]></td>[lf]"
        write "<td background=[dq]"+common_path+"border%205"+http_encode:opt+"[dq]></td>[lf]"
        write "</tr><tr>[lf]"
        write "<td><img src=[dq]/common/border%203"+http_encode:opt+"[dq]></td>[lf]"
        write "<td><img src=[dq]"+common_path+"border%203"+http_encode:opt+"[dq]></td>[lf]"
        write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
        write "<td><img src=[dq]/common/border%205"+http_encode:opt+"[dq]></td>[lf]"
        write "<td><img src=[dq]"+common_path+"border%205"+http_encode:opt+"[dq]></td>[lf]"
        write "</tr><tr>[lf]"
        var Str opt := " button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" color [dq]"+string:c2+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
        write "<td><img src=[dq]/common/border%203"+http_encode:opt+"[dq]></td>[lf]"
        write "<td><img src=[dq]"+common_path+"border%203"+http_encode:opt+"[dq]></td>[lf]"
        write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
        write "<td><img src=[dq]/common/border%205"+http_encode:opt+"[dq]></td>[lf]"
        write "<td><img src=[dq]"+common_path+"border%205"+http_encode:opt+"[dq]></td>[lf]"
      write "</tr><tr>[lf]"
      write "<td background=[dq]/common/border%203"+http_encode:opt+"[dq]></td>[lf]"
      write "<td background=[dq]"+common_path+"border%203"+http_encode:opt+"[dq]></td>[lf]"
    eif round>0
      var Str opt := " size "+string:round+" "+string:round+" color [dq]"+string:c+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
      write "<td><img src=[dq]/common/corner%200"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]"+common_path+"corner%200"+http_encode:opt+"[dq]></td>[lf]"
      write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
      write "<td><img src=[dq]/common/corner%201"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]"+common_path+"corner%201"+http_encode:opt+"[dq]></td>[lf]"
      write "</tr><tr>[lf]"
      if has:header
        write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
        write "<td bgcolor=[dq]#"+string:c+"[dq]><center>"
        if hssr
          var Str url := "text "+(string html_decode:header)+" font [dq]"+hface+"[dq] "+string:hsize+" color [dq]"+string:hcolor+"[dq] bgcolor [dq]"+string:c+"[dq]"
          write "<img src=[dq]/common/"+http_encode:url+"[dq]>"
          write "<img src=[dq]"+common_path+http_encode:url+"[dq]>"
        else
          write header
        write "</center></td>[lf]"
        write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
        write "</tr><tr>[lf]"
        write "<td colspan=[dq]3[dq] height=[dq]"+string:round+"[dq] bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
        write "</tr><tr>[lf]"
        write "<td colspan=[dq]3[dq] height=[dq]"+string:round+"[dq] bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
        write "</tr><tr>[lf]"
      write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
    else
      if has:header
        write "<td"+(shunt colored " bgcolor=[dq]#"+string:c+"[dq]" "")+"><center>"
        if hssr
          var Str url := "text "+(string html_decode:header)+" font [dq]"+hface+"[dq] "+string:hsize+" color [dq]"+string:hcolor+"[dq] bgcolor [dq]"+string:c+"[dq]"
          write "<img src=[dq]/common/"+http_encode:url+"[dq]>"
          write "<img src=[dq]"+common_path+http_encode:url+"[dq]>"
        else
          write header
        write "</center></td>[lf]"
        write "</tr><tr>[lf]"
    write "<td width=[dq]100%[dq] height=[dq]100%[dq]"
    if colored
      write " bgcolor=[dq]#"+string:c2+"[dq]"
    write ">"
    html_stack mark
    if colored
      push common bgcolor c2
  style_close box
    html_stack rewind
    write "</td>[lf]"
    var ColorRGB888 c := color
    var ColorRGB888 c2 := shade c 0.5
    if not has:header
      c2 := c
    if button<>""
      var Str opt := " button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" color [dq]"+string:c2+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
      write "<td background=[dq]/common/border%205"+http_encode:opt+"[dq]></td>[lf]"
      write "<td background=[dq]"+common_path+"border%205"+http_encode:opt+"[dq]></td>[lf]"
      write "</tr><tr>[lf]"
      write "<td><img src=[dq]/common/border%206"+http_encode:opt+"[dq]></td>[lf]"
      write "<td background=[dq]/common/border%207"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]/common/border%208"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]"+common_path+"border%206"+http_encode:opt+"[dq]></td>[lf]"
      write "<td background=[dq]"+common_path+"border%207"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]"+common_path+"border%208"+http_encode:opt+"[dq]></td>[lf]"
    eif round>0
      var Str opt := " size "+string:round+" color [dq]"+string:c2+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]"
      write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
      write "</tr><tr>[lf]"
      write "<td><img src=[dq]/common/corner%202"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]"+common_path+"corner%202"+http_encode:opt+"[dq]></td>[lf]"
      write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
      write "<td><img src=[dq]/common/corner%203"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]"+common_path+"corner%203"+http_encode:opt+"[dq]></td>[lf]"
    write "</tr></table>[lf]"

  style_tag input
    write label
    write "<input type=[dq]"+type+"[dq] name=[dq]"+name+"[dq] value=[dq]"+value+"[dq]"
    if length=defined
      write " size=[dq]"+string:length+"[dq]"
    if has:database
      write (shunt browser="konqueror" " onFocus=[dq]textin(this)[dq] onBlur=[dq]textout(this)[dq]" " onChange=[dq]change(this)[dq]")
    write_attributes
    if smart_input and (bgcolor:r<>255 or bgcolor:g<>255 or bgcolor:b<>255)
      write " style=[dq]border: 0; background-color: #"+string:(shade bgcolor 0.25)+"[dq]"
    write ">[lf]"

  style_tag textarea
    write label
    write "<textarea name=[dq]"+name+"[dq] cols=[dq]"+string:columns+"[dq] rows=[dq]"+string:rows+"[dq] wrap=[dq]off[dq]"
    if has:database
      write (shunt browser="konqueror" " onFocus=[dq]textin(this)[dq] onBlur=[dq]textout(this)[dq]" " onChange=[dq]change(this)[dq]")
    if smart_input and (bgcolor:r<>255 or bgcolor:g<>255 or bgcolor:b<>255)
      write " style=[dq]border: 0; background-color: #"+string:(shade bgcolor 0.25)+"[dq]"
    write_attributes
    write ">"
    write value
    write "</textarea>[lf]"

  style_tag select_begin
    write label
    write "<select name=[dq]"+name+"[dq]"
    if has:database
      write (shunt browser="konqueror" " onFocus=[dq]textin(this)[dq] onBlur=[dq]textout(this)[dq]" " onChange=[dq]change(this)[dq]")
    if smart_input and (bgcolor:r<>255 or bgcolor:g<>255 or bgcolor:b<>255)
      write " style=[dq]border-width: 0; background-color: #"+string:(shade bgcolor 0.25)+"[dq]"
    write ">[lf]"
  style_tag select_end
    write "</select>[lf]"

  style_tag option
    if (attribute select_begin is_active)
      write "<option"
      if value=(attribute select_begin value)
        write " selected"
      write " value=[dq]"+value+"[dq]"
      write ">"
      write label
      write "</option>[lf]"
    else
      if value=(attribute select_begin value)
        attribute select_begin selected_label := label
     
  style_tag pdata
    if has:rows
      write label+"[lf]"
      write "<table><tr><td><pre>[lf]"
    else
      write label+"<tt>[lf]"
    write "<pdata path=[dq]"+path+"[dq]>"+value+"</pdata>[lf]"
    if has:rows
      write "</pre></td></tr></table>[lf]"
    else
      write "</tt>[lf]"


  style_tag button
    if button=""
      write "<input type=[dq]submit[dq] name=[dq]"+target+"[dq] value=[dq]"+label+"[dq]>[lf]"
    else
      var Str action := "[dq]button_pressed('"+target+"')[dq]"
      var Str event := shunt browser="netscape" "onMouseUp" "onClick"
      var Str url := "/common/button"+(http_encode " [dq]"+html_decode:label+"[dq] font [dq]"+face+"[dq] "+string:size+(shunt extend=defined " extend "+string:extend "")+(shunt center " center" "")+" tcolor [dq]"+string:tcolor+"[dq] button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" bcolor [dq]"+string:bcolor+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]")
      var Str url := common_path+"button"+(http_encode " [dq]"+html_decode:label+"[dq] font [dq]"+face+"[dq] "+string:size+(shunt extend=defined " extend "+string:extend "")+(shunt center " center" "")+" tcolor [dq]"+string:tcolor+"[dq] button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" bcolor [dq]"+string:bcolor+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]")
      write "<img src=[dq]"+url+"[dq] align=[dq]middle[dq] "+event+"="+action+">"
    if not has:noeol
      write "<br>[lf]"

  style_tag icon
    var Str action := "[dq]button_pressed('"+target+"')[dq]"
    var Str event := shunt browser="netscape" "onMouseUp" "onClick"
    var Str url := src
    if button<>""
      url := "/common/icon"+(http_encode " [dq]"+src+"[dq]"+(shunt isize_x=defined " isize "+string:isize_x+" "+string:isize_y "")+(shunt dull=defined " dull "+string:dull "")+" button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" bcolor [dq]"+string:bcolor+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]")
      url := common_path+"icon"+(http_encode " [dq]"+src+"[dq]"+(shunt isize_x=defined " isize "+string:isize_x+" "+string:isize_y "")+(shunt dull=defined " dull "+string:dull "")+" button [dq]"+button+"[dq]"+(shunt bsize_x=defined " bsize "+string:bsize_x+" "+string:bsize_y "")+(shunt margin_left=defined " margin "+string:margin_left+" "+string:margin_top+" "+string:margin_right+" "+string:margin_bottom "")+" bcolor [dq]"+string:bcolor+"[dq] bgcolor [dq]"+string:(attribute common bgcolor)+"[dq]")
    write "<img src=[dq]"+url+"[dq] align=[dq]middle[dq] alt=[dq]"+help+"[dq] "+event+"="+action+">"

  style_open listing
    write "<p>[lf]<tt>[lf]"
    push fixed is_active true
  style_close listing
    write "</tt>[lf]</p>[lf]"


#---------------------------------------------------------------------------
# input fields
  

method p set_read_only c
  arg_rw HtmlPage p ; arg CBool c
  if c
    p attribute input is_read_only := true

method p read_only_begin
  arg_rw HtmlPage p
  p:html_stack mark
  p push input is_read_only true

method p read_only_begin c
  arg_rw HtmlPage p ; arg CBool c
  p:html_stack mark
  if c
    p push input is_read_only true

method p read_only_end
  arg_rw HtmlPage p
  p:html_stack rewind

meta '. read_only' e
  if e:size<1 or not (e:0 cast HtmlPage)
    return
  if e:(e:size-1):ident="{}"
    if e:size=2
      e:(e:size-1) compile ?
      e suckup e:0
      e add (instruction (the_function '. read_only_begin' HtmlPage) e:0:result)
      e suckup e:(e:size-1)
      e add (instruction (the_function '. read_only_end' HtmlPage) e:0:result)
      e set_void_result
    eif e:size=3 and (e:1 cast CBool)
      e:(e:size-1) compile ?
      e suckup e:0
      e suckup e:1
      e add (instruction (the_function '. read_only_begin' HtmlPage CBool) e:0:result e:1:result)
      e suckup e:(e:size-1)
      e add (instruction (the_function '. read_only_end' HtmlPage) e:0:result)
      e set_void_result
  eif e:size=2 and (e:1 cast CBool)
    e suckup e:0
    e suckup e:1
    e add (instruction (the_function '. set_read_only' HtmlPage CBool) e:0:result e:1:result)
    e set_void_result

method p is_read_only -> c
  arg_rw HtmlPage p ; arg CBool c
  c := p attribute input is_read_only

export '. read_only' '. is_read_only'


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

method p html_input ident data fun label length flags
  arg_rw HtmlPage p ; arg Str ident ; arg Universal data ; arg Function fun ; arg Str label ; arg Int length ; arg uInt flags
  p input label label type (shunt (flags .and. 2)=0 "text" "password") name ident value (to_string data "raw" fun) length length
  if (flags .and. 1)<>0
    p eol

if database

  method p data_input d label length flags
    arg_rw HtmlPage p ; arg Data_ d ; arg Str label ; arg Int length ; arg uInt flags
    if (d:interface get d addressof:(var Str value) Str)=failure
      value := ""
    if (p attribute input is_read_only)
      p pdata label label path d:path value value
    else
      var Str dpath := replace (replace d:path "&#" "(") ";" ")"
      p input label label type (shunt (flags .and. 2)=0 "text" "password") name "/"+(p:request generate_signature d:path)+dpath value value length length database
    if (flags .and. 1)<>0
      p eol

meta '. input' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast Str)
    return
  e:2:compile ?
  var CBool data := database and e:2:is_data
  if not data
    var Str name := shunt e:2:size=0 e:2:ident e:2:(e:2:size-1):ident
    if name=""
      return
    var Link:Type type :> e:2:result:type:real_data_type
    if not (e:2 cast type)
      return
    var Pointer:Function function :> type get_generic_method to_index
    if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
      return
    notify_editable_variable e:2    
  var uInt flags := 1
  var Link:Argument length :> argument constant Int undefined
  var Int i := 3
  while i<e:size
    if e:i:ident="noeol"
      flags := flags .and. .not. 1
      i += 1
    eif e:i:ident="password"
      flags := flags .or. 2
      i += 1
    eif e:i:ident="length" and i+1<e:size and (e:(i+1) cast Int)
      e suckup e:(i+1)
      length :> e:(i+1) result
      i += 2
    else
      return
  e suckup e:0 ; e suckup e:1 ; e suckup e:2
  if database and data
    e add (instruction (the_function '. data_input' HtmlPage Data_ Str Int uInt) e:0:result e:2:result e:1:result length (argument constant uInt flags))
  else
    e add (instruction (the_function '. html_input' HtmlPage Str Universal Function Str Int uInt) e:0:result (argument constant Str name) e:2:result (argument mapped_constant Function function) e:1:result length (argument constant uInt flags))
  e set_void_result


method p html_text_input label ident value nx ny
  arg_rw HtmlPage p ; arg Str label ident value ; arg Int nx ny
  p textarea label label name ident columns nx rows ny value value

if database

  method p data_text_input label d nx ny
    arg_rw HtmlPage p ; arg Str label ; arg Data_ d ; arg Int nx ny
    if (d:interface get d addressof:(var Str value) Str)=failure
      value := ""
    if (p attribute input is_read_only)
      p pdata label label path d:path value value columns nx rows ny
    else
      var Str dpath := replace (replace d:path "&#" "(") ";" ")"
      p textarea label label name "/"+(p:request generate_signature d:path)+dpath value value columns nx rows ny database

meta '. text_input' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast Str)
    return
  e:2:compile ?
  var CBool data := database and e:2:is_data
  if not data
    var Str name := shunt e:2:size=0 e:2:ident e:2:(e:2:size-1):ident
    if name=""
      return
    if not (e:2 cast Str)
      return
    notify_editable_variable e:2
  var Bool eol := true
  var Link:Argument cols :> argument constant Int undefined
  var Link:Argument rows :> argument constant Int undefined
  var Int i := 3
  while i<e:size
    if e:i:ident="noeol"
      eol := false
      i += 1
    eif e:i:ident="columns" and i+1<e:size and (e:(i+1) cast Int)
      e suckup e:(i+1)
      cols :> e:(i+1) result
      i += 2
    eif e:i:ident="rows" and i+1<e:size and (e:(i+1) cast Int)
      e suckup e:(i+1)
      rows :> e:(i+1) result
      i += 2
    else
      return
  e suckup e:0 ; e suckup e:1 ; e suckup e:2
  if database and data
    e add (instruction (the_function '. data_text_input' HtmlPage Str Data_ Int Int) e:0:result e:1:result e:2:result cols rows)
  else
    e add (instruction (the_function '. html_text_input' HtmlPage Str Str Str Int Int) e:0:result e:1:result (argument constant Str name) e:2:result cols rows)
  if eol
    e add (instruction (the_function '. text' HtmlPage Str) e:0:result (argument constant Str "[lf]"))
  e set_void_result


method p html_select_begin label ident data fun
  arg_rw HtmlPage p ; arg Str label ; arg Str ident ; arg Universal data ; arg Function fun
  p:html_stack mark
  p push select_begin value (to_string data "raw" fun)
  p push select_begin is_active true
  p select_begin label label name ident

method p html_select_end
  arg_rw HtmlPage p
  p select_end
  p:html_stack rewind
 
if database

  method p data_select_begin label d
    arg_rw HtmlPage p ; arg Str label ; arg Data_ d
    if (d:interface get d addressof:(var Str value) Str)=failure
      value := ""
    p:html_stack mark
    p push select_begin value html_encode:value
    if (p attribute input is_read_only)
      p push select_begin is_active false
      p push select_begin label html_encode:label
      p push pdata path d:path
      p push select_begin selected_label ""
    else
      p push select_begin is_active true
      var Str dpath := replace (replace d:path "&#" "(") ";" ")"
      p select_begin label label name "/"+(p:request generate_signature d:path)+dpath value value database
  
  method p data_select_end
    arg_rw HtmlPage p
    if (p attribute input is_read_only)
      p pdata label html_decode:(p attribute select_begin label) path (p attribute pdata path) value html_decode:(p attribute select_begin selected_label)
    else
      p select_end database
    p:html_stack rewind
   
meta '. select' e
  if e:size<4 or not (e:0 cast HtmlPage) or not (e:1 cast Str)
    return
  e:2:compile ?
  var CBool data := database and e:2:is_data
  if not data
    var Str name := shunt e:2:size=0 e:2:ident e:2:(e:2:size-1):ident
    if name=""
      return
    var Link:Type type :> e:2:result:type:real_data_type
    if not (e:2 cast type)
      return
    var Pointer:Function function :> type get_generic_method to_index
    if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
      return
    notify_editable_variable e:2
  var Bool eol := true
  var Int i := 3
  while i<e:size-1
    if e:i:ident="noeol"
      eol := false
      i += 1
    else
      return
  (e e:size-1) compile ?
  e suckup e:0 ; e suckup e:1 ; e suckup e:2
  if database and data
    e add (instruction (the_function '. data_select_begin' HtmlPage Str Data_) e:0:result e:1:result e:2:result)
  else
    e add (instruction (the_function '. html_select_begin' HtmlPage Str Str Universal Function) e:0:result e:1:result (argument constant Str name) e:2:result (argument mapped_constant Function function))
  e suckup (e e:size-1)
  if database and data
    e add (instruction (the_function '. data_select_end' HtmlPage) e:0:result)
  else
    e add (instruction (the_function '. html_select_end' HtmlPage) e:0:result)
  if eol
    e add (instruction (the_function '. text' HtmlPage Str) e:0:result (argument constant Str "[lf]"))
  e set_void_result


method p html_file_upload label ident
  arg_rw HtmlPage p ; arg Str label ident
  p input label label type "file" name "file upload "+ident

meta '. file_upload' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast Str) or not (e:2 cast Str)
    return
  var Str name := shunt e:2:size=0 e:2:ident e:2:(e:2:size-1):ident
  if name=""
    return
  var Bool eol := true
  var Int i := 3
  while i<e:size
    if e:i:ident="noeol"
      eol := false
      i += 1
    else
      return
  e suckup e:0 ; e suckup e:1 ; e suckup e:2
  e add (instruction (the_function '. html_file_upload' HtmlPage Str Str) e:0:result e:1:result (argument constant Str name))
  if eol
    e add (instruction (the_function '. text' HtmlPage Str) e:0:result (argument constant Str "[lf]"))
  e set_void_result
  notify_editable_variable e:2

export '. input' '. text_input' '. select' '. option' '. file_upload'


#---------------------------------------------------------------------------
#  listing


method p listing_text1 l
  arg_rw HtmlPage p ; arg Str l
  if { var Int i := l search "`" -1 ; i>=0 }
    var Int j := i+1
    while j<l:len and ( (l:j>="a" and l:j<="z") or  (l:j>="A" and l:j<="Z") or (l:j>="0" and l:j<="9") or l:j="_" )
      j += 1
    if j=i+1
      j := i+2
    p text (l 0 i) ; p italic (p text (l i+1 j-i-1)) ; p listing_text1 (l j l:len)
  else
    p text l

method p listing_text2 l
  arg_rw HtmlPage p ; arg Str l
  if { var Int i := l search "¤" -1 ; i>=0 }
    var Int j := i+1
    while j<l:len and ( (l:j>="a" and l:j<="z") or  (l:j>="A" and l:j<="Z") or (l:j>="0" and l:j<="9") or l:j="_" )
      j += 1
    if j=i+1
      j := i+2
    p listing_text1 (l 0 i) ; p bold (p text (l i+1 j-i-1)) ; p listing_text2 (l j l:len)
  else
    p listing_text1 l

method p listing list
  arg_rw HtmlPage p ; arg List:Str list
  strong_definition
  p listing
    var Pointer:Str l :> list first
    while exists:l
      if { var Int i := l option_position "#" -1 ; i<>-1 }
        p listing_text2 (l 0 i)
        p font color (color hsl 200 75 50)
          p italic
            p text (l i l:len)
      else
        p listing_text2 l
      p eol
      l :> list next l

multiline_keyword listing
export '. listing'