Patch title: Release 83 bulk changes
Abstract:
File: /pliant/appli/database/io.pli
Key:
    Removed line
    Added line
abstract
  [Handles datas stored in a file, using HTML like tags.]

# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# 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/language/stream/filesystembase.pli"
module "/pliant/admin/file.pli"
module "prototype.pli"
module "/pliant/util/encoding/html.pli"

constant optimized_loader true


method d direct_search_path path createit -> d2
  arg_rw Data_ d ; arg Str path ; arg CBool createit ; arg Data_ d2
  d2 := d
  var Str p := path
  while (p parse "/" any:(var Str k) "/" any:(var Str remain))
    d2 := d2:interface search d2 html_decode:k createit
    p := "/"+remain
  if (p parse "/" any:(var Str k))
    d2 := d2:interface search d2 html_decode:k createit


public

constant database_line_limit 2^24


#--------------------------------------------------------------------------


gvar Sem database_store_sem

function stop_storing p
  arg Address p
  database_store_sem request
gvar DelayedAction stop
stop function :> the_function stop_storing Address
pliant_shutdown_actions append addressof:stop

function restart_storing p
  arg Address p
  database_store_sem release
gvar DelayedAction restart
restart function :> the_function restart_storing Address
pliant_wakeup_actions append addressof:restart


method d store s
  arg Data_ d ; arg_rw Stream s
  if (d:interface get d addressof:(var Str value) Str)=success
    s writeline "<pdata path=[dq]"+d:dbpath+"[dq]>"+html_encode:value+"</pdata>"
  var Data_ cur := d:interface first_to_store d "" "" (var DataScanBuffer buf)
  while cur:adr<>null
    cur store s
    cur := d:interface next_to_store d "" "" buf

method db do_store filename -> status
  oarg_rw Database_ db ; arg Str filename ; arg Status status
  if not database_store_sem:nowait_rd_request
    return failure
  part store "store database "+filename
    db get_root (var Data_ d)
    var Link:Stream s :> new Stream
    s open filename+".tmp" out+safe
    if db:flags:database_compressed
      s writeline "<zlib>"
      (var Stream z) open "zlib:" "" out+safe pliant_default_file_system s
      d store z
      z flush sync
      status := shunt z:close=success and s:close=success success failure
    else
      d store s
      s flush sync
      status := shunt s:close=success success failure
    if status=success
      file_delete filename
      file_move filename+".tmp" filename
      file_directory_flush filename
    else
      file_delete filename+".tmp"
  database_store_sem rd_release


#--------------------------------------------------------------------------


method d load s db -> status
  arg_rw Data_ d ; arg_rw Stream s ; oarg_rw Database_ db ; arg Status status
  status := success
  s line_limit := database_line_limit
  if optimized_loader
    var Array:Data_ cache
    cache size := 1
    cache 0 := d
    var Int level := 0
  while not s:atend
    # if s:line_number%10000=0
    #   console "line " s:line_number "            [cr]"
    var Str l := s readline
    if (l eparse "<pdata path=[dq]" any:(var Str path) "[dq]" any ">" any:(var Str value) "</pdata>")
      if optimized_loader
        if level>0
          level -= 1
        while level>0 and { var Pointer:Data_ d0 :> cache level ; (path 0 d0:path1:len)<>d0:path1 or (path d0:path1:len 1)<>"/" }
        while level>0 and { var Pointer:Data_ d0 :> cache level ; (path 0 d0:path1:len)<>d0:path1 or (path d0:path1:len 1)<>"/" or (addressof d0:base)<>(addressof d:base) }
          level -= 1
        var Int cur := cache:level:path1:len
        while cur<path:len and path:cur="/" and { var Int next := ((path cur+1 path:len) search "/" -1)+cur+1 ; next>cur }
          if level+1>=cache:size
            cache size += 1
          var Pointer:Data_ d0 :> cache level
          var Pointer:Data_ d1 :> cache level+1
          d1 := d0:interface search d0 html_decode:(path cur+1 next-cur-1) true
          if (exists d1:path2)
            d1 path1 :> new Str d1:path1+d1:path2
            d1 path2 :> null map Str
          level += 1 ; cur := next
        if cur<path:len and path:cur="/"
          if level+1>=cache:size
            cache size += 1
          var Pointer:Data_ d0 :> cache level
          var Pointer:Data_ d1 :> cache level+1
          d1 := d0:interface search d0 html_decode:(path cur+1 path:len) true
          level += 1
        var Str v := html_decode value
        if (cache:level:interface set cache:level addressof:v Str)=failure
          status := failure
      else
        var Data_ d := db direct_search_path path true
        var Data_ d2 := d direct_search_path path true
        var Str v := html_decode value
        if (d:interface set d addressof:v Str)=failure
        if (d2:interface set d2 addressof:v Str)=failure
          status := failure
    eif (l eparse "<pdata path=[dq]" any:(var Str path) "[dq] value=[dq]" any:(var Str value) "[dq]" any "/>")
      var Data_ d2 := d direct_search_path path true
      var Str v := html_decode value
      if (d2:interface set d2 addressof:v Str)=failure
        status := failure
    eif (l eparse "<preset path=[dq]" any:(var Str path) "[dq]" any "/>")
      var Data_ d2 := d direct_search_path path false
      if d:adr<>null and (d2:interface reset d2)=failure
        status := failure
    eif (l eparse "<pcreate path=[dq]" any:(var Str path) "[dq]" any "/>")
      var Int i := path search_last "/" 0
      var Data_ d2 := d direct_search_path (path 0 i) false
      if d2:adr<>null and (d2:interface create d2 html_decode:(path i+1 path:len))=failure
        status := failure
    eif (l eparse "<pdelete path=[dq]" any:(var Str path) "[dq]" any "/>")
      var Int i := path search_last "/" 0
      var Data_ d2 := d direct_search_path (path 0 i) false
      if d2:adr<>null and (d2:interface delete d2 html_decode:(path i+1 path:len))=failure
        status := failure
    eif (l eparse "<precovery offset=[dq]" (var Intn offset) "[dq]" any "/>")
      var Str filename := d:base query "filename"
      var Str logname := d:base query "logname"
      if logname<>"" and logname<>filename
        s open logname in+safe
        s configure "seek "+string:offset
        s line_limit := database_line_limit
    eif l="<zlib>"
      db flags += database_compressed
      var Link:Stream z :> new Stream
      z open "zlib:" "" in+safe pliant_default_file_system s
      if (d load z db)=failure or z:close=failure
        status := failure


method db do_load filename -> status
  oarg_rw Database_ db ; arg Str filename ; arg Status status
  db flags -= database_compressed
  db flags += database_loading
  db get_root (var Data_ root)
  root:interface reset root
  part load "load database "+filename
    status := success
    var Link:Stream s :> new Stream
    s open filename in+safe
    if s=failure
      s open filename+".tmp" in+safe
    status := root load s db
    if s:close=failure
      status := failure
  db flags -= database_loading