Patch title: Release 87 bulk changes
Abstract:
File: /pliant/protocol/http/style/common.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/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/compiler.pli"
module "/pliant/language/parser.pli"
module "/pliant/admin/file.pli"
module "/pliant/protocol/http/server.pli"
module "/pliant/protocol/common/mime.pli"
module "common.pli"


#---------------------------------------------------------------------------
#  basic


method p head s
  arg_rw HtmlPage p ; arg Str s
  var Pointer:Stream stream :> p http_stream
  var Address start := stream stream_write_buf
  var Address cur := stream stream_write_cur
  var Address stop := stream stream_write_stop
  if (cast stop Int).-.(cast cur Int)>=s:len
    var Address a := memory_search start (cast cur Int).-.(cast start Int) "</head>":characters 7
    if a<>null
      memory_move a (a translate Byte s:len) (cast cur Int).-.(cast a Int)
      memory_copy s:characters a s:len
      stream stream_write_cur := cur translate Byte s:len
      return
  stream writechars "[dq]"
  stream writechars s

method p flush
  arg_rw HtmlPage p
  p:http_stream flush anytime

function 'cast Status' p -> s
  arg HtmlPage p ; arg Status s
  s := cast p:http_stream Status


method p virtual_command -> c
  arg HtmlPage p ; arg_C Str c
  c :> p:http_request command


method p lang -> l
  arg HtmlPage p ; arg_C Str l
  l :> p:http_request lang


export '. head' '. flush' 'cast Status' '. virtual_command' '. lang'


#---------------------------------------------------------------------------
#  authentification


method p user_name -> u
  arg_rw HtmlPage p ; arg Str u
  u := p:request user_name

method p allowed name -> a
  arg_rw HtmlPage p ; arg Str name ; arg CBool a
  a := p:request allowed name

method p is_not_allowed name -> failed
  arg_rw HtmlPage p ; arg Str name ; arg CBool failed
  failed := not (p:request allowed name)
  if failed
    p reset_http_answer
    p:request send_authentification_request

meta requires e
  if e:size=1 and (e:0 cast Str)
    e compile_as (expression immediat (if is_not_allowed:name return) substitute name e:0)

export '. user_name' '. allowed' requires '. is_not_allowed'


#---------------------------------------------------------------------------
#  [] inline text


function active_type itext access e
  arg InlineText itext ; arg Int access ; arg_rw Expression e
  if ("[dq]"+(addressof:itext map Str)+"[dq]" parse (var Str t))
    var Link:Str text :> new Str t
    if e:size=0
      e compile_as (expression immediat (page text t) substitute t (expression constant text near e))


#---------------------------------------------------------------------------
# driving the browser


method page goto_hyperlink target autoext section options
  arg_rw HtmlPage page ; arg Str target ; arg CBool autoext ; arg Str section options
  var Str without_path := target (target search_last "/" -1)+1 target:len
  var Str t := target
  if autoext and without_path:len<>0 and (without_path search "." -1)=(-1) and (without_path search ":" -1)=(-1)
    t += ".html"
  if section<>""
    t += "#"+http_encode:section
  if options<>""
    t += "?"+http_encode:options
  page:http_request answer_is_dynamic := true
  page html "<script language=[dq]JavaScript[dq]>[lf]"
  page html "  location.replace([dq]"+t+"[dq])[lf]"
  page html "</script>[lf]"
  page html "Your browser is not very smart. You should select <a href=[dq]"+t+"[dq]>this link</a> to get the right page."
  
meta '. goto_url' e
  if e:size<2 or not (e:0 cast HtmlPage) or not (e:1 cast Str)
    return
  e suckup e:0 ; e suckup e:1
  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 := 2
  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 Str)
      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 Str)
      e suckup e:(i+1)
      options :> e:(i+1):result
      i += 2
    else
      return
  e add (instruction (the_function '. goto_hyperlink' HtmlPage Str CBool Str Str) e:0:result e:1:result autoext section options)
  e set_void_result


method page goto_backward n
  arg_rw HtmlPage page ; arg Int n
  page:http_request answer_is_dynamic := true
  page html "<script language=[dq]JavaScript[dq]>[lf]"
  var Int x := undefined ; var Int y := undefined
  part search
    if n=0
      if ("&"+page:http_request:form+"&" eparse any "&_pliant_x=" (var Int x) "&" any) and ("&"+page:http_request:form+"&" eparse any "&_pliant_y=" (var Int y) "&" any)
        leave search
      eif (page:http_request:url_options parse "button+" (var Int x) "+" (var Int y) "+" any)
      eif (page:http_request:encoded_options parse "button+" (var Int x) "+" (var Int y) "+" any)
        leave search
    eif n=1
      var Pointer:Arrow c :> page:http_request:query_log first
      while c<>null
        if ((c map Str) parse acword:"referer" ":" any "?button+" x "+" y "+" any)
          leave search
        c :> page:http_request:query_log next c
  if x=defined and y=defined
    var Str spos := (character 65+x\17576)+(character 65+x\676%26)+(character 65+x\26%26)+(character 65+x%26)+(character 65+y\17576)+(character 65+y\676%26)+(character 65+y\26%26)+(character 65+y%26)
    page html "    window.name = '_xy_"+spos+"_'+window.name[lf]"
  if page:http_request:browser_model="netscape"
    page html "  history.go(-"+(string n+1)+")[lf]"
  eif false # page:http_request:browser_model="ie" and page:http_request:browser_release<6
    page html "  window.name = '_reload_'+window.name[lf]"
    page html "  history.go(-"+(string n+1)+")[lf]"
  else # Mozilla 0.9.8, IE 6, Opera 6 and Konqueror
    page html "  window.name = '_back_"+(character 65+n)+"__reload_'+window.name[lf]"
  page html "</script>[lf]"
  page html "<p>Now computing ...</p><p><font size=[dq]-1[dq]>If your browser is not smart enough to switch back automatically when the computation is over, then you'll have to press the Back button "+(string n+1)+" time"+(shunt n>=1 "s" "")+" and then the reload button.</font></p>"

method page reload_page
  arg_rw HtmlPage page
  page goto_backward 0

method page goto_backward
  arg_rw HtmlPage page
  page goto_backward 1


export '. goto_url' '. reload_page' '. goto_backward'