Patch title: Release 85 bulk changes
Abstract:
File: /pliant/protocol/http/pli_filter.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/unsafe.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/parser.pli"
module "/pliant/util/encoding/http.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/admin/file.pli"

gvar (Dictionary Str Str) constant_effects active_effects

implicit constant_effects
  insert "Type" "#C80096"
  insert "Str" "green"
  insert "Char" "green"
  insert "InlineText" "green"
  
implicit active_effects
  insert "GlobalVariable" "#FF0000"
  insert "LocalVariable"  "#C80032"

type Tag
  field Char kind
  field Str 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 Link:Str eff :> constant_effects first t:key
    if exists:eff
      color := eff
      ss := "<font color="+string:color+">"+ss+"</font>"
  eif t:kind="A"
    var Link:Str eff :> active_effects first t:key
    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

function fill_tags tags m
  arg_rw Link:(Array (Dictionary Int Tag)) tags; arg Module m
  if addressof:m=null
    console "module not loaded" eol
    return
  var Link:Module mm :> m
  if addressof:(mm external)<>null
    mm :> mm external
  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 (entry_type:c=Function or entry_type:c=Meta or entry_type:c=GlobalVariable or entry_type:c=LocalVariable)
        t:kind:="A"; t:key:=entry_type:c:name; t:link:=""
        if entry_type:c=Function or entry_type:c=Meta
          var Link:Function fun :> c map Function
          fun:position decode (var Str filename) (var Int lin) (var Int col)
          if filename<>""
            t link := filename+"#line"+string:lin
        eif entry_type:c=GlobalVariable
          var Link:GlobalVariable gv :> c map GlobalVariable
          gv:position decode (var Str filename) (var Int lin) (var Int col)
          if filename<>""
            t link := filename+"#line"+string:lin
        tags:line insert column t
      eif c<>null
        t:kind:="C"; t:key:=entry_type:c:name; 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:=""; 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 common_filter ins outs filename module
  arg_rw Stream ins outs; arg Str filename; arg Module module
  var Arrow a
  var Link:(List Str) pgm :> new (List Str)
  var Link:List program :> new List
  while not ins:atend
    var Link:Str src_line :> new Str ins:readline
    pgm += src_line
    program append addressof:src_line
  var Link:(Array (Dictionary Int Tag)) tags :> new (Array (Dictionary Int Tag))
  tags size := pgm:size+1
  fill_tags tags module

  var Int l := 1
  outs writeline "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2//EN[dq]>"
  outs writeline "<HTML>"
  outs writeline "<head>"
  outs writeline "<meta http-equiv=[dq]Content-Type[dq] content=[dq]text/html; charset=iso-8859-1[dq]>"
  outs writeline "<title>Listing of file "+html_encode:filename+"</title>"
  outs writeline "<STYLE TYPE=[dq]text/css[dq]>"
  outs writeline "<!--"
  outs writeline "A:link, A:visited, A:active { text-decoration: none; color: black}"
  outs writeline "-->"
  outs writeline "</STYLE>"
  outs writeline "</head>"
  outs writeline "<body bgcolor='white'><table column=3 border=0 cellpadding=0 cellspacing=0>"
  outs writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
  outs writechars "<tr><td colspan=3 bgcolor='#FFF0E6'><tt><center><big>"
  outs writeline html_encode:filename+"</big></center></tt></td></tr>"
  outs writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
  each line pgm
    outs 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
    outs 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:=""; 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:=""; t:link:=""
           as push t
           neutral := true
         as piece += line:s
         s += 1
    as purge
    outs writeline as:piece+"</tt></td><td bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
    l+=1
  outs writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
  outs writeline "</table></body></HTML>"

function my_pli_filter ins outs opt
  arg_rw Stream ins outs; arg_rw Str opt
  var Str filename := opt option "name" Str
  var Pointer:Arrow c :> pliant_module_dictionary first filename
  common_filter ins outs filename (c map Module)
  opt += " mime [dq]text/html[dq]"

function my_page_filter ins outs opt
  arg_rw Stream ins outs; arg_rw Str opt
  outs writeline "module [dq]/pliant/protocol/http/style/filter.style[dq]"
  outs writeline "send_listing"

export my_pli_filter common_filter my_page_filter