Patch title: Release 85 bulk changes
Abstract:
File: /pliant/appli/forum/display.pli
Key:
    Removed line
    Added line
module "/pliant/language/unsafe.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"
module "/pliant/protocol/http/server.pli"
module "/pliant/protocol/http/style/default.style"
module "database.pli"


method page display_difference1 list
  arg_rw HtmlPage page ; arg List:Str list
  implicit page
    table columns 1 border 0 enlarge 0 
      var Pointer:Str l :> list first
      while exists:l  
        if (l 0 2)=": "
          cell color lsh 80 25 60
          cell color (color hsl 60 25 80)
            italic text:(l 2 l:len)
          l :> list next l
        eif (l 0 2)="- "
          cell color lsh 80 25 0
          cell color (color hsl 0 25 80)
            fixed
              while exists:l and (l 0 2)="- "
                text (l 2 l:len)+"[lf]"
                l :> list next l
        eif (l 0 2)="+ "
          cell color lsh 80 25 120
          cell color (color hsl 120 25 80)
            fixed
              while exists:l and (l 0 2)="+ "
                text (l 2 l:len)+"[lf]"
                l :> list next l
        eif (l 0 2)="  "
          cell
            fixed
              while exists:l and (l 0 2)="  "
                text (l 2 l:len)+"[lf]"
                l :> list next l
        else
          l :> list next l

method page update_section_button patch linenum id
  arg_rw HtmlPage page ; arg Str patch ; arg Int linenum ; arg Str id
  page small
    page button (shunt id<>"" id " ") noeol
      var Str temp := file_temporary
      (var Stream src) open patch in+safe
      (var Stream dest) open temp out+safe
      while not src:atend and { var Str line := src readline ; line<>"" }
        if not (line parse word:"section" ":" any)
          dest writeline line
      var List:Str lines ; var (Index Str Int) sections
      if id<>""
        sections insert id 0
      var Int header := src:line_number+1
      while not src:atend
        var Str line := src readline
        if src:line_number=header+linenum
          if (line 0 2)<>": "
            lines += ": "+id
          else
            line := ": "+id
        if line<>": "
          lines += line
        if (line 0 2)=": " and line:len>2
          if not exists:(sections first (line 2 line:len))
            sections insert (line 2 line:len) 0
      each s sections
        dest writeline "section: "+(sections key s)
      dest writeline ""
      var Pointer:Str l :> lines first
      while exists:l
        dest writeline l
        l :> lines next l
      src close ; dest close
      var FileInfo info := file_query patch standard
      file_configure temp "datetime "+(string info:datetime)
      file_delete patch ; file_move temp patch
      page reload_page

method page update_section_buttons list l patch d current
  arg_rw HtmlPage page ; arg List:Str list ; arg Pointer:Str l ; arg Str patch ; arg Data:ForumDebate d ; arg Str current
  var Int n := 0 ; var Pointer:Str ptr :> list first
  while addressof:ptr<>addressof:l
    n += 1 ; ptr :> list next ptr
  each s d:patch_section
    if keyof:s<>current
      page update_section_button patch n keyof:s
  if current<>""
    page update_section_button patch n ""

method l tabulation -> t
  arg Str l ; arg Int t
  t := 0
  while t<l:len and l:t=" "
    t += 1

method line relative_tabulation previous -> smart
  arg Str line ; arg Str previous ; arg Str smart
  var Int t := line tabulation
  smart := (string t-previous:tabulation)+" "+(line t line:len)

function line_matching l list mapping -> matching
  arg Pointer:Str l ; arg List:Str list ; arg Dictionary mapping ; arg Int matching
  matching := 0
  var Pointer:Str p :> list previous l
  if not exists:p
    p :> ""
  var Str key := (l 2 l:len) relative_tabulation (p 2 p:len)
  var Pointer:Arrow c :> mapping first key
  while c<>null
    var Int m := shunt l:tabulation<l:len 1 0
    var Pointer:Str p :> l
    var Pointer:Str l2 :> list next l
    var Int line_number := (c map Int)+1
    part scan
      while exists:l2 and (l2 0 2)="+ "
        var Str key2 := (l2 2 l2:len) relative_tabulation (p 2 p:len)
        var Pointer:Arrow c2 :> mapping first key2
        while c2<>null and (c2 map Int)<>line_number
          c2 :> mapping next key2 c2
        if c2=null
          leave scan
        if l2:tabulation<l2:len
          m += 1
        p :> l2
        l2 :> list next l2
        line_number += 1
    matching := max matching m
    c :> mapping next key c

