Patch title: Release 87 bulk changes
Abstract:
File: /pliant/appli/source_browser.pli
Key:
    Removed line
    Added line
# Copyright  Patrice Ossona de Mendez
# Repackaged for new Pliant HTTP layout by Hubert Tonneau
#
# 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/stream.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/protocol/http/server.pli"


constant use_properties false

'pliant watch' Type false := "#C80096"
'pliant watch' Str false := "green"
'pliant watch' Char false := "green"
'pliant watch' InlineText false := "green"
'pliant watch' Function true := "black"
'pliant watch' Meta true := "black"
'pliant watch' GlobalVariable true := "#FF0000"
'pliant watch' LocalVariable true := "#C80032"

type Tag
  field Char kind
  field Pointer:Type key
  field Str link

function apply t s -> s2
  arg Tag t; arg Str s s2
  var Str ss:=s
  if t:kind="C"
    var Str color := "#006446"
    var Pointer:Str eff :> t:key 'pliant is_watched' false
    if exists:eff
      color := eff
      ss := "<font color="+string:color+">"+ss+"</font>"
  eif t:kind="A"
    var Pointer:Str eff :> t:key 'pliant is_watched' true
    if exists:eff
      color := eff
      ss := "<font color="+string:color+">"+ss+"</font>"
  eif t:kind=" "
    ss := replace (html_encode ss true) " " "&nbsp;"
  eif t:kind="#"
    if ss="#"+(repeat (max ss:len-1 3) "-")
      ss := "<hr>"
    else
      ss := "<em><font color='blue'>"+(replace (html_encode ss true) " " "&nbsp;")+"</font></em>"
  if t:link<>""
    ss := "<a href="+t:link+"><b>"+ss+"</b></a>"
  s2 := ss
  
method position decode filename line column
  arg ListingPosition position; arg_w Str filename; arg_w Int line column
  var Str s := cast position Str
  if not (s eparse any:filename _ any:(var Str remain))
    filename:=""; line:=0; column := 0
    return
  if not (remain parse line column)
    remain parse any:(var Str dummy) line column

method fun 'get position' -> pos
  oarg Function fun; arg ListingPosition pos
  return fun:position
    
method met 'get position' -> pos
  oarg Meta met; arg ListingPosition pos
  var Link:Function fun :> addressof:met omap Function
  return fun:position

method gv 'get position' -> pos
  oarg GlobalVariable gv; arg ListingPosition pos
  return gv:position

function fill_tags tags m
  arg_rw (Link Array:(Dictionary Int Tag)) tags ; arg Module m
  if not exists:m
    return
  var Link:Module mm :> m
  if (addressof mm:external)<>null
    mm :> mm external
  if use_properties
    var Pointer:Arrow c :> m:properties first "pliant tags list"
  else
    var Pointer:Arrow c :> m first "pliant tags list "+mm:name
  if c=null
    console "no tags for this module" eol
    return
  var Link:ListingTags lt :> c map ListingTags
  var ListingTag xt
  var Address a := lt first
  while a<>null
    xt := lt get a
    var Int line := xt line
    var Int column := xt:column-1
    c :> xt value
    a := lt next a
    var Tag t
    if c<>null and entry_type:c=TagMarker
      var Int s := tags:size
      tags := new Array:(Dictionary Int Tag)
      tags size := s
    eif line<tags:size
      if c<>null and exists:(entry_type:c 'pliant is_watched' true)
        t:kind:="A"; t:key:>entry_type:c
        var Link:Universal data :> c omap Universal
        data:'get position' decode (var Str filename) (var Int lin) (var Int col)
        if filename<>""
          t link := filename+"#line"+string:lin
        else
          t link := ""
        tags:line insert column t
      eif c<>null
        console "C " entry_type:c:name eol
        t:kind:="C"; t:key:>entry_type:c; t:link:=""
        if entry_type:c=Type
          var Link:Type typ :> c map Type
          typ:position decode (var Str filename) (var Int lin) (var Int col)
          if filename<>""
            t link := filename+"#line"+string:lin
        tags:line insert column t
      else
        t:kind:="C"; t:key:>null map Type; t:link:=""
        tags:line insert column t

