Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/browser/sample/document.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/data/id.pli"
module "/pliant/graphic/browser/server/context.pli"
module "/pliant/graphic/browser/server/api.pli"
module "/pliant/storage/document/document.pli"
module "/pliant/storage/document/document2.pli"
module "/pliant/storage/ground/control.pli"
module "/pliant/storage/ground/object.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/util/pml/io.pli"


type DocumentEditorContext
  field Pointer:BrowserServerContext context
  field Link:StorageDocument d
  field Str menu
  field Str action <- "navigate"
  field Str aid ; field Int aindex
  field Str bid ; field Int bindex
  field Str cid ; field Int cindex
  field Str32 pending


#-------------------------------------------------------------------------
#  Send display version of the XML tree to the browser


gvar Dictionary send_methods

method n send_prototype s section f
  arg StorageNode n ; arg Stream s ; arg CBool section ; arg Function f
  indirect

method n send s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  var Pointer:Function f :> (send_methods first n:tag) map Function
  if exists:f
    n send_prototype s section f

method n send_body s
  arg StorageNode n ; arg Stream s
  var Pointer:StorageNode n2 :> n first
  while exists:n2
    n2 send s true
    n2 :> n2 next


method n send_document s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  n send_body s
send_methods insert "document" true addressof:(the_function '. send_document' StorageNode Stream CBool)


method n send_para s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  if section
    s oraw open (cast "section" Ident) n:id body
  s oraw open (cast "para" Ident) (cast "cursor" Ident) (cast "edit" Ident) body
  n send_body s
  s oraw close
  if section
    s oraw close
send_methods insert "para" true addressof:(the_function '. send_para' StorageNode Stream CBool)

method n send_text s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  s oraw open (cast "text" Ident) (n attr "") close
send_methods insert "text" true addressof:(the_function '. send_text' StorageNode Stream CBool)

method n send_link s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  s oraw open (cast "style" Ident) (cast "use" Ident) "link" body
  n send_body s
  s oraw close
send_methods insert "link" true addressof:(the_function '. send_link' StorageNode Stream CBool)


method n send_header s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  if section
    s oraw open (cast "section" Ident) n:id body
  s oraw open (cast "header" Ident) (cast "cursor" Ident) (cast "edit" Ident) body
  n send_body s
  s oraw close
  if section
    s oraw close
send_methods insert "header" true addressof:(the_function '. send_header' StorageNode Stream CBool)

method n send_title s section
  arg StorageNode n ; arg Stream s ; arg CBool section
  if section
    s oraw open (cast "section" Ident) n:id body
  s oraw open (cast "title" Ident) (cast "cursor" Ident) (cast "edit" Ident) body
  n send_body s
  s oraw close
  if section
    s oraw close
send_methods insert "title" true addressof:(the_function '. send_title' StorageNode Stream CBool)


#-------------------------------------------------------------------------
#  A fiew utility functions


method n is_bloc -> c
  arg StorageNode n ; arg CBool c
  var Str t := n tag
  c := t="para" or t="header" or t="title"

method n has_style -> c
  arg StorageNode n ; arg CBool c
  var Str t := n tag
  c := false


function locate_rec n node index -> found
  arg StorageNode n ; arg_rw Pointer:StorageNode node ; arg_rw Int index ; arg CBool found
  if n:tag="text"
    var Int l := utf8_decode:(n attr "") len
    if index<=l
      node :> n ; found := true
    else
      index -= l+1 ; found := false
  else
    var Pointer:StorageNode n2 :> n first
    while exists:n2
      if (locate_rec n2 node index)
        return true
      n2 :> n2 next
    found := false
  
method d locate id i node index -> found
  arg StorageDocument d ; arg Str id ; arg Int i ; arg_rw Pointer:StorageNode node ; arg_rw Int index ; arg CBool found
  var Pointer:StorageNode n :> d search_node id
  index := i
  found := exists:n and n:is_bloc and (locate_rec n node index)


function count_rec n -> nb
  arg StorageNode n ; arg Int nb
  if n:tag="text"
    nb := utf8_decode:(n attr ""):len+1
  else
    nb := 0
    var Pointer:StorageNode n2 :> n first
    while exists:n2
      nb += count_rec n2
      n2 :> n2 next
  