method page display_new l list mapping
  arg_rw HtmlPage page ; arg_rw Pointer:Str l ; arg List:Str list ; arg Dictionary mapping
  implicit page
    cell
      table columns 1 border 0 enlarge 0
        while exists:l and (l 0 2)="+ "
          var Int matching := line_matching l list mapping
          if matching<2
            cell color lsh 80 25 120
            cell color (color hsl 120 25 80)
              fixed
                while exists:l and (l 0 2)="+ " and (line_matching l list mapping)<2
                  text (l 2 l:len)+"[lf]"
                  l :> list next l
          else
            cell color lsh 80 10 120
            cell color (color hsl 120 10 80)
              fixed
                while matching>0
                  text (l 2 l:len)+"[lf]"
                  l :> list next l ; matching -= 1

method page display_difference2 list mapping f d modify section path
  arg_rw HtmlPage page ; arg List:Str list ; arg Dictionary mapping ; arg_rw Data:Forum f ; arg_rw Data:ForumDebate d ; arg CBool modify ; arg Str section path
  constant width 60
  implicit page
    table columns 3 border 0 enlarge 0
      cell void ; cell fixed:[   ] ; cell void
      var Pointer:Str l :> list first
      while exists:l  
        if (l 0 2)=": "
          cell color lsh 80 25 60
          cell color (color hsl 60 25 80)
            italic text:(l 2 l:len)
          cell void
          cell color lsh 80 25 60
          cell color (color hsl 60 25 80)
            italic text:(l 2 l:len)
            if modify
              fixed [ ]
              update_section_buttons list l (forum_path f d section+path) d (l 2 l:len)
          l :> list next l
        eif (l 0 2)="- "
          if exists:(list previous l) and ((list previous l) 0 2)<>": "
            cell color lsh 80 25 60
            cell color (color hsl 60 25 80)
              void
            cell void
            cell color lsh 80 25 60
            cell color (color hsl 60 25 80)
              if modify
                update_section_buttons list l (forum_path f d section+path) d ""
          cell color lsh 80 25 0
          cell color (color hsl 0 25 80)
            fixed
              while exists:l and (l 0 2)="- "
                text (l 2 width)+"[lf]"
                l :> list next l
          cell void
          if exists:l and (l 0 2)="+ "
            display_new l list mapping
          else
            cell void
        eif (l 0 2)="+ "
          if exists:(list previous l) and ((list previous l) 0 2)<>": " and ((list previous l) 0 2)<>"- "
            cell color lsh 80 25 60
            cell color (color hsl 60 25 80)
              void
            cell void
            cell color lsh 80 25 60
            cell color (color hsl 60 25 80)
              if modify
                update_section_buttons list l (forum_path f d section+path) d ""
          cell void
          cell void
          display_new l list mapping
        eif (l 0 2)="  "
          var Pointer:Str start :> l ; var CBool cut := false
          cell
            fixed
              while exists:l and (l 0 2)="  "
                if l="  "
                  var Pointer:Str l2 :> list next l
                  while exists:l2 and (l2 0 2)="  " and l2<>"  "
                    l2 :> list next l2
                  if exists:l2 and l2="  " and (addressof:l2<>addressof:(list next l) or cut)
                    if not cut
                      html "<hr>" ; cut := true
                    l :> l2
                  else
                    text (l 2 width)+"[lf]"
                    l :> list next l
                else
                  text (l 2 width)+"[lf]"
                  l :> list next l
          cell void
          l :> start ; var CBool cut := false
          cell
            fixed
              while exists:l and (l 0 2)="  "
                if l="  "
                  var Pointer:Str l2 :> list next l
                  while exists:l2 and (l2 0 2)="  " and l2<>"  "
                    l2 :> list next l2
                  if exists:l2 and l2="  " and (addressof:l2<>addressof:(list next l) or cut)
                    if not cut
                      html "<hr>" ; cut := true
                    l :> l2
                  else
                    text (l 2 width)+"[lf]"
                    l :> list next l
                else
                  text (l 2 width)+"[lf]"
                  l :> list next l
        else
          l :> list next l


method page display_difference patch reference f d modify section path options
  arg_rw HtmlPage page ; arg Str patch reference ; arg_rw Data:Forum f ; arg_rw Data:ForumDebate d ; arg CBool modify ; arg Str section path ; arg Str options
  (var Stream s) open patch in+safe
  while not s:atend and { var Str ll := s readline ; ll<>"" }
    if (ll parse "encoding" ":" "binary")
      page text "This is a binary file.[lf]"
      return
  var List:Str list
  while not s:atend
    list += s readline
  if (options option "review")
    var Dictionary mapping
    if reference<>""
      (var Stream s) open reference in+safe
      var Str previous := ""
      while not s:atend
        var Str current := s readline
        mapping insert (current relative_tabulation previous) false addressof:(new Int s:line_number)
        previous := current
    page display_difference2 list mapping f d modify section path
  else
    page display_difference1 list

export '. display_difference'