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

# 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/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"

constant split_default_modulus 1000

gvar Int split_counter := 0
gvar Int split_cache := 4 # less conservative could be memory_assigned\2^20

gvar List_ split_list ; gvar FastSem split_list_sem


type SplitArrow
  later


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 ListNode_ split_node

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 adjust_flags
  arg_rw DatabaseSplit ds
  if ds:database:flags:database_compressed
    ds:common:flags += database_compressed
  else
    ds:common:flags -= database_compressed


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 back d -> d2
  arg_rw DatabaseSplit ds ; arg Data_ d d2
  d2 := d
  d2 path1 :> new Str ds:subpath+d:dbpath
  d2 path2 :> null map Str
  d2 base :> ds database

method ds notify_set d adr type
  arg_rw DatabaseSplit ds ; arg Data_ d ; arg Address adr ; arg Type type
  if not ds:common:flags:database_loading
    ds:common flags += database_modified
    ds:database notify_set (ds back d) adr type

method ds notify_reset d
  arg_rw DatabaseSplit ds ; arg Data_ d
  if not ds:common:flags:database_loading
    ds:common flags += database_modified
    ds:database notify_reset (ds back d)

method ds notify_create d k
  arg_rw DatabaseSplit ds ; arg Data_ d ; arg Str k
  if not ds:common:flags:database_loading
    ds:common flags += database_modified
    ds:database notify_create (ds back d) k

method ds notify_delete d k
  arg_rw DatabaseSplit ds ; arg Data_ d ; arg Str k
  if not ds:common:flags:database_loading
    ds:common flags += database_modified
    ds:database notify_delete (ds back d) k


method ds setup a filename type interface database subpath
  arg_rw DatabaseSplit ds ; arg_rw SplitArrow a ; 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 arrow :> a
  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
 

meta split_field e
  var Pointer:Arrow c :> pliant_general_dictionary first "pliant type"
  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 addressof:st e:module
  e compile_as (expression immediat (field t ids) substitute t e:0 substitute ids (e 1 e:size-1))
  pliant_general_dictionary remove "pliant type" addressof:st
  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 "+f+" field."


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 "split_node")
      var Link:DatabaseSplit db :> (addressof:n translate Byte -split_node_offset) map DatabaseSplit
      if (db:arrow:sem nowait_request)
        if ((addressof:db translate Int -2) map Int)=2 # not used
          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

type DataSplit
  field Dictionary fields
  field List base_fields all_fields
  field Link:Type fixed_type split_type
  field Int arrow_offset
  field uInt modulus <- split_default_modulus
  field Pointer:DataInterface_ split_interface
 
DataInterface_ maybe DataSplit


gvar (Array uInt8 256) db_code := general_code ""

function db_encode clear -> encoded
  arg Str clear encoded
  encoded := general_encode clear "_":number db_code

function db_decode encoded -> clear
  arg Str encoded clear
  clear := general_decode encoded "_":number

method s db_hash -> u
  arg Str s ; arg uInt u
  var Str md5 := string_md5_binary_signature s
  u := md5:characters map uInt

method ds filename d -> name
  arg DataSplit ds ; arg Data_ d ; arg Str name
  var Str all := d:base query "filename"
  var Int i := (all search_last "/" -1)+1
  var Str path := all 0 i
  path := replace path "security:/" "data:/pliant/split/"
  var Str file := all i all:len
  var Int i := file search_last "." file:len
  var Str base := file 0 i
  var Str ext := file i file:len
  name := path+base+"/"+ds:fixed_type:name+"/"+(shunt ds:modulus<>1 (string d:key:db_hash%ds:modulus)+"/" "")+(db_encode d:key)+ext

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_offset) map SplitArrow
  a:sem request "aquire database slit record semaphore "+d:path
  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:base d:dbpath
      db do_load filename
      split_counter += 1
      if split_counter>=split_cache and memory_current_used>=memory_assigned
        daemon "database unload daemon"
          split_unload
  else
    db :> a database
  a:sem release

method ds reset d -> status
  oarg_rw DataSplit ds ; arg_rw Data_ d ; arg Status status
  ds:fixed_type destroy_instance d:adr
  ds:fixed_type build_instance d:adr
  d:base notify_reset d
  status := success


