Patch title: Release 85 bulk changes
Abstract:
File: /pliant/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
# modify it under the terms of the GNU General Public Licens
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be us
# but WITHOUT ANY WARRANTY; without even the implied warrant
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public 
# version 2 along with this program; if not, write to the Fr
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 

module "/pliant/language/compiler.pli"
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and
# modify it under the terms of the GNU General Public Licens
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be us
# but WITHOUT ANY WARRANTY; without even the implied warrant
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public 
# version 2 along with this program; if not, write to the Fr
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 

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/language/parser.pli"
module "/pliant/language/parser/multiline.pli"
module "/pliant/protocol/http/server.pli"
module "/pliant/util/encoding/neutral.pli"
module "/pliant/admin/md5.pli"
module "common.pli"
submodule "common.style"
module "/pliant/admin/md5.pli"
module "common.pli"
submodule "common.style"
submodule "/pliant/graphic/color/rgb888.pli"


constant smart_input false



#-----------------------------------------------------------
#-----------------------------------------------------------
#  style setup
#  new Pliant instructions


function corner i round color ground -> s
  arg Int i ; arg Int round ; arg PixelRGB888 color ground ;
  s := "<img src=[dq]/common/corner_"+string:i+"_size_"+stri


function round_rectangle_begin space rounded color ground ta
  arg Int space ; arg CBool rounded ; arg PixelRGB888 color 
  if rounded
    t := "<table cellpadding=[dq]0[dq] cellspacing=[dq]0[dq]
    t += "<tr><td>"+(corner 0 space color ground)+"</td><td>
    t += "<tr><td></td><td"+cell_extra+">"
  else
    t := "<table cellpadding=[dq]"+string:space+"[dq] border
    t += "<tr><td"+cell_extra+">"
public


function round_rectangle_end space rounded color ground -> t
  arg Int space ; arg CBool rounded ; arg PixelRGB888 color 
  if rounded
    t := "</td><td></td></tr>[lf]"
    t += "<tr><td>"+(corner 2 space color ground)+"</td><td>
    t += "</table>[lf]"
  else
    t := "</td></tr></table>[lf]"
  html_tag common
    attr bgcolor ColorRGB888 (color rgb 255 255 255)
    attr url_icon Str
    attr has_html4 CBool true
    attr head Str
    hidden


  html_tag page_header
    void
  html_tag page_footer
    void