type ApplyStack
  field List:Tag tstack
  field List:Str left
  field Str piece <- ""

method as purge
  arg_rw ApplyStack as
  var Pointer:Tag sc
  while {sc :> as:tstack:last; exists:sc}
    as:piece := as:left:last+(apply sc as:piece)
    as:tstack -= sc
    as:left -= as:left:last
    
method as push t
  arg_rw ApplyStack as; arg Tag t
  as:tstack += t
  as:left += as:piece
  as:piece := ""

function source_listing filename server http
  arg Str filename ; arg_rw HttpServer server ; arg_rw Stream http
  (var Stream src) open filename in+safe
  var Link:(List Str) pgm :> new (List Str)
  while not src:atend
    pgm += new Str src:readline
  var Link:(Array (Dictionary Int Tag)) tags :> new (Array (Dictionary Int Tag))
  tags size := pgm:size+1
  var Link:Module module :> (pliant_module_dictionary first filename) map Module
  if not exists:module and (reverse:filename eparse (pattern reverse:".page") any:(var Str filebase))
    if exists:server
      var Link:DynamicPage dp :> server find_dynamic_page filename
      if exists:dp
        module :> (dp:function:properties first "module") map Module
      else
        console filename " module not found" eol
  # if not exists:module
  #   console "module " filename " not loaded" eol
  fill_tags tags module
  http writeline "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2//EN[dq]>"
  http writeline "<html>"
  http writeline "<head>"
  http writeline "<meta http-equiv=[dq]Content-Type[dq] content=[dq]text/html; charset=iso-8859-1[dq]>"
  http writeline "<title>Listing of file "+html_encode:filename+"</title>"
  http writeline "<style TYPE=[dq]text/css[dq]>"
  http writeline "<!--"
  http writeline "A:link, A:visited, A:active { text-decoration: none; color: black}"
  http writeline "-->"
  http writeline "</style>"
  http writeline "</head>"
  http writeline "<body bgcolor='white'><table column=3 border=0 cellpadding=0 cellspacing=0>"
  http writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
  http writechars "<tr><td colspan=3 bgcolor='#FFF0E6'><tt><center><big>"
  http writeline html_encode:filename+"</big></center></tt></td></tr>"
  http writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
  var Int l := 1
  each line pgm
    http writechars "<tr><td bgcolor='#FFF0E6'><tt>&nbsp;<a name=[dq]line"+string:l+"[dq]></a><small>"+string:l+"</small>&nbsp;</tt></td><td><tt>"
    var Link:ApplyStack as :> new ApplyStack
    http eol
    var Int s := 0
    var Bool neutral:=false
    var Bool in_str := false
    while s<line:len
      var Pointer:Tag cur :> tags:l first s
      if exists:cur
        neutral := false
        as purge # purge the stack
        while exists:cur # should be only one
          as push cur
          cur :> tags:l next s cur
      if line:s="#"
        as purge # purge the stack
        var Tag t; t:kind:="#"; t key:>null map Type; t:link:=""
        as push t
        as piece := (line s line:len)
        s := line:len
        as purge
      eif line:s="[dq]"
        as purge
        var Tag t; t:kind:="C"; t key:>Str; t link:=""
        as push t
        t:kind:=" "
        as push t
        var Int length := 2+((line s+1 line:len) search "[dq]" line:len)
        as piece := (line s length)
        s+=length
        as purge
      else
         if not neutral
           var Tag t; t:kind:=" "; t key:>null map Type; t:link:=""
           as push t
           neutral := true
         as piece += line:s
         s += 1
    as purge
    http writeline as:piece+"</tt></td><td bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
    l += 1
  http writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
  http writeline "</table>"
  http writeline "</body>"
  http writeline "</html>"

export source_listing