method f apply d d2
  arg DataSplitFieldDef f ; arg Data_ d ; arg_w Data_ d2
  d2 adr := d:adr translate Byte f:offset
  d2 object := d object
  d2 interface :> f interface
  d2 base :> d base
  if (addressof d:path2)=null
    d2 path1 :> d path1
    d2 path2 :> f path
  else
    d2 path1 :> new Str d:path1+d:path2+f:path
    d2 path2 :> null map Str

method f apply ds d2
  arg DataSplitFieldDef f ; arg DatabaseSplit ds ; arg_w Data_ d2
  d2 adr := ds:root translate Byte f:offset
  d2 object := ds:root
  d2 interface :> f interface
  d2 base :> ds
  d2 path1 :> ""
  d2 path2 :> f path

method ds search d k -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str k ; arg Data_ d2
  var Pointer:Arrow a :> ds:fields first k
  if a<>null
    var Pointer:DataSplitFieldDef f :> a map DataSplitFieldDef
    if f:split
      f apply (ds content d) d2
    else
      f apply d d2
  else
    d2 := data_null
    d2 base :> d base
    d2 path1 :> new Str d:dbpath+"/"+html_encode:k
    d2 path2 :> null map Str

method ds next d start stop buf -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg_rw DataScanBuffer buf ; arg Data_ d2
  var Pointer:Arrow a
  if buf:adr<>null
    a :> ds:all_fields next (buf:adr map Arrow)
  else
    a :> ds:all_fields first
  while a<>null
    var Pointer:DataSplitFieldDef f :> a map DataSplitFieldDef
    if (start:len=0 or html_decode:(f:path 1 f:path:len)>=start) and (stop:len=0 or html_decode:(f:path 1 f:path:len)<stop)
      if f:split
        f apply (ds content d) d2
      else
        f apply d d2
      buf adr := addressof a
      return
    a :> ds:all_fields next a
  d2 adr := null

method ds first d start stop buf -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg_w DataScanBuffer buf ; arg Data_ d2
  buf adr := null
  d2 := ds next d start stop buf

method ds count d start stop -> count
  oarg_rw DataSplit ds ; arg Data_ d ; arg Str start stop ; arg Int count
  if start:len=0 and stop:len=0
    count := ds:fields count
  else
    count := 0
    var Pointer:Arrow c :> ds:all_fields first
    while c<>null
      var Pointer:DataSplitFieldDef f :> c map DataSplitFieldDef
      if (start:len=0 or html_decode:(f:path 1 f:path:len)>=start) and (stop:len=0 or html_decode:(f:path 1 f:path:len)<stop)
        count += 1
      c :> ds:all_fields next c


method ds next_to_store d start stop buf -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg_rw DataScanBuffer buf ; arg Data_ d2
  var Pointer:Arrow a
  if buf:adr<>null
    a :> ds:base_fields next (buf:adr map Arrow)
  else
    a :> ds:base_fields first
  while a<>null
    var Pointer:DataSplitFieldDef f :> a map DataSplitFieldDef
    if (start:len=0 or html_decode:(f:path 1 f:path:len)>=start) and (stop:len=0 or html_decode:(f:path 1 f:path:len)<stop)
      f apply d d2
      buf adr := addressof a
      return
    a :> ds:base_fields next a
  d2 adr := null

method ds first_to_store d start stop buf -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg_w DataScanBuffer buf ; arg Data_ d2
  var Pointer:SplitArrow a :> (d:adr translate Byte ds:arrow_offset) map SplitArrow
  a:sem request "aquire database split record semaphore (first_to_store) "+d:path
  if (exists a:database)
    var Link:DatabaseSplit db :> a database
    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
  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
    var Pointer:SplitArrow a :> (r:adr translate Byte ds:arrow_offset) map SplitArrow
    a:sem request "aquire database split record semaphore (pre_delete) "+t:path
    var Str filename := ds filename r
    file_delete filename
    a:sem release


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