method d count id -> nb
  arg StorageDocument d ; arg Str id ; arg Int nb
  var Pointer:StorageNode n :> d search_node id
  nb := shunt exists:n count_rec:n 0


method e pending_flush
  arg_rw DocumentEditorContext e
  implicit e
    if pending:len>0
      if (e:d locate cid cindex (var Pointer:StorageNode node) (var Int index))
        var Str32 t := utf8_decode (node attr "")
        e:d set_attr node "" (utf8_encode (t 0 index)+pending+(t index t:len))
      cindex += pending len
      pending := ""


method e focus id index
  arg_rw DocumentEditorContext e ; arg Str id ; arg Int index
  implicit context e
    cid := id ; cindex := index
    var Pointer:StorageNode n :> d search_node id
    if exists:n and index<>undefined
      context focus_set (shunt n:has_style "f " "")+id index


method e bloc_overwrite id
  arg_rw DocumentEditorContext e ; arg Str id
  implicit e
    var Pointer:StorageNode n :> d search_node id
    if exists:n
      context:connection oraw open (cast "section_overwrite" Ident) id body
      n send context:connection false
      context:connection oraw close


method e bloc_create_after id tag -> id2
  arg_rw DocumentEditorContext e ; arg Str id tag id2
  implicit e
    id2 := generate_id
    var Pointer:StorageNode n :> d search_node id
    if exists:n
      var Pointer:StorageNode bloc :> d create_node id2 tag
      d stick bloc stick_after n
      var Pointer:StorageNode txt :> d create_node generate_id "text"
      d set_attr txt "" ""
      d stick txt stick_tail bloc
      context:connection oraw open (cast "section_after" Ident) n:id body
      bloc send context:connection true
      context:connection oraw close


method e bloc_delete id
  arg_rw DocumentEditorContext e ; arg Str id
  implicit e
    var Pointer:StorageNode n :> d search_node id
    if exists:n
      context section_delete id
      d delete_node n