function title round rounded color ground fontcolor fontsize
  arg Int round ; arg CBool rounded ; arg PixelRGB888 fontco
  var CBool center := options option "center"
  var CBool bold := options option "bold"
  t := round_rectangle_begin round rounded color ground " wi
  t += shunt center "<center>" ""
  t += "<font face=[dq]Helvetica[dq]"+(shunt fontsize>0 " si
  t += shunt bold "<b>" ""
  t += shunt center "" "&nbsp;&nbsp;&nbsp;"
  t += tag_option "label" "" "" ""
  t += shunt bold "</b>" ""
  t += "</font>"
  t += shunt center "</center>" ""
  t += round_rectangle_end round rounded color ground
  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


style_setup
  var Str browser := http_request browser_model
  var CBool print := page:options option "print"
  var Float hue := options option "hue" Float
  if hue=undefined
    hue := 130
  var Float saturation := options option "staturation" Float
  if saturation=undefined
    saturation := 32
  var Float ground_light := 80
  var Float ground_saturation := saturation/24
  var PixelRGB888 ground := lsh_pixel ground_light ground_sa
  var CBool rounded := browser<>"" and browser<>"netscape"
  html_tag note label
    attr label Str
    subpage target


  tag_style "doctype" "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD
  var Str icon := "" # "<link REL=[dq]icon[dq] HREF=[dq]/com
  tag_style "head" "<head>[lf]"+icon+"<script src=[dq]/commo
  tag_style "stylesheet" ""
  tag_style "script" ""
  var Str form_encoding := ""
  if http_request:browser_model="konqueror"
    form_encoding := " enctype [dq]multipart/form-data[dq]"
  tag_style "body" "<body"+(shunt print "" " bgcolor=[dq]"+g
  tag_style "page_top" ""
  tag_style "page_bottom" ""
  tag_style "/body" "</form>[lf]</body>[lf]"
  html_tag image src -> img
    attr src Str


  tag_style "eol" "<br"+slash+">[lf]"
  html_tag how target
    attr target Str
    attr section Str
    attr options Str
    attr no_extension


  tag_style "link" "<a"+(tag_option "url" " href=[dq]" "[dq]
  tag_style "section" "<a"+(tag_option "name" " name=[dq]" "
  tag_style "image" "<img"+(tag_option "url" " src=[dq]" "[d
  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) 


  if print
    tag_style "title" "<title>"+(tag_option "label" "" "" ""
  else
    var Float title_light := 64
    var Float title_saturation := saturation/3
    var PixelRGB888 titleground := lsh_pixel title_light tit
    var PixelRGB888 fontcolor := lsh_pixel 15 20 hue
    var Str logo_head := tag_flag "logo" "<table border=[dq]
    var Str logo_tail := (tag_flag "logo" "</td><td>" "")+(t
    tag_style "title" "<title>"+(tag_option "label" "" "" ""
  html_tag chapter label
    attr label Str encode


  if print
    tag_style "chapter" "<h1>"+(tag_option "label" "" "" "")
  else
    tag_style "chapter" "<br>[lf]<br>[lf]<p>[lf]"+(title 10 
  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


  if print
    tag_style "header1" "<h2>"+(tag_option "label" "" "" "")
  else
    titleground := lsh_pixel title_light*0.67+ground_light*0
    fontcolor := lsh_pixel 30 25 hue
    tag_style "header1" "<br>[lf]<p>[lf]"+(title 5 rounded t
  method p header h
    arg_rw HtmlPage p ; arg Str h
    p header h
      void


  if print
    tag_style "header1" "<h3>"+(tag_option "label" "" "" "")
  else
    titleground := lsh_pixel title_light*0.33+ground_light*0
    fontcolor := lsh_pixel 40 30 hue
    tag_style "header2" "<p>[lf]"+(title 5 rounded titlegrou
  html_tag para -> p
    body
    newline


  if print
    tag_style "header1" "<h4>"+(tag_option "label" "" "" "")
  else
    titleground := lsh_pixel title_light*0.17+ground_light*0
    fontcolor := lsh_pixel 50 25 hue
    tag_style "header3" "<p>[lf]"+(title 3 rounded titlegrou
  html_tag eol -> br
    newline


  if false
    var PixelRGB888 buttonground := lsh_pixel 60 20 220
    var PixelRGB888 fontcolor := lsh_pixel 100 0 0
    var Str event := shunt browser="netscape" "onMouseUp" "o
    var Str event := tag_option "id" " "+event+"=[dq]button_
    var Str t := "<table cellpadding=[dq]1[dq] cellspacing=[
    t += round_rectangle_begin 3 true buttonground ground ""
    t += "<font face=[dq]Helvetica[dq] size=[dq]-1[dq] color
    t += round_rectangle_end 3 true buttonground ground
    t += "</td></tr></table>[lf]"
    tag_style "button" t
  tag_style "button" "<input type=[dq]submit[dq]"+(tag_optio
  html_tag center
    body


  tag_style "para" "<p>[lf]"+(tag_option "header" "<b>" "</b
  tag_style "/para" "</p>[lf]"
  tag_style "center" "<center>"
  tag_style "/center" "</center>"
  tag_style "bold" "<b>"
  tag_style "/bold" "</b>"
  tag_style "italic" "<i>"
  tag_style "/italic" "</i>"
  tag_style "big" "<font size=[dq]+1[dq]>"
  tag_style "/big" "</font>"
  tag_style "small" "<font size=[dq]-1[dq]>"
  tag_style "/small" "</font>"
  tag_style "fixed" "<tt>"
  tag_style "/fixed" "</tt>"
  tag_style "color" "<font"+(tag_option "color" " color=[dq]
  tag_style "/color" "</font>"
  tag_style "highlight" "<tt> </tt><font size=[dq]-2[dq] col
  tag_style "/highlight" "</b></font>[lf]"
  html_tag bold -> b
    body


  tag_style "list" "<ul>[lf]"
  tag_style "/list" "</ul>[lf]"
  tag_style "item" "<li>[lf]"
  tag_style "/item" "</li>[lf]"
  html_tag italic -> i
    body


  tag_style "table" "<p>[lf]<table"+(tag_option "id" " id=[d
  tag_style "/table" "</table>[lf]</p>[lf]"
  tag_style "row" "<tr>[lf]"
  tag_style "/row" "</tr>[lf]"
  var PixelRGB888 cellheaderground := lsh_pixel ground_light
  tag_style "cell" "<td"+(tag_option "id" " id=[dq]" "[dq]" 
  tag_style "/cell" "</td>[lf]"
  html_tag big
    body


  var Str db_events := shunt browser="konqueror" " onFocus=[
  tag_style "input" (tag_option "label" "" "" "")+"<input"+(
  tag_style "textarea" (tag_option "label" "" "" "")+"<texta
  tag_style "pdata" (tag_option "label" "" "" "")+"<tt>[lf]<
  var Str db_events := shunt browser="konqueror" " onFocus=[
  tag_style "select" (tag_option "label" "" "" "")+"<select"
  tag_style "/select" "</select>[lf]"
  tag_style "option" "<option"+(tag_flag "selected" " select
  html_tag small
    body


  var PixelRGB888 right_note_ground := lsh_pixel 85 20 60
  tag_style "note_right" "<table cellpadding=[dq]10[dq] cell
  tag_style "/note_right" (round_rectangle_end 10 rounded ri
  var PixelRGB888 inline_note_ground := lsh_pixel 90 0 0
  tag_style "note_inline" (round_rectangle_begin 10 rounded 
  tag_style "/note_inline" (round_rectangle_end 10 rounded i
  tag_style "note_link" "<a"+(tag_option "url" " href=[dq]" 
  html_tag fixed
    body
    attr is_active CBool false


  var PixelRGB888 listingground := lsh_pixel 90 0 0
  tag_style "listing" (round_rectangle_begin 5 false listing
  # tag_style "listing" "<p>[lf]<tt>[lf]"
  tag_style "/listing" "</tt>"+(round_rectangle_end 5 false 
  # tag_style "/listing" "</tt>[lf]</p>[lf]"
  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)


#-----------------------------------------------------------
#  basic
  html_tag list -> ul
    body
    newline


  html_tag item -> li
    body
    newline


method p eol
  arg_rw HtmlPage p
  p tag "eol" ""
  html_tag table
    attr columns Int
    attr padding Int 4 -> cellpadding
    attr spacing Int 0 -> cellpadding
    attr border Int 1
    body
    newline
    attr cursor Int


export '. eol'
  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)


#-----------------------------------------------------------
#  links and images
  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


method p hyperlink html_encoded_label target autoext section
  arg_rw HtmlPage p ; arg Str html_encoded_label target ; ar
  var Str without_path := target (target search_last "/" -1)
  var Str url := target
  if autoext and without_path:len<>0 and (without_path searc
    url += ".html"
  if options<>""
    url += "?"+http_encode:options
  if section<>""
    url += "#"+http_encode:section
  p tag "link" "label "+string:html_encoded_label+" url [dq]
  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


method p text_hyperlink label target autoext section options
  arg_rw HtmlPage p ; arg Str label target ; arg CBool autoe
  p hyperlink html_encode:label target autoext section optio


meta '. link' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast St
    return
  e suckup e:0 ; e suckup e:1 ; e suckup e:2
  var Link:Argument autoext :> argument constant CBool true
  var Link:Argument section :> argument constant Str ""
  var Link:Argument options :> argument constant Str ""
  var Int i := 3
  while i<e:size
    if e:i:ident="no_extension"
      autoext :> argument constant CBool false
      i += 1
    eif e:i:ident="section" and i+1<e:size and (e:(i+1) cast
      e suckup e:(i+1)
      section :> e:(i+1):result
      i += 2
    eif e:i:ident="options" and i+1<e:size and (e:(i+1) cast
      e suckup e:(i+1)
      options :> e:(i+1):result
      i += 2
    else
      return
  e add (instruction (the_function '. text_hyperlink' HtmlPa
  e set_void_result
  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


method p section name
  arg_rw HtmlPage p ; arg Str name
  p tag "section" "name [dq]"+http_encode:name+"[dq]"
  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


method p image img
  arg_rw HtmlPage p ; arg Str img
  var Str link
  p tag "image" "url [dq]"+img+"[dq]"
  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


method p image_hyperlink img target autoext section options
  arg_rw HtmlPage p ; arg Str img target ; arg CBool autoext
  p hyperlink "<img src=[dq]"+img+"[dq] border=[dq]0[dq]"+sl


meta '. image' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast St
    return
  e suckup e:0 ; e suckup e:1 ; e suckup e:2
  var Link:Argument autoext :> argument constant CBool true
  var Link:Argument section :> argument constant Str ""
  var Link:Argument options :> argument constant Str ""
  var Int i := 3
  while i<e:size
    if e:i:ident="no_extension"
      autoext :> argument constant CBool false
      i += 1
    eif e:i:ident="section" and i+1<e:size and (e:(i+1) cast
      e suckup e:(i+1)
      section :> e:(i+1):result
      i += 2
    eif e:i:ident="options" and i+1<e:size and (e:(i+1) cast
      e suckup e:(i+1)
      options :> e:(i+1):result
      i += 2
    else
      return
  e add (instruction (the_function '. image_hyperlink' HtmlP
  e set_void_result
#---------------------------------------------------------------------------
#  style setup




named_expression left_image
  table columns 2 border 0
    cell
      image filename options
    cell
      body
method p standard_html_hook text
  arg_rw HtmlPage p ; arg Str text
  p:http_stream writechars text


named_expression right_image
  table columns 2 border 0
    cell
      body
    cell
      image filename options
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]>"
    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]>"
          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


meta '. image' e
  if e:size>=4 and (e:0 cast HtmlPage) and (e:1 cast Str) an
    if (e e:size-2):ident="left"
      e compile_as (expression duplicate left_image substitu
    eif (e e:size-2):ident="right"
      e compile_as (expression duplicate right_image substit
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 "</head>[lf]"
    write "<body"
    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]"
    write " onLoad=[dq]refresh()[dq]"
    write ">[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]>"
    page_header


method page standard_end_hook
  arg_rw HtmlPage page
  implicit page
    if request:answered
      return
    page_footer
    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]"


meta '. how' e
  if e:size>=2 and (e:0 cast HtmlPage) and (e:1 cast Str)
    e compile_as (expression immediat (page image "/common/h
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 := 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


export '. link' '. section' '. image' '. how'


#-----------------------------------------------------------
#  title and headers


method p html_title label logo url small
  arg_rw HtmlPage p ; arg Str label logo url ; arg CBool sma
  p tag "title" "label [dq]"+(html_encode label true)+"[dq] 
  if small
    var Pointer:Int h :> p:env kmap "default header level" I
    h += 1

meta '. title' e
  if e:size<2 or not (e:0 cast HtmlPage) or not (e:1 cast St
    return
  var Link:Argument logo :> argument constant Str ""
  var Link:Argument url :> argument constant Str ""
  var Link:Argument small :> argument constant CBool false
  var Int n := e:size
  if n>2 and e:(n-1):is_pure_ident and e:(n-1):ident="small"
    small :> argument constant CBool true
    n -= 1
  if n>4
    return
  e suckup e:0 ; e suckup e:1
  if n>2
    if not (e:2 cast Str)
      return
    e suckup e:2
    logo :> e:2 result
  if n>3
    if not (e:3 cast Str)
      return
    e suckup e:3
    url :> e:3 result
  e add (instruction (the_function '. html_title' HtmlPage S
  e set_void_result
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


method p chapter label
  arg_rw HtmlPage p ; arg Str label
  p tag "chapter" "label [dq]"+(html_encode label true)+"[dq
  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>"


method p html_header_begin label
  arg_rw HtmlPage p ; arg Str label
  var Pointer:Int h :> p:env kmap "default header level" Int
  h += 1
  p tag "header"+string:h "label [dq]"+(html_encode label tr
  style_tag section
    write "<a name=[dq]"+name+"[dq]></a>"


method p html_header_end
  arg_rw HtmlPage p
  p:env kmap "default header level" Int -= 1
  style_tag note
    write "<a href=[dq]"+request:url_path+"?"+http_encode:target+"[dq]>"+label+"</a>[lf]"


meta '. header' e
  if e:size<2 or e:size>3 or not (e:0 cast HtmlPage) or not 
    return
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function '. html_header_begin' Htm
  if e:size>=3
    e:2 compile ?
    e suckup e:2
  e add (instruction (the_function '. html_header_end' HtmlP
  e set_void_result
  style_tag image
    write "<img src=[dq]"+src+"[dq]"
    write_attributes
    write ">"


method p small_headers
  arg_rw HtmlPage p
  var Pointer:Int h :> p:env kmap "default header level" Int
  h += 1
  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 "</a>"


  style_tag title
    head "<title>"+label+"</title>[lf]"
    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 has:logo
        write "<table width=[dq]100%[dq]><tr><td width=[dq]100%[dq]>"
      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>"
      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]"


simple_bloc_tag para
  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]"
      else
        write "<h1>"+label+"</h1>[lf]"


method p html_para_begin header what
  arg_rw HtmlPage p ; arg Str header what
  p tag "para" "header [dq]"+(html_encode header true)+"[dq]

method p html_para_end
  arg_rw HtmlPage p
  p tag "/para" ""
  

meta '. para' e
  if e:size<3 or not (e:0 cast HtmlPage)
    return
  var Link:Argument h :> argument constant Str ""
  var Link:Argument w :> argument constant Str ""
  var Link:Argument w0 :> w
  e suckup e:0
  var Int i := 1
  while i<e:size-1
    if e:i:ident="header" and i+1<e:size-1 and (e:(i+1) cast
      e suckup e:(i+1)
      h :> e:(i+1):result
      i += 2
    eif (e:i cast Str) and addressof:w=addressof:w0
      e suckup e:i
      w :> e:i:result
      i += 1
  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
    else
      return
  e add (instruction (the_function '. html_para_begin' HtmlP
  e:(e:size-1) compile ?
  e suckup e:(e:size-1)
  e add (instruction (the_function '. html_para_end' HtmlPag
  e set_void_result
      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]"
      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>"


export '. title' '. chapter' '. header' '. small_headers' '.
  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>"


#-----------------------------------------------------------
#  text attributs
  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>"


simple_bloc_tag center
simple_bloc_tag bold
simple_bloc_tag italic
simple_bloc_tag big
simple_bloc_tag small
  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]"


method p html_fixed_begin m
  arg_rw HtmlPage p ; arg_w Int m
  p tag "fixed" ""
  m := p do_not_use_Int
  p do_not_use_Int := p:do_not_use_Int .or. 1
  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+0"+http_encode:opt+"[dq]></td>[lf]"
      write "<td background=[dq]/common/border+1"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]/common/border+2"+http_encode:opt+"[dq]></td>[lf]"
      write "</tr><tr>[lf]"
      if has:header
        write "<td background=[dq]/common/border+3"+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]>"
        else
          write header
        write "</center></td>[lf]"
        write "<td background=[dq]/common/border+5"+http_encode:opt+"[dq]></td>[lf]"
        write "</tr><tr>[lf]"
        write "<td><img src=[dq]/common/border+3"+http_encode:opt+"[dq]></td>[lf]"
        write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
        write "<td><img src=[dq]/common/border+5"+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+3"+http_encode:opt+"[dq]></td>[lf]"
        write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
        write "<td><img src=[dq]/common/border+5"+http_encode:opt+"[dq]></td>[lf]"
      write "</tr><tr>[lf]"
      write "<td background=[dq]/common/border+3"+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+0"+http_encode:opt+"[dq]></td>[lf]"
      write "<td bgcolor=[dq]#"+string:c+"[dq]></td>[lf]"
      write "<td><img src=[dq]/common/corner+1"+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]>"
        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]>"
        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+5"+http_encode:opt+"[dq]></td>[lf]"
      write "</tr><tr>[lf]"
      write "<td><img src=[dq]/common/border+6"+http_encode:opt+"[dq]></td>[lf]"
      write "<td background=[dq]/common/border+7"+http_encode:opt+"[dq]></td>[lf]"
      write "<td><img src=[dq]/common/border+8"+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+2"+http_encode:opt+"[dq]></td>[lf]"
      write "<td bgcolor=[dq]#"+string:c2+"[dq]></td>[lf]"
      write "<td><img src=[dq]/common/corner+3"+http_encode:opt+"[dq]></td>[lf]"
    write "</tr></table>[lf]"


method p html_fixed_end m
  arg_rw HtmlPage p ; arg Int m
  p tag "/fixed" ""
  p do_not_use_Int := m
  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]"


meta '. fixed' e
  if e:size<>2 or not (e:0 cast HtmlPage)
    return
  eif (entry_type e:1:value)=Str
    return
  e suckup e:0
  var Link:Argument m :> argument local Int
  e add (instruction (the_function '. html_fixed_begin' Html
  e:1 compile ?
  e suckup e:1
  e add (instruction (the_function '. html_fixed_end' HtmlPa
  e set_void_result
  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]"


method p html_lsh_color_begin l s h
  arg_rw HtmlPage p ; arg Float l s h
  p tag "color" "color "+(string (lsh_pixel l s h):html_enco
  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 "<table><tr><td><tt>"
    write label+"<tt>[lf]"
    write "<pdata path=[dq]"+path+"[dq]>"+value+"</pdata>[lf]"
    write "</tt>[lf]"
    if has:rows
      write "</tt></td></tr></table>"


method p html_rgb_color_begin r g b
  arg_rw HtmlPage p ; arg Int r g b
  p tag "color" "color [dq]"+(rgb_pixel r g b):html_encoding
  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]")
      write "<img src=[dq]"+url+"[dq] align=[dq]middle[dq] "+event+"="+action+">"
    if not has:noeol
      write "<br>[lf]"


method p html_color_end
  arg_rw HtmlPage p
  p tag "/color" ""
  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]")
    write "<img src=[dq]"+url+"[dq] align=[dq]middle[dq] alt=[dq]"+help+"[dq] "+event+"="+action+">"


meta '. color' e
  if e:size<2 or not (e:0 cast HtmlPage)
    return
  e suckup e:0
  var Link:Function f
  if e:1:ident="lsh" and e:size=6 and (e:2 cast Float) and (
    f :> the_function '. html_lsh_color_begin' HtmlPage Floa
  eif e:1:ident="rgb" and e:size=6 and (e:2 cast Int) and (e
    f :> the_function '. html_rgb_color_begin' HtmlPage Int 
  else
    return
  for (var Int i) 2 e:size-2
    e suckup e:i
  if e:size=6
    e add (instruction f e:0:result e:2:result e:3:result e:
  else
    e add (instruction f e:0:result e:2:result)
  e:(e:size-1) compile ? ; e suckup e:(e:size-1)
  e add (instruction (the_function '. html_color_end' HtmlPa
  e set_void_result
  style_open listing
    write "<p>[lf]<tt>[lf]"
    push fixed is_active true
  style_close listing
    write "</tt>[lf]</p>[lf]"


method p highlight msg
  arg_rw HtmlPage p ; arg Str msg
  p tag "highlight" ""
  p text msg
  p tag "/highlight" ""
  
export '. center' '. bold' '. italic' '. big' '. small' '. f



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


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


simple_bloc_tag list
simple_bloc_tag item

export '. list' '. item'


#-----------------------------------------------------------
# tables


method p html_table_begin columns padding spacing border m1 
  arg_rw HtmlPage p ; arg Int columns padding spacing border
  var Pointer:Int nb :> p:env kmap "default table columns" I
  var Pointer:Int cur :> p:env kmap "default table cursor" I
  if (p:do_not_use_Int .and. 2)<>0
    var Str tid := generate_id
    var (Pointer List:Str) ids :> p:env kmap "default id" Li
    ids += tid
  m1 := nb
  m2 := cur
  p tag "table" "id [dq]"+tid+"[dq] padding [dq]"+string:pad
  nb := columns
  cur := 0

method p html_table_end m1 m2
  arg_rw HtmlPage p ; arg Int m1 m2
  p tag "/table" ""
  p:env kmap "default table columns" Int := m1
  p:env kmap "default table cursor" Int := m2
  if (p:do_not_use_Int .and. 2)<>0
    var (Pointer List:Str) ids :> p:env kmap "default id" Li
    ids remove ids:last

meta '. table' e
  if e:size<2 or not (e:0 cast HtmlPage)
    return
  var Int i := 1
  var Pointer:Argument columns :> argument constant Int 2
  var Pointer:Argument padding :> argument constant Int 4
  var Pointer:Argument spacing :> argument constant Int 1
  var Pointer:Argument border :> argument constant Int 1
  var Pointer:Argument m1 :> argument local Int
  var Pointer:Argument m2 :> argument local Int
  while i<e:size-1
    if e:i:ident="columns" and i+1<e:size-1 and (e:(i+1) cas
      e suckup e:(i+1)
      columns :> e:(i+1) result
      i += 2
    eif (e:i:ident="padding" or e:i:ident="enlarge") and i+1
      e suckup e:(i+1)
      padding :> e:(i+1) result
      i += 2
    eif e:i:ident="spacing" and i+1<e:size-1 and (e:(i+1) ca
      e suckup e:(i+1)
      spacing :> e:(i+1) result
      i += 2
    eif e:i:ident="border" and i+1<e:size-1 and (e:(i+1) cas
      e suckup e:(i+1)
      border :> e:(i+1) result
      i += 2
    else
      return
  e suckup e:0
  e add (instruction (the_function '. html_table_begin' Html
  e:(e:size-1) compile ?
  e suckup e:(e:size-1)
  e add (instruction (the_function '. html_table_end' HtmlPa
  e set_void_result


method p cell_id -> options
  arg_rw HtmlPage p ; arg Str options
  if (p:do_not_use_Int .and. 2)<>0
    var Str cid := generate_id
    var (Pointer List:Str) ids :> p:env kmap "default id" Li
    ids += cid
    options := "id [dq]"+cid+"[dq] "
  else
    options := ""

method p html_cell_begin
method p read_only_begin
  arg_rw HtmlPage p
  arg_rw HtmlPage p
  var Pointer:Int cur :> p:env kmap "default table cursor" I
  if cur=0
    p tag "row" ""
  p tag "cell" p:cell_id
  p:html_stack mark
  p push input is_read_only true


method p html_header_cell_begin
  arg_rw HtmlPage p
  var Pointer:Int cur :> p:env kmap "default table cursor" I
  if cur=0
    p tag "row" ""
  p tag "cell" p:cell_id+"header"
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 html_lsh_cell_begin l s h
  arg_rw HtmlPage p ; arg Float l s h
  if l=undefined or s=undefined or h=undefined
    p html_cell_begin
    return
  var Pointer:Int cur :> p:env kmap "default table cursor" I
  if cur=0
    p tag "row" ""
  p tag "cell" p:cell_id+"ground [dq]"+(lsh_pixel l s h):htm

method p html_rgb_cell_begin r g b
  arg_rw HtmlPage p ; arg Int r g b
  if r<0 or r>=256 or g<0 or g>=256 or b<0 or b>=256
    p html_cell_begin
    return
  var Pointer:Int cur :> p:env kmap "default table cursor" I
  if cur=0
    p tag "row" ""
  p tag "cell" p:cell_id+"ground [dq]"+(rgb_pixel r g b):htm

method p html_cell_end
method p read_only_end
  arg_rw HtmlPage p
  arg_rw HtmlPage p
  p tag "/cell" ""
  var Pointer:Int nb :> p:env kmap "default table columns" I
  var Pointer:Int cur :> p:env kmap "default table cursor" I
  cur += 1
  if cur=nb
    p tag "/row" ""
    cur := 0
  if (p:do_not_use_Int .and. 2)<>0
    var (Pointer List:Str) ids :> p:env kmap "default id" Li
    ids remove ids:last
  p:html_stack rewind


meta '. cell' e
  if e:size<2 or not (e:0 cast HtmlPage)
meta '. read_only' e
  if e:size<1 or not (e:0 cast HtmlPage)
    return
    return
  var Int i := 1
  var Int lsh_color := undefined
  var Int rgb_color := undefined
  var CBool header := false
  while i<e:size-1
    if e:i:ident="color" and i+4<e:size-1 and e:(i+1):ident=
      lsh_color := i+2
      i += 5
    eif e:i:ident="color" and i+4<e:size-1 and e:(i+1):ident
      rgb_color := i+2
      i += 5
    eif e:i:ident="header"
      header := true
      i += 1
    else
      return
  e suckup e:0
  if lsh_color=defined
    e suckup e:lsh_color
    e suckup e:(lsh_color+1)
    e suckup e:(lsh_color+2)
    e add (instruction (the_function '. html_lsh_cell_begin'
  eif rgb_color=defined
    e suckup e:rgb_color
    e suckup e:(rgb_color+1)
    e suckup e:(rgb_color+2)
    e add (instruction (the_function '. html_rgb_cell_begin'
  eif header
    e add (instruction (the_function '. html_header_cell_beg
  else
    e add (instruction (the_function '. html_cell_begin' Htm
  e:(e:size-1) compile ?
  e suckup e:(e:size-1)
  e add (instruction (the_function '. html_cell_end' HtmlPag
  e set_void_result
  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


export '. table' '. cell'
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'


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


method p html_input ident data fun label length flags
  arg_rw HtmlPage p ; arg Str ident ; arg Universal data ; a


method p html_input ident data fun label length flags
  arg_rw HtmlPage p ; arg Str ident ; arg Universal data ; a
  p tag "input" "label [dq]"+html_encode:label+"[dq] type [d
  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


  method p data_input d label length flags
    arg_rw HtmlPage p ; arg Data_ d ; arg Str label ; arg In
    if (d:interface get d addressof:(var Str value) Str)=fai
      value := ""
  if (flags .and. 1)<>0
    p eol


  method p data_input d label length flags
    arg_rw HtmlPage p ; arg Data_ d ; arg Str label ; arg In
    if (d:interface get d addressof:(var Str value) Str)=fai
      value := ""
    p text label
    if p:read_only_mode
      p tag "pdata" "path [dq]"+d:path+"[dq] value [dq]"+htm
    if (p attribute input is_read_only)
      p pdata label label path d:path value value
    else
      var Str dpath := replace (replace d:path "&#" "(") ";"
    else
      var Str dpath := replace (replace d:path "&#" "(") ";"
      p tag "input" "type [dq]"+(shunt (flags .and. 2)=0 "te
      p input label label type (shunt (flags .and. 2)=0 "text" "password") name "|"+dpath+"|"+(p:request generate_signature d:path) value value length length database
    if (flags .and. 1)<>0
      p eol


method p html_text_input label ident value nx ny
  arg_rw HtmlPage p ; arg Str label ident value ; arg Int nx
    if (flags .and. 1)<>0
      p eol


method p html_text_input label ident value nx ny
  arg_rw HtmlPage p ; arg Str label ident value ; arg Int nx
  p tag "textarea" "label [dq]"+html_encode:label+"[dq] name
  p textarea label label name ident columns nx rows ny value value




  method p data_text_input d label nx ny
    arg_rw HtmlPage p ; arg Data_ d ; arg Str label ; arg In
  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)=fai
      value := ""
    if (d:interface get d addressof:(var Str value) Str)=fai
      value := ""
    if p:read_only_mode
      p table columns 1 border 0
        p cell
          p fixed
            p tag "pdata" "label [dq]"+html_encode:label+"[d
            # p text 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 "&#" "(") ";"
    else
      var Str dpath := replace (replace d:path "&#" "(") ";"
      p tag "textarea" "label [dq]"+html_encode:label+"[dq] 
      p textarea label label name "|"+dpath+"|"+(p:request generate_signature d:path) 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 St
    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
    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
      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 In
      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

meta '. text_input' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast St
    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
    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
      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 In
      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' Htm
    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' Htm
  if eol
    e add (instruction (the_function '. text' HtmlPage Str) 
  e set_void_result


  else
    e add (instruction (the_function '. html_text_input' Htm
  if eol
    e add (instruction (the_function '. text' HtmlPage Str) 
  e set_void_result


method p html_select_begin ident data fun label
  arg_rw HtmlPage p ; arg Str ident ; arg Universal data ; a
  p tag "select" "label [dq]"+html_encode:label+"[dq] name [
  p:env kmap "default select active" Bool := true
  p:env kmap "default select value" Str := to_string data "r
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

method p html_select_end
  arg_rw HtmlPage p
  p tag "/select" ""
  p:env kmap "default select active" Bool := false
  p select_end
  p:html_stack rewind
 
if database

 
if database

  method p data_select_begin d label
    arg_rw HtmlPage p ; arg Data_ d ; arg Str label
  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)=fai
      value := ""
    if (d:interface get d addressof:(var Str value) Str)=fai
      value := ""
    if p:read_only_mode
      p tag "pdata" "label [dq]"+html_encode:label+"[dq] pat
    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
    else
      p push select_begin is_active true
      var Str dpath := replace (replace d:path "&#" "(") ";"
      var Str dpath := replace (replace d:path "&#" "(") ";"
      p tag "select" "label [dq]"+html_encode:label+"[dq] na
    p:env kmap "default select active" Bool := not p:read_on
    p:env kmap "default select value" Str := value
      p select_begin label label name "|"+dpath+"|"+(p:request generate_signature d:path) value value database
  
  method p data_select_end
    arg_rw HtmlPage p
  
  method p data_select_end
    arg_rw HtmlPage p
    if not p:read_only_mode
      p tag "/select" ""
    p:env kmap "default select active" Bool := false
    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 St
    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
    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
    if addressof:function=null or addressof:function=address
      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
   
meta '. select' e
  if e:size<4 or not (e:0 cast HtmlPage) or not (e:1 cast St
    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
    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
    if addressof:function=null or addressof:function=address
      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' H
    e add (instruction (the_function '. data_select_begin' HtmlPage Str Data_) e:0:result e:1:result e:2:result)
  else
  else
    e add (instruction (the_function '. html_select_begin' H
    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' Htm
  else
    e add (instruction (the_function '. html_select_end' Htm
  if eol
    e add (instruction (the_function '. text' HtmlPage Str) 
  e set_void_result


  e suckup (e e:size-1)
  if database and data
    e add (instruction (the_function '. data_select_end' Htm
  else
    e add (instruction (the_function '. html_select_end' Htm
  if eol
    e add (instruction (the_function '. text' HtmlPage Str) 
  e set_void_result


method p option label value
  arg_rw HtmlPage p; arg Str label value
  var CBool selected := value=(p:env kmap "default select va
  if (p:env kmap "default select active" Bool)
    p tag "option" (shunt selected "selected " "")+"label [d
  eif selected
    p fixed
      p text label


method p html_file_upload label ident
  arg_rw HtmlPage p ; arg Str label ident
method p html_file_upload label ident
  arg_rw HtmlPage p ; arg Str label ident
  p tag "input" "label [dq]"+html_encode:label+"[dq] type [d
  p input label label type "file" name "file upload "+ident


#-----------------------------------------------------------


#-----------------------------------------------------------
# buttons


method p html_button label id context
  arg_rw HtmlPage p ; arg Str label id context
  p tag "button" "id [dq]"+"button 0 0 "+id+" "+(p:request c

meta '. button' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast St
    return
  var CBool eol := true
  var Str options := ""
  var Int i := 2
  while i<e:size-1
    if e:i:ident="noeol"
      eol := false
      i += 1
    eif e:i:ident="stay"
      options += " stay"
      i += 1
    eif e:i:ident="nostay"
      options += " nostay"
      i += 1
    else
      return
  if not (button_expression e options (var Str button_id) (v
    return
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function '. html_button' HtmlPage 
  if eol
    e add (instruction (the_function '. text' HtmlPage Str) 
  e set_void_result


method p html_icon url help id context
  arg_rw HtmlPage p ; arg Str url help id context
  var Str action := "[dq]button_pressed('button 0 0 "+id+" "
  var Str event := " onClick="+action
  if p:http_request:browser_model="netscape"
    event += " onMouseUp="+action
  p html "<img src=[dq]"+html_encode:url+"[dq] alt=[dq]"+htm

meta '. icon' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast St
    return
  var Link:Argument help :> argument constant Str ""
  var Str options := ""
  var Int i := 2
  while i<e:size-1
    if e:i:ident="help" and i+1<e:size-1 and (e:(i+1) cast S
      e suckup e:(i+1)
      help :> e:(i+1) result
      i += 2
    eif e:i:ident="stay"
      options += " stay"
      i += 1
    eif e:i:ident="nostay"
      options += " nostay"
      i += 1
    else
      return
  if not (button_expression e options (var Str button_id) (v
    return
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function '. html_icon' HtmlPage St
  e set_void_result


method p html_popup url help size_x size_y id context
  arg_rw HtmlPage p ; arg Str url help ; arg Int size_x size
  var Str event := shunt p:http_request:browser_model="netsc
  p html "<img src=[dq]"+html_encode:url+"[dq] alt=[dq]"+htm

meta '. popup' e
  if e:size<3 or not (e:0 cast HtmlPage) or not (e:1 cast St
    return
  var Link:Argument help :> argument constant Str ""
  var Link:Argument size_x :> argument constant Int 512
  var Link:Argument size_y :> argument constant Int 256
  var Str options := ""
  var Int i := 2
  while i<e:size-1
    if e:i:ident="help" and i+1<e:size-1 and (e:(i+1) cast S
      e suckup e:(i+1)
      help :> e:(i+1) result
      i += 2
    eif e:i:ident="size" and i+2<e:size-1 and (e:(i+1) cast 
      e suckup e:(i+1) ; e suckup e:(i+2)
      size_x :> e:(i+1) result ; size_y :> e:(i+2) result
      i += 3
    eif e:i:ident="stay"
      options += " stay"
      i += 1
    eif e:i:ident="nostay"
      options += " nostay"
      i += 1
    else
      return
  if not (button_expression e options (var Str button_id) (v
    return
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function '. html_popup' HtmlPage S
  e set_void_result

method page close
  arg_rw HtmlPage page
  if (page:env first "default dynamic")=null
    page:http_request answer_is_dynamic := true
  page html "<script language=[dq]JavaScript[dq]>[lf]"
  page html "  window.opener.location.reload(true)[lf]"
  page html "  window.close()[lf]"
  page html "</script>[lf]"
  page:env insert "default backward" true entry_new:Void


method p html_note label id context
  arg_rw HtmlPage p ; arg Str label id context
  p tag "note_link" "url [dq]"+p:request:url_path+"?button+0

meta '. note' e
  if e:size<>3 or not (e:0 cast HtmlPage) or not (e:1 cast S
    return
  if not (button_expression e "" (var Str button_id) (var Li
    return
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function '. html_note' HtmlPage St
  e set_void_result

method p html_note_begin width
  arg_rw HtmlPage p ; arg Float width
  p tag "note_right" "width [dq]"+string:(cast width*100 Int

method p html_note_end
  arg_rw HtmlPage p
  p tag "/note_right" ""
  
meta '. note' e
  if e:size=4 and (e:0 cast HtmlPage) and e:1:ident="right" 
    e:3 compile ?
    e suckup e:0 ; e suckup e:2
    e add (instruction (the_function '. html_note_begin' Htm
    e suckup e:3
    e add (instruction (the_function '. html_note_end' HtmlP
    e set_void_result
  eif e:size=3 and (e:0 cast HtmlPage) and e:1:ident="inline
    e:2 compile ?
    e suckup e:0
    e add (instruction (the_function '. tag' HtmlPage Str St
    e suckup e:2
    e add (instruction (the_function '. tag' HtmlPage Str St
    e set_void_result

export '. button' '. icon' '. popup' '. close' '. note'


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



method p listing list
  arg_rw HtmlPage p ; arg List:Str list
#  listing



method p listing list
  arg_rw HtmlPage p ; arg List:Str list
  p tag "listing" ""
  p do_not_use_Int := p:do_not_use_Int .or. 1
  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 color lsh 0 75 200
        p italic
          p text (l i l:len)
    else
      p listing_text2 l
    p eol
    l :> list next l
  p do_not_use_Int := p:do_not_use_Int .and. .not. 1
  p tag "/listing" ""
  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'

multiline_keyword listing
export '. listing'