if false # deprecated filters
   
  function c_filter src dest options
    arg_rw Stream src dest ; arg_rw Str options
    dest writeline "module [dq]/pliant/protocol/http/style/listing.style[dq] #"
    var CBool doc := false
    while not src:atend
      var Str line := src readline
      if doc
        if (line parse "*/")
          doc := false
        eif (line parse "doc")
          dest writeline "table columns 1 border 0"
          dest writeline "  [0]left_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number-1)+" 1[0]"
          dest writeline "  cell color (color hsl 60 10 80)"
        else
          dest writeline "  "+line
      eif (line parse "/*")
        line := src readline
        if line="doc" or line="abstract"
          dest writeline "table columns 1 border 0"
          dest writeline "  [0]left_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number-1)+" 1[0]"
          if line="doc"
            dest writeline "  cell color (color hsl 60 10 80)"
          else
            dest writeline "  cell color (color hsl 60 35 80)"
          doc := true
        else
          dest writeline "raw_line "+string:"/*"
          dest writeline "raw_line "+string:line
      eif line:len>10 and line="/"+(repeat line:len-2 "*")+"/"
        dest writeline "horizontal_line"
      eif (line eparse any:(var Str base) "///" offset:(var Int offset1) spaces:(var Str drop) offset:(var Int offset2) any:(var Str comment))
        if (comment parse word:"section" (var Str drop))
          dest writeline comment ; comment := ""
        dest writeline "raw_characters "+string:(line 0 offset1-3)
        if comment<>""
          dest writeline "[0]right_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number)+" "+string:offset2+"[0]"+comment
        dest writeline "eol"
      eif (line parse any:(var Str base) "//" any:(var Str comment))
        dest writeline "section "+(string "comment "+comment)
        dest writeline "raw_line "+string:line
      else
        dest writeline "raw_line "+string:line


  # xlHtml has been removed because it tends to run forever
  constant xlhtml "" # (shunt (file_query "embedded:/usr/bin/xlhtml" standard)=success "xlhtml" (file_query "embedded:/usr/bin/xlHtml" standard)=success "xlHtml" "")
  constant wvhtml "" # (shunt (file_query "embedded:/usr/bin/wvHtml" standard)=success "wvHtml" "")
  
  if xlhtml<>""
    module "/pliant/language/unsafe.pli"
    module "/pliant/admin/file.pli"
    module "/pliant/admin/execute.pli"
  
    function xls_filter src dest options
      arg_rw Stream src dest ; arg_rw Str options
      var Str temp1 := replace file_temporary "file:/" "embedded:/"
      (var Stream s) open temp1 out+safe
      while not src:atend
        src read_available (var Address adr) (var Int size)
        s raw_write adr size
      s close
      var Str temp2 := replace file_temporary "file:/" "embedded:/"
      execute xlhtml+" "+file_os_name:(replace temp1 "embedded:/" "file:/") root "embedded:/" path "embedded:/" output temp2
      (var Stream s) open temp2 in+safe
      while not s:atend
        s read_available (var Address adr) (var Int size)
        dest raw_write adr size
      s close
      file_delete temp1
      file_delete temp2
      options += " mime [dq]text/html[dq]"
    declare_mime_static_filter ".xls" (the_function xls_filter Stream Stream Str)
    declare_mime_static_filter ".XLS" (the_function xls_filter Stream Stream Str)
  
  if wvhtml<>""
    module "/pliant/language/unsafe.pli"
    module "/pliant/admin/file.pli"
    module "/pliant/admin/execute.pli"
  
    function doc_filter src dest options
      arg_rw Stream src dest ; arg_rw Str options
      var Str temp1 := replace file_temporary "file:/" "embedded:/"
      (var Stream s) open temp1 out+safe
      while not src:atend
        src read_available (var Address adr) (var Int size)
        s raw_write adr size
      s close
      var Str temp2 := (replace file_temporary "file:/" "embedded:/")+"/"
      file_tree_create temp2
      execute wvhtml+" --targetdir="+file_os_name:(replace temp2 "embedded:/" "file:/")+" "+file_os_name:(replace temp1 "embedded:/" "file:/")+" document.html" root "embedded:/" path "embedded:/"
      (var Stream s) open temp2+"document.html" in+safe
      while not s:atend
        s read_available (var Address adr) (var Int size)
        dest raw_write adr size
      s close
      file_delete temp1
      file_tree_delete temp2  
      options += " mime [dq]text/html[dq]"
    declare_mime_static_filter ".doc" (the_function doc_filter Stream Stream Str)
    declare_mime_static_filter ".DOC" (the_function doc_filter Stream Stream Str)