method e bloc_cut
  arg_rw DocumentEditorContext e
  implicit e
    var Pointer:StorageNode n :> d search_node cid
    if exists:n and (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
      var Str32 t := utf8_decode (node attr "")
      if index<t:len
        var Str id2 := bloc_create_after cid n:tag
        if (d locate id2 0 (var Pointer:StorageNode node2) (var Int index2))
          d set_attr node2 "" utf8_encode:(t index t:len)
          bloc_overwrite id2
          d set_attr node "" utf8_encode:(t 0 index)
          bloc_overwrite cid
      

method e text_cut
  arg_rw DocumentEditorContext e
  implicit e
    var Pointer:StorageNode n :> d search_node cid
    if exists:n and (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
      var Str32 t := utf8_decode (node attr "")
      if index<t:len
        var Pointer:StorageNode node2 :> d create_node generate_id "text"
        d stick node2 stick_after node
        d set_attr node2 "" utf8_encode:(t index t:len)
        d set_attr node "" utf8_encode:(t 0 index)


method d bloc_stick_rec n -> modified
  arg_rw StorageDocument d ; arg_rw StorageNode n ; arg CBool modified
  modified := false
  var Pointer:StorageNode n2 :> n first
  while exists:n2
    while n2:tag="text" and (exists n2:next) and n2:next:tag="text" and { var Str32 t := utf8_decode (n2 attr "") ; t:len=0 or (t t:len-1)<>"[lf]" }
      d set_attr n2 "" (n2 attr "")+(n2:next attr "")
      d delete_node n2:next
      modified := true
    if (d bloc_stick_rec n2)
      modified := true
    n2 :> n2 next

method e bloc_stick id
  arg_rw DocumentEditorContext e ; arg Str id
  implicit e
    var Pointer:StorageNode n :> d search_node id
    if exists:n and (d bloc_stick_rec n)
      bloc_overwrite id


#-------------------------------------------------------------------------
#  Main interface


method context tree_view n head
  arg_rw BrowserServerContext context ; arg StorageNode n ; arg Str head
  implicit context
    para stick
      style use "view_tab"
        text head
      style use "view_tag"
        text n:tag
      var CBool found := n first_attr (var Str a) (var Str v)
      while found
        text " "
        style use "view_attr"
          text a
        text " "
        style use (shunt n:tag="text" and a="" "view_text" "view_value")
          text string:v
        found := n next_attr a v
      text " "
      style use "view_id"
        text n:id
    var Pointer:StorageNode n2 :> n first
    while exists:n2
      tree_view n2 head+"  "
      n2 :> n2 next


method context document_editor url
  arg_rw BrowserServerContext context ; arg Str url
  implicit context
    if not (url eparse "/" any:(var Str site) "/" any:(var Str category) "/" any:(var Str object) "/" any:(var Str fiber))
      console "wrong url" eol
      url_return
      return
    ovar DocumentEditorContext e
    e context :> context
    e d :> (storage_object site category object fiber StorageDocument) map StorageDocument
    if not (exists e:d)
      var Link:StorageControl c :> storage_control site category object
      if not exists:c
        console "no control" eol
        url_return
        return
      c fiber_create fiber "StorageDocument"
      e d :> (storage_object site category object fiber StorageDocument) map StorageDocument
      if not (exists e:d)
        console "no fiber" eol
        url_return
        return
      var Pointer:StorageNode n1 :> e:d create_node "" "document"
      var Pointer:StorageNode n2 :> e:d create_node generate_id "para"
      e:d stick n2 stick_tail n1
      var Pointer:StorageNode n3 :> e:d create_node generate_id "text"
      e:d set_attr n3 "" ""
      e:d stick n3 stick_tail n2
    eif false
      var Pointer:StorageNode n :> e:d search_node ""
      if exists:n and n:tag="sequence"
        e:d set_tag n "document"
    implicit e
      style_copy "" "header"
      style_set "header" text font "Free Sans Bold"
      style_set "header" text scale 16/72*25.4
      style_copy "" "title"
      style_set "title" text font "Free Sans Bold"
      style_set "title" text scale 24/72*25.4
      style_copy "" "link"
      style_set "link" text color (color rgb 0 0 192)
      style_copy "" "view_tab"
      style_copy "" "tree_view"
      style_set "tree_view" text wrap false
      style_set "view_tab" text font "Free Monospaced"
      style_copy "tree_view" "view_tag"
      style_set "view_tag" text color (color rgb 96 0 0)
      style_copy "tree_view" "view_attr"
      style_set "view_attr" text font "Free Sans Oblique"
      style_set "view_attr" text scale 10/72*25.4
      style_set "view_attr" text color (color rgb 0 96 0)
      style_copy "tree_view" "view_value"
      style_set "view_value" text color (color rgb 0 96 0)
      style_copy "tree_view" "view_text"
      style_copy "tree_view" "view_id"
      style_set "view_id" text font "Free Sans"
      style_set "view_id" text scale 8/72*25.4
      style_set "view_id" text color (color rgb 128 128 128)
      window top
        section "parameters"
          void
      window left
        section "menu" dynamic
          if menu="insert"
            button "title" key "alt e"
              if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
                bloc_cut
                var Str id2 := bloc_create_after cid "title"
                focus id2 0
            eol
            button "header" key "alt h"
              if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
                bloc_cut
                var Str id2 := bloc_create_after cid "header"
                focus id2 0
            eol
            button "para" key "alt p" selected action="para"
              if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
                bloc_cut
                var Str id2 := bloc_create_after cid "para"
                focus id2 0
            eol
            button "table" key "alt t" active false
              void
            eol
            button "subpage" key "alt s"
              if (d locate cid cindex (var Pointer:StorageNode node) (var Int index)) and node:parent:is_bloc
                text_cut
                var Pointer:StorageNode link :> d create_node generate_id "link"
                var Str id := generate_id
                d set_attr link "url" id
                d set_attr link "master" "true"
                d stick link stick_after node
                var Pointer:StorageNode txt :> d create_node generate_id "text"
                d stick txt stick_tail link
                bloc_overwrite cid
                focus cid cindex+1
            eol
            button "exit" key "escape"
              menu := "" ; action := ""
              section_replay "menu"
              section_overwrite "help"
                void
          eif menu="view"
            button "exit" key "escape"
              menu := "" ; action := ""
              section_replay "menu"
              section_overwrite "help"
                void
              section_overwrite "document"
                var Pointer:StorageNode n :> e:d search_node ""
                if exists:n
                  n send e:context:connection true
          else
            button "navigate" key "alt n" selected action="navigate"
              action := shunt action<>"navigate" "navigate" ""
              section_replay "menu"
              section_overwrite "help"
                if action="navigate"
                  text "Clic on the link you want to follow."
            eol
            button "type in" key "alt i"
              menu := "insert" ; action := ""
              section_replay "menu"
              section_overwrite "help"
                void
            eol
            button "attribute" key "alt a" active false
              void
            eol
            button "tree view" key "alt v"
              menu := "view" ; action := ""
              section_replay "menu"
              section_overwrite "help"
                void
              section_overwrite "document"
                style use "tree_view"
                  var Pointer:StorageNode n :> e:d search_node ""
                  if exists:n
                    tree_view n ""
            eol
            button "exit" key "alt x"
              pending_flush
              url_return
      window main
        hook
          section "document"
            var Pointer:StorageNode n :> e:d search_node ""
            if exists:n
              n send e:context:connection true
        event
          if action="view"
            void
          eif event="character"
            pending += utf8_decode key
          eif event="uncharacter"
            void
          else
            pending_flush
            if event="press" and key="button1"
              e aid := shunt (pointer_section 0 2)="f " (pointer_section 2 pointer_section:len) pointer_section ; e aindex := pointer_index
              if action="navigate" and (d locate e:aid e:aindex (var Pointer:StorageNode node) (var Int index))
                while exists:node and not node:is_bloc
                  if node:tag="link" and (url eparse "/" any:(var Str site) "/" any:(var Str category) "/" any:(var Str object) "/" any:(var Str fiber))
                    var Str url2 := (context:url 0 context:url:len-context:subpath:len)+site+"/"+category+"/"+(node attr "url")+"/"+fiber
                    url_call url2
                    return
                  node :> node parent
              focus e:aid e:aindex
            eif event="release" and key="button1"
              e bid := shunt (pointer_section 0 2)="f " (pointer_section 2 pointer_section:len) pointer_section ; e bindex := pointer_index
            eif event="press" and key="backspace"
              if cindex>0 and (d locate cid cindex-1 (var Pointer:StorageNode node) (var Int index))
                var Str32 t := utf8_decode (node attr "")
                d set_attr node "" (utf8_encode (t 0 index)+(t index+1 t:len))
                bloc_overwrite cid
                focus cid cindex-1
              eif cindex=0
                var Pointer:StorageNode n :> d search_node cid
                if exists:n and n:is_bloc and (exists n:previous) and n:previous:is_bloc
                  var Str id := n:previous id ; var Int index := (d count id)-1
                  var Pointer:StorageNode n2 :> n first
                  while exists:n2
                    var Pointer:StorageNode n3 :> n2 next
                    d stick n2 stick_tail n:previous
                    n2 :> n3
                  bloc_delete n:id
                  bloc_stick id
                  bloc_overwrite id
                  focus id index
            eif event="press" and key="delete"
              if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
                var Str32 t := utf8_decode (node attr "")
                if t:len>0
                  d set_attr node "" (utf8_encode (t 0 index)+(t index+1 t:len))
                  bloc_stick cid
                  bloc_overwrite cid
                  focus cid cindex
                eif (d count cid)=1
                  bloc_delete cid
            eif event="press" and key="ctrl delete"
              if (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
                bloc_delete cid
            eif event="press" and key="enter" and (d locate cid cindex (var Pointer:StorageNode node) (var Int index))
              var Str32 t := utf8_decode (node attr "")
              d set_attr node "" (utf8_encode (t 0 index)+"[lf]")
              var Pointer:StorageNode txt :> d create_node generate_id "text"
              d stick txt stick_after node
              d set_attr txt "" utf8_encode:(t index t:len)
              bloc_overwrite cid
              focus cid cindex+2              
            eif event="press" and key="left"
              if cindex>0
                focus cid cindex-1
            eif event="press" and key="right"
              if cindex+1<(d count cid)
                focus cid cindex+1
            eif event="press" and key="home"
              focus cid 0
            eif event="press" and key="end"
              focus cid (d count cid)-1
            else
              void # console "event '"+event+"' key '"+key+"'" eol
      window bottom
        section "help"
          void


export '. document_editor'