Patch title: Release 91 bulk changes
Abstract:
File: /appli/document/xml_parser.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"


#------------------------------------------------------------------------
# prototypes


public

  type XmlParser
    void

  method parser is_raw_tag tag -> c
    oarg_rw XmlParser parser ; arg Str tag ; arg CBool c
    generic
    c := false
  
  method parser new_text text -> ptr
    oarg_rw XmlParser parser ; arg Str text ; arg Address ptr
    generic
  
  method parser new_tag tag -> ptr
    oarg_rw XmlParser parser ; arg Str tag ; arg Address ptr
    generic
  
  method parser set_tag_attribute tag attribute value
    oarg_rw XmlParser parser ; arg Address tag ; arg Str attribute value
    generic
  
  method parser bind tag parent
    oarg_rw XmlParser parser ; arg Address tag parent
    generic


#------------------------------------------------------------------------
# initialize fast parsing tables


function reset a
  arg_w (Array uInt8 256) a
  for (var Int i) 0 255
    a i := 0

gvar (Array uInt8 256) tag_begin
reset tag_begin
tag_begin "<":number := 1

gvar (Array uInt8 256) tag_end
reset tag_end
tag_end ">":number := 1
tag_end " ":number := 1
tag_end "[tab]":number := 1
tag_end "[cr]":number := 1
tag_end "[lf]":number := 1
 
gvar (Array uInt8 256) attr_end
reset attr_end
attr_end "=":number := 1
attr_end ">":number := 1
 
gvar (Array uInt8 256) value_end
reset value_end
value_end "[dq]":0:number := 1
value_end ">":number := 1
 
gvar (Array uInt8 256) direct_end
reset direct_end
direct_end " ":number := 1
direct_end "[tab]":number := 1
direct_end "[cr]":number := 1
direct_end "[lf]":number := 1
direct_end ",":number := 1
direct_end ";":number := 1
direct_end ">":number := 1
 

#------------------------------------------------------------------------
# fast item parsing (basically searches for the end of the item)


method s character -> ch
  arg_rw Stream s ; arg Char ch
  ch := s:stream_read_cur map Char

method s forward
  arg_rw Stream s
  if s:stream_read_cur<>s:stream_read_stop
    s stream_read_cur := s:stream_read_cur translate Char 1


constant buffer_len 256

method s scan end buf txt
  arg_rw Stream s ; arg (Array uInt8 256) end ; arg_w (Array Char buffer_len) buf ; arg_w Str txt
  var Address src_cur := s stream_read_cur ; var Address src_stop := s stream_read_stop
  var Address dest_start := addressof buf ; var CBool allocated := false
  var Address dest_cur := dest_start ; var Address dest_stop := dest_start translate (Array Char buffer_len) 1
  part loop
    if src_cur=src_stop
      s stream_read_cur := src_cur
      if s:atend
        src_cur := s stream_read_cur
        leave loop
      src_cur := s stream_read_cur
      src_stop := s stream_read_stop
    if dest_cur=dest_stop 
      var Int size := (cast dest_cur Int).-.(cast dest_start Int)
      var Address buffer := memory_allocate 2*size null
      memory_copy dest_start buffer size
      if allocated
        memory_free dest_start
      dest_start := buffer
      dest_cur := buffer translate Byte size
      dest_stop := buffer translate Byte 2*size
      allocated := true
    var uInt8 c := src_cur map uInt8
    if end:c<>0
      leave loop
    dest_cur map uInt8 := c
    src_cur := src_cur translate Char 1
    dest_cur := dest_cur translate Char 1
    restart loop
  s stream_read_cur := src_cur
  txt set dest_start (cast dest_cur Int).-.(cast dest_start Int) allocated
((the_function '. scan' Stream (Array uInt8 256) (Array Char buffer_len) Str) arg 3) maps += 4


#------------------------------------------------------------------------
# parsing loop


type XmlLevel
  field Str tag
  field Address node
  field List:Address pending

method parser parse s root
  oarg_rw XmlParser parser ; arg_rw Stream s ; arg Address root
  var List:XmlLevel stack
  var List:Address root_pending ; var (Pointer List:Address) pending :> root_pending
  var (Array Char buffer_len) buf1 buf2 buf3
  part scan
    if s:atend
      leave scan
    s scan tag_begin buf1 (var Str txt)
    if txt<>""
      pending += parser new_text txt
    if s:atend
      leave scan
    s forward
    if s:character="/"
      s forward
      s scan tag_end buf1 (var Str tag)
      s forward
      var Pointer:XmlLevel l :> stack last
      while exists:l
        if l:tag=tag
          var Address n := l node
          while exists:l
            var Pointer:Address p :> l:pending first
            while exists:p
              parser bind p n
              p :> l:pending remove p
            l :> stack remove l
          if (exists stack:last)
            pending :> stack:last pending
          else
            pending :> root_pending
        else
          l :> stack previous l
    else
      s scan tag_end buf1 (var Str tag)
      var Address node := parser new_tag tag ; pending += node
      part scan_attr
        while not s:atend and { var Char ch := s character ; ch=" " or ch="[tab]" or ch="," or ch=";" or ch="[cr]" or ch="[lf]" }
          s forward
        s scan attr_end buf2 (var Str attr)
        if s:character="="
          s forward
        else 
          leave scan_attr
        while not s:atend and { ch := s character ; ch=" " or ch="[tab]" or ch="[cr]" or ch="[lf]" }
          s forward
        var Str value
        if ch="[dq]"
          s forward
          s scan value_end buf3 value
          if s:character="[dq]"
            s forward
        else
          s scan direct_end buf3 value
        parser set_tag_attribute node attr value
        if s:character<>">"
          restart scan_attr
      while not s:atend and { ch := s character ; s forward ; ch<>">" }
        void
      if not (parser is_raw_tag tag)
        var XmlLevel level ; level tag := tag ; level node := node ; level pending := var List:Address empty_list
        stack += level
        pending :> stack:last pending
      else
        var Str txt := ""
        while not s:atend and { var Str line := s readline ; line<>"</"+tag+">" }
          txt += line+"[lf]"
        parser new_text txt
    if not s:atend and s:character="[cr]"
      s forward
    if not s:atend and s:character="[lf]"
      s forward
    restart scan
  var Pointer:Address p :> root_pending first
  while exists:p
    parser bind p root
    p :> root_pending remove p
  var Pointer:XmlLevel l :> stack first
  while exists:l
    var Pointer:Address p :> l:pending first
    while exists:p
      parser bind p root
      p :> l:pending remove p
    l :> stack next l

export '. parse'