Patch title: Release 94 bulk changes
Abstract:
File: /pliant/storage/database/file.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.

scope "/pliant/storage/" "/pliant/appli/"
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/os.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/schedule/daemon.pli"
module "/pliant/admin/file.pli"
module "prototype.pli"
module "io.pli"
module "mount.pli"
module "login.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/language/data/string_cast.pli"

constant auto_store true
constant auto_store_step 5
constant verbose false
constant debug false
constant compression os_zlib_filename<>""

doc
  [There are two ways to grant that we are the only thread dealing with a given database:]
  list
    item [Either we own the 'sem' sempaphore in read write mode.]
    item [Or we own the 'sem' sempaphore in read only mode, and the 'rdsem' in read write mode.]


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


method t field_offset f -> o
  arg Type t ; arg Str f ; arg Int o
  for (var Int i) 0 t:nb_fields-1 
    if (t field i):name=f
      return (t field i):offset
  error error_id_missing "Type "+t:name+" does not have a "+f+" field."


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


public
  type DatabaseFile
    field Database_ common
    field Sem rwsem rdsem
    field Link:DataInterface_ root_interface
    field Str filename
    field Str logname ; field Link:Stream log ; field Link:Str login_tag
    field Intn base_size growth <- 0
    field Int wr_counter <- 0
    field ListNode_ all_node modified_node

Database_ maybe DatabaseFile


gvar List_ database_modified_list ; gvar Sem database_modified_sem
gvar Int database_modified_count := 0
gvar Int database_handle_count := 0
gvar Int database_handle_limit := 256

method df set_modified
  arg_rw DatabaseFile df
  if df:common:flags:database_modified
    return
  df:common flags += database_modified
  database_modified_sem request
  database_modified_list append df:modified_node
  database_modified_count += 1
  database_modified_sem release

method df clear_modified
  arg_rw DatabaseFile df
  if not df:common:flags:database_modified
    return
  df:common flags -= database_modified
  database_modified_sem request
  database_modified_list remove df:modified_node
  database_modified_count -= 1
  database_modified_sem release


gvar List_ database_all_list ; gvar Sem database_all_sem

function build df
  arg_w DatabaseFile df
  df:common sem :> df rwsem
  df:common flags := cast 0 DatabaseFlags
  df:common flags += database_autostore
  database_all_sem request
  database_all_list append df:all_node
  database_all_sem release

function destroy df
  arg_w DatabaseFile df
  df:common flags += database_loading
  # if pliant_execution_phase>=execution_phase_free
  #   return
  df clear_modified
  database_all_sem request
  database_all_list remove df:all_node
  database_all_sem release


method df get_root d
  arg DatabaseFile df ; arg_w Data_ d
  d adr := addressof:df translate DatabaseFile 1
  d object := addressof df
  d interface :> df root_interface
  d base :> df
  d path1 :> ""
  d path2 :> null map Str


function data_store force
  arg CBool force
  later


method df log_line line
  arg_rw DatabaseFile df ; arg Str line
  plugin log
  df:log writeline line

method df log_required -> required
  arg_rw DatabaseFile df ; arg CBool required
  if df:common:flags:database_loading
    return false
  if df:logname:len=0
    return false
  if not df:common:flags:database_modified and df:common:flags:database_autostore
    df set_modified
    if auto_store
      daemon "database autostore daemon"
        while database_modified_count>0 and not daemon_emergency
          daemon_sleep auto_store_step
          data_store false
  df wr_counter += 1
  if (addressof df:log)=null
    atomic_add database_handle_count 1
    if database_handle_count>database_handle_limit
      daemon "database autoclose daemon"
        data_store false
    df log :> new Stream
    if df:logname=df:filename
      # temporary log
      df:log open df:filename append+linecache+safe
      df:log safe_configure "journal"
    else
      # full log
      var FileInfo info := file_query df:logname standard
      df:log open df:filename append+safe
      df:log safe_configure "journal"
      df:log writeline "<precovery offset=[dq]"+string:(shunt info=defined info:size 0)+"[dq] />"
      df:log close
      df:log open df:logname append+linecache+safe
      df:log safe_configure "journal"
    if df:log=failure
      df log :> null map Stream
      return false
  var Link:Str lt :> data_read_login_tag
  if (addressof df:login_tag)<>addressof:lt
    df log_line lt
    df login_tag :> lt
  required := true

method df notify_set d adr type
  arg_rw DatabaseFile df ; arg Data_ d ; arg Address adr ; arg Type type
  plugin notify_set
  if df:log_required
    if type=Str
      df log_line "<pdata path=[dq]"+d:dbpath+"[dq]>"+html_encode:(adr map Str)+"</pdata>"
    else
      var Str value := to_string adr type "raw"
      df log_line "<pdata path=[dq]"+d:dbpath+"[dq]>"+html_encode:value+"</pdata>"

method df notify_reset d
  arg_rw DatabaseFile df ; arg Data_ d
  plugin notify_reset
  if df:log_required
    df log_line "<preset path=[dq]"+d:dbpath+"[dq] />"

method df notify_create d k
  arg_rw DatabaseFile df ; arg Data_ d ; arg Str k
  plugin notify_create
  if df:log_required
    df log_line "<pcreate path=[dq]"+d:dbpath+"/"+html_encode:k+"[dq] />"

method df notify_delete d k
  arg_rw DatabaseFile df ; arg Data_ d ; arg Str k
  plugin notify_delete
  if df:log_required
    df log_line "<pdelete path=[dq]"+d:dbpath+"/"+html_encode:k+"[dq] />"


function copy_lines s d
  arg_rw Stream s d
  s line_limit := database_line_limit
  while not s:atend
    var Str l := s readline
    if l<>"<zlib>"
      d writeline l
    else
      var Link:Stream z :> new Stream
      z open "zlib:" "" in+safe pliant_default_file_system s
      copy_lines z d

function database_recode filename encoding
  arg Str filename encoding
  part copy "recode "+filename
    var Link:Stream old :> new Stream
    old open filename in+safe
    var Link:Stream s :> new Stream
    s open filename+".tmp" out+safe
    s safe_configure "journal"
    var CBool ok
    if encoding="zlib"
      s writeline "<zlib>"
      var Link:Stream z :> new Stream
      z open "zlib:" "" out+safe pliant_default_file_system s
      copy_lines old z
      z flush sync
      ok := z:close=success and s:close=success
    else
      copy_lines old s
      s flush sync
      ok := s:close=success
    if ok and old:close=success
      file_delete filename
      file_move filename+".tmp" filename
      file_directory_flush filename
    else
      file_delete filename+".tmp"


method df log_recompress
  oarg_rw DatabaseFile df
  if not df:common:flags:database_compressed or df:logname=df:filename or df:logname=""
    return
  var Intn logsize := (file_query df:logname standard) size
  (var Stream s) open df:logname in+safe
  s configure "seek "+(string logsize*2\3)
  var CBool binary := false
  for (var Int i) 0 255
    s raw_read addressof:(var uInt8 b) 1
    if b>=128
      binary := true
  s close
  if binary # most of the log file is already compressed
    return
  database_store_sem rd_request
  database_trace trace "recompressing log file " df:logname
  df:common:sem request "aquire database semaphore (log_recompress) "+df:common:path
  if (exists df:log)
    df:log close
    df log :> null map Stream
    atomic_add database_handle_count -1
  database_recode df:logname "zlib"
  df base_size := (file_query df:logname standard) size
  df:common:sem release
  database_store_sem rd_release

method df store -> status
  oarg_rw DatabaseFile df ; arg Status status
  df:sem rd_request "aquire database semaphore (store) "+df:common:path
  df:rdsem request "aquire database io semaphore (store) "+df:common:path
  if df:common:flags:database_modified
    if (exists df:log)
      df:log close
      df log :> null map Stream
      atomic_add database_handle_count -1
    status := df do_store df:filename
    df base_size := (file_query df:logname standard) size
    if status=success
      df clear_modified
  else
    status := success
  df:rdsem release
  df:sem rd_release


method df setup filename logname mountpoint
  oarg_rw DatabaseFile df ; arg Str filename logname mountpoint
  df:sem request "aquire database semaphore (setup) "+df:common:path
  df filename := filename
  df logname := logname
  df path := mountpoint # setting the path before loading is required when slit field are used in order to get the full path in slitted database
  df do_load filename df:base_size
  if mountpoint<>""
    data_mount df mountpoint
  if df:base_size=undefined
    df base_size := (file_query df:logname standard) size
  eif df:common:flags:database_autostore
    df set_modified  
  df:sem release


gvar Array:Int hour_stats # per hours statistics about activity
function init_hour_stats
  hour_stats size := 24
  for (var Int i) 0 23
    hour_stats i := 0
init_hour_stats
gvar Int hour_current := 0
gvar Int hour_wr_counter := 0
gvar Int hour_best := 0
gvar Sem hour_sem

function hour_load h -> l
  arg Int h ; arg Int l
  l := (hour_stats (h+22)%24)+2*(hour_stats (h+23)%24)+4*hour_stats:h+2*(hour_stats (h+1)%24)+(hour_stats (h+2)%24)

function data_store force
  arg CBool force
  var CBool hour_force := false
  var DateTime now := datetime
  hour_sem request
  if now:hour<>hour_current
    hour_stats hour_current := hour_wr_counter
    hour_current := now hour ; hour_wr_counter := 0
    if hour_current=0
      hour_best := 0
      for (var Int i) 1 23
        if hour_load:i<hour_load:hour_best
          hour_best := i
    if hour_current=hour_best or hour_load:hour_current=0
      hour_force := true
  hour_sem release
  var List l
  database_modified_sem rd_request
  var Pointer:ListNode_ n :> database_modified_list first
  while exists:n
    constant modified_node_offset (DatabaseFile field_offset "modified_node")
    var Link:DatabaseFile df :> (addressof:n translate Byte -modified_node_offset) map DatabaseFile
    if (df:sem nowait_request)
      hour_sem request
      hour_wr_counter += df wr_counter
      df wr_counter := 0
      hour_sem release
      df:sem release
    var Intn size := (file_query df:logname standard) size
    if force or hour_force or (database_handle_count>database_handle_limit and df:common:flags:database_autoclose) or (size<>undefined and size>df:base_size*3\2+df:growth)
      if df:filename<>""
        l append addressof:df
    n :> n next
  database_modified_sem rd_release
  var Pointer:Arrow c :> l first
  while c<>null
    var Link:DatabaseFile df :> c omap DatabaseFile
    database_trace trace "auto-store " df:filename
    if df:store=success
      df log_recompress
    c :> l next c

function data_store
  data_store true


method df query command -> answer
  oarg DatabaseFile df ; arg Str command answer
  answer := shunt command="filename" df:filename command="logname" df:logname command="modified" (shunt df:common:flags:database_modified "true" "false") ""

method df configure command -> status
  oarg_rw DatabaseFile df ; arg Str command ; arg Status status
  if compression and command="encoding zlib"
    if not df:common:flags:database_compressed
      database_trace trace "compress " df:filename
      df:sem request "aquire database semaphore (configure) "+df:common:path
      df:common flags += database_compressed
      status := df do_store df:filename
      df base_size := (file_query df:logname standard) size
      if df:logname<>"" and df:logname<>df:filename and status=success
        database_recode df:logname "zlib"
      df:sem release
    else
      status := success
  eif command="encoding clear"
    if df:common:flags:database_compressed
      database_trace trace "uncompress " df:filename
      df:sem request "aquire database semaphore (configure) "+df:common:path
      df:common flags -= database_compressed
      status := df do_store df:filename
      df base_size := (file_query df:logname standard) size
      if df:logname<>"" and df:logname<>df:filename and status=success
        database_recode df:logname "clear"
      df:sem release
    else
      status := success
  eif (command parse "growth" df:growth)
    status := success
  eif command="close auto"
    df:sem request "aquire database semaphore (configure) "+df:common:path
    df:common flags += database_autoclose
    df:sem release
    status := success
  eif command="close manual"
    df:sem request "aquire database semaphore (configure) "+df:common:path
    df:common flags -= database_autoclose
    df:sem release
    status := success
  eif command="store auto"
    df:sem request "aquire database semaphore (configure) "+df:common:path
    df:common flags += database_autostore
    df:sem release
    status := success
  eif command="store manual"
    df:sem request "aquire database semaphore (configure) "+df:common:path
    df:common flags -= database_autostore
    df:sem release
    status := success
  else
    status := failure


function data_file_switch src dest -> status
  arg Str src dest ; arg Status status
  status := failure
  database_all_sem rd_request
  var Pointer:ListNode_ n :> database_all_list first
  while exists:n
    constant all_node_offset (DatabaseFile field_offset "all_node")
    var Link:DatabaseFile df :> (addressof:n translate Byte -all_node_offset) map DatabaseFile
    if df:filename=dest or (file_os_name df:filename)=file_os_name:dest and file_os_name:dest<>""
      df:sem request "aquire database semaphore (data_file_switch) "+df:common:path
      file_move src dest
      file_directory_flush dest
      df do_load df:filename
      df clear_modified
      df:sem release
      status := success
    n :> n next
  database_all_sem rd_release

export data_file_switch


function load_databases parameter filehandle
  arg Address parameter ; arg Int filehandle
  var Pointer:ListNode_ n :> database_all_list first
  while exists:n
    constant all_node_offset (DatabaseFile field_offset "all_node")
    var Link:DatabaseFile df :> (addressof:n translate Byte -all_node_offset) map DatabaseFile
    df do_load df:filename
    df clear_modified
    n :> n next
gvar DelayedAction da0
da0 function :> the_function load_databases Address Int
pliant_restore_actions append addressof:da0


export '. setup' '. store'
export data_store database_recode
export database_handle_limit