Patch title: Release 85 bulk changes
Abstract:
File: /pliant/appli/database/split.pli
Key:
    Removed line
    Added line
   
abstract
  [Split databases enable to handle very large sets of datas


# scope "/pliant/appli/"
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/admin/file.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/util/encoding/general.pli"
module "/pliant/admin/md5.pli"
module "/pliant/language/schedule/daemon.pli"
module "prototype.pli"
module "io.pli"
module "interface.pli"
module "pointer.pli"
abstract
  [Split databases enable to handle very large sets of datas


# scope "/pliant/appli/"
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/admin/file.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/util/encoding/general.pli"
module "/pliant/admin/md5.pli"
module "/pliant/language/schedule/daemon.pli"
module "prototype.pli"
module "io.pli"
module "interface.pli"
module "pointer.pli"
module "/pliant/language/data/cache.pli"




gvar Int split_counter := 0
gvar Int split_cache := 4 # less conservative could be memor


gvar List_ split_list ; gvar FastSem split_list_sem


type SplitArrow
  later


type DatabaseSplit
  field Database_ common
type DatabaseSplit
  field Database_ common
  field Pointer:SplitArrow arrow
  field Str filename
  field Arrow root
  field Link:DataInterface_ root_interface
  field Pointer:Database_ database_
  field Str subpath
  field Str filename
  field Arrow root
  field Link:DataInterface_ root_interface
  field Pointer:Database_ database_
  field Str subpath
  field ListNode_ split_node


CachePrototype maybe DatabaseSplit
Database_ maybe DatabaseSplit


Database_ maybe DatabaseSplit


type SplitArrow
  field Link:DatabaseSplit database
  field Sem sem

method ds database -> db
  arg DatabaseSplit ds ; oarg_C Database_ db
  db :> (addressof ds:database_) omap Database_


method ds database -> db
  arg DatabaseSplit ds ; oarg_C Database_ db
  db :> (addressof ds:database_) omap Database_


method ds drop
  oarg_rw DatabaseSplit ds
  if ds:common:flags:database_modified
    database_trace trace "store and unload " ds:filename
    ds adjust_flags
    file_tree_create ds:filename
    ds do_store ds:filename
  else
    database_trace trace "unload " ds:filename


function destroy a
  arg_w SplitArrow a
  if pliant_execution_phase>execution_phase_free
    return
  if (exists a:database)
    split_list_sem request
    split_list remove a:database:split_node
    split_list_sem release


method ds get_root d
  arg DatabaseSplit ds ; arg_w Data_ d
  d adr := ds root
  d object := ds root
  d interface :> ds root_interface
  d base :> ds
  d path1 :> ""
  d path2 :> null map Str



method ds get_root d
  arg DatabaseSplit ds ; arg_w Data_ d
  d adr := ds root
  d object := ds root
  d interface :> ds root_interface
  d base :> ds
  d path1 :> ""
  d path2 :> null map Str



method ds setup a filename type interface database subpath
  arg_rw DatabaseSplit ds ; arg_rw SplitArrow a ; arg Str fi
method ds setup filename type interface database subpath
  arg_rw DatabaseSplit ds ; arg Str filename ; arg Type type ; arg DataInterface_ interface ; arg Database_ database ; arg Str subpath
  ds:common flags := cast 0 DatabaseFlags
  ds:common path := database:path+subpath
  ds:common flags := cast 0 DatabaseFlags
  ds:common path := database:path+subpath
  ds arrow :> a
  ds filename := filename
  ds root := entry_new type
  ds root_interface :> interface
  ds database_ :> database
  ds subpath := subpath
  ds sem :> database sem
  ds filename := filename
  ds root := entry_new type
  ds root_interface :> interface
  ds database_ :> database
  ds subpath := subpath
  ds sem :> database sem
  split_list_sem request
  split_list append ds:split_node
  split_list_sem release



method t split_type -> st
  arg Type t ; arg_R Type st
  st :> (t:properties first "split type") map Type



method t split_type -> st
  arg Type t ; arg_R Type st
  st :> (t:properties first "split type") map Type
 



meta split_field e
  var Pointer:Arrow c :> pliant_general_dictionary first "pl
  if c=null or entry_type:c<>Type
    return
  if e:size<2 or (e:0 constant Type)=null
    return
  var Link:Type t :> c map Type
  var Link:Type st :> t split_type
  if not exists:st
meta split_field e
  var Pointer:Arrow c :> pliant_general_dictionary first "pl
  if c=null or entry_type:c<>Type
    return
  if e:size<2 or (e:0 constant Type)=null
    return
  var Link:Type t :> c map Type
  var Link:Type st :> t split_type
  if not exists:st
    t define_field SplitArrow "split arrow" null
    st :> new Type
    st name := t:name+" split"
    t:properties insert "split type" true addressof:st
    (addressof:Universal map Type) maybe st
  pliant_general_dictionary insert2 "pliant type" true addre
  e compile_as (expression immediat (field t ids) substitute
  pliant_general_dictionary remove "pliant type" addressof:s
  st terminate_fields



    st :> new Type
    st name := t:name+" split"
    t:properties insert "split type" true addressof:st
    (addressof:Universal map Type) maybe st
  pliant_general_dictionary insert2 "pliant type" true addre
  e compile_as (expression immediat (field t ids) substitute
  pliant_general_dictionary remove "pliant type" addressof:s
  st terminate_fields



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 "+


function split_unload -> remaining
  arg Int remaining
  var List l
  database_trace trace "unloading splitted database records"
  part filter "filter splitted database records"
    split_list_sem request
    split_counter := 0
    remaining := 0
    var Pointer:ListNode_ n :> split_list first
    while exists:n
      constant split_node_offset (DatabaseSplit field_offset
      var Link:DatabaseSplit db :> (addressof:n translate By
      if (db:arrow:sem nowait_request)
        if ((addressof:db translate Int -2) map Int)=2 # not
          l append addressof:db
          n :> split_list remove n
        else
          db:arrow:sem release
          remaining += 1
          n :> n next
      else
        remaining += 1
        n :> n next
    split_list_sem release
  part unload "unloading splitted database records"
    var Pointer:Arrow c :> l first
    while c<>null
      db :> c map DatabaseSplit
      if db:common:flags:database_modified
        database_trace trace "store and unload" db:filename
        db adjust_flags
        file_tree_create db:filename
        db do_store db:filename
      else
        database_trace trace "unload " db:filename
      db:arrow database :> null map DatabaseSplit
      db:arrow:sem release
      c :> l remove c
  

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


type DataSplitFieldDef
  field Pointer:DataInterface_ fixed_interface
  field CBool split
  field Int offset
  field Link:DataInterface_ interface
  field Str path
  field Arrow default


method ds content d -> db
  arg DataSplit ds ; arg Data_ d ; arg Link:DatabaseSplit db
type DataSplitFieldDef
  field Pointer:DataInterface_ fixed_interface
  field CBool split
  field Int offset
  field Link:DataInterface_ interface
  field Str path
  field Arrow default


method ds content d -> db
  arg DataSplit ds ; arg Data_ d ; arg Link:DatabaseSplit db
  var Pointer:SplitArrow a :> (d:adr translate Byte ds:arrow
  a:sem request "aquire database slit record semaphore "+d:p
  if not (exists a:database)
    part load "load database slit record "+d:path
      var Str filename := ds filename d
      database_trace trace "load " filename
      db :> new DatabaseSplit
      a database :> db
      db setup a filename ds:split_type ds:split_interface d
      db do_load filename
      split_counter += 1
      if split_counter>=split_cache and memory_current_used>
        daemon "database unload daemon"
          split_unload
  else
    db :> a database
  a:sem release
  # console "path = " d:path eol
  if (cache_open d:path DatabaseSplit ((addressof Link:DatabaseSplit db) map Link:CachePrototype))
    var Str filename := ds filename d
    database_trace trace "load " filename
    db setup filename ds:split_type ds:split_interface d:base d:dbpath
    db do_load filename
    cache_ready ((addressof Link:DatabaseSplit db) map Link:CachePrototype)


method ds first_to_store d start stop buf -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg


method ds first_to_store d start stop buf -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg
  var Pointer:SplitArrow a :> (d:adr translate Byte ds:arrow
  a:sem request "aquire database split record semaphore (fir
  if (exists a:database)
    var Link:DatabaseSplit db :> a database
  if (cache_search d:path (var Link:CachePrototype cp))
    var Link:DatabaseSplit db :> addressof:cp map DatabaseSplit
    if db:common:flags:database_modified
    if db:common:flags:database_modified
      database_trace trace "store " db:filename
      db adjust_flags
      file_tree_create db:filename
      db do_store db:filename
      db:common flags -= database_modified
      db adjust_flags
      file_tree_create db:filename
      db do_store db:filename
      db:common flags -= database_modified
  a:sem release
  buf adr := null
  d2 := ds next_to_store d start stop buf


method ds pre_delete t k
  arg DataSplit ds ; arg Data_ t ; arg Str k
  var Data_ r := t:interface search t k
  if r:adr<>null
  buf adr := null
  d2 := ds next_to_store d start stop buf


method ds pre_delete t k
  arg DataSplit ds ; arg Data_ t ; arg Str k
  var Data_ r := t:interface search t k
  if r:adr<>null
    var Pointer:SplitArrow a :> (r:adr translate Byte ds:arr
    a:sem request "aquire database split record semaphore (p
    cache_delete t:path+"/"+html_encode:k
    var Str filename := ds filename r
    file_delete filename
    var Str filename := ds filename r
    file_delete filename
    a:sem release






export split_field '' split_unload
export split_cache
export split_field ''
export split_dispatch
export split_dispatch


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


function unload_databases parameter filehandle
  arg Address parameter ; arg Int filehandle
  var Pointer:ListNode_ n :> split_list first
  while exists:n
    constant split_node_offset (DatabaseSplit field_offset "
    var Link:DatabaseSplit ds :> (addressof:n translate Byte
    n :> split_list remove n
    ds:arrow database :> null map DatabaseSplit

gvar DelayedAction da
da function :> the_function unload_databases Address Int
pliant_restore_actions append addressof:da