function split_interface t -> di
  arg Type t ; arg Link:DataInterface_ di
  var DataKind k := data_kind t
  if k<>data_record
    return
  var Pointer:Type st :> t split_type
  if not exists:st
    return
  var Link:DataSplit ds :> new DataSplit
  ds fixed_type :> t
  ds split_type :> st
  ds split_interface :> data_interface st
  var (Index Str Arrow) base_order all_order
  for (var Int i) 0 t:nb_fields-1
    var Pointer:TypeField tf :> t field i
    if tf:name<>"split arrow"
      var Link:DataSplitFieldDef f :> new DataSplitFieldDef
      f fixed_interface :> ds
      f split := false
      f offset := tf offset
      f interface :> data_interface tf:type
      f path := "/"+(html_encode tf:name)
      f default := tf initial_value
      ds:fields insert tf:name false addressof:f
      var Arrow a := addressof f
      base_order insert tf:name a
      all_order insert tf:name a
    else
      ds arrow_offset := tf:offset
  for (var Int i) 0 st:nb_fields-1
    var Pointer:TypeField tf :> st field i
    var Link:DataSplitFieldDef f :> new DataSplitFieldDef
    f fixed_interface :> ds
    f split := true
    f offset := tf offset
    f interface :> data_interface tf:type
    f path := "/"+(html_encode tf:name)
    f default := tf initial_value
    ds:fields insert tf:name false addressof:f
    var Arrow a := addressof f
    all_order insert tf:name a
  var Pointer:Arrow c :> base_order first
  while addressof:c<>null
    ds:base_fields append c
    c :> base_order next c
  var Pointer:Arrow c :> all_order first
  while addressof:c<>null
    ds:all_fields append c
    c :> all_order next c
  di :> ds

data_interface_generators insert_before data_interface_generators:first addressof:(the_function split_interface Type -> Link:DataInterface_)


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


function map_field r def -> f
  arg_rw Data_ r ; arg DataSplitFieldDef def ; arg Data_ f
  if (addressof r:interface)=(addressof def:fixed_interface)
    if def:split
      var Pointer:DataSplit ds :> (addressof def:fixed_interface) map DataSplit
      def apply (ds content r) f
    else
      def apply r f
  else
    r:base:sem rd_request
    f := r:interface search r html_decode:(def:path 1 def:path:len) false
    r:base:sem rd_release
    if f:adr=null
      f object := def default

meta '' e
  if e:size<>2 or not e:1:is_pure_ident or not e:0:is_data
    return
  var Link:Type t :> unpointerto e:0:result:type
  if entry_type:(addressof data_interface:t)<>DataSplit
    return
  var Pointer:DataSplit r :> (addressof data_interface:t) map DataSplit
  for (var Int i) 0 t:nb_fields-1
    var Pointer:TypeField f :> t field i
    if f:name=e:1:ident
      var Link:Type dt :> Data f:type
      var Link:Argument a :> argument local dt
      e suckup e:0
      var Pointer:DataSplitFieldDef def :> (r:fields first f:name) map DataSplitFieldDef
      e add (instruction (the_function map_field Data_ DataSplitFieldDef -> Data_) e:0:result (argument mapped_constant DataSplitFieldDef def) a)
      e set_result a access_read+(e:0:access .and. access_write)
      return
  var Pointer:Type st :> t split_type
  for (var Int i) 0 st:nb_fields-1
    var Pointer:TypeField f :> st field i
    if f:name=e:1:ident
      var Link:Type dt :> Data f:type
      var Link:Argument a :> argument local dt
      e suckup e:0
      var Pointer:DataSplitFieldDef def :> (r:fields first f:name) map DataSplitFieldDef
      e add (instruction (the_function map_field Data_ DataSplitFieldDef -> Data_) e:0:result (argument mapped_constant DataSplitFieldDef def) a)
      e set_result a access_read+(e:0:access .and. access_write)
      return


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


function split_dispatch path modulus
  arg Str path ; arg uInt modulus
  var Array:FileInfo files := file_list path standard+recursive+relative
  for (var Int i) 0 files:size-1
    var Str key := db_decode files:i:stripped_name
    var Str old := path+files:i:name
    var Str name := path+(shunt modulus<>1 (string key:db_hash%modulus)+"/" "")+db_encode:key+".pdb"
    if old<>name
      file_tree_create name
      file_move old name
      old := old 0 (old search_last "/" -1)+1
      file_delete old
  files := file_list path standard+directories
  for (var Int i) 0 files:size-1
    if files:i:is_directory
      file_delete files:i:name


export split_field '' split_unload
export split_cache
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 "split_node")
    var Link:DatabaseSplit ds :> (addressof:n translate Byte -split_node_offset) map DatabaseSplit
    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