Patch title: Release 94 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.]
console "Please replace with /pliant/storage/database/split.pli[lf]"

# 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"
module "/pliant/language/data/cache.pli"

constant split_default_modulus 1000


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

CachePrototype maybe DatabaseSplit
Database_ maybe DatabaseSplit


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

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

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 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 filename := filename
  ds root := entry_new type
  ds root_interface :> interface
  ds database_ :> database
  ds subpath := subpath
  ds sem :> database sem


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


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


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


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
  # 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 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
  if (cache_search d:path (var Link:CachePrototype cp))
    var Link:DatabaseSplit db :> addressof:cp map DatabaseSplit
    if db:common:flags:database_modified
      db adjust_flags
      file_tree_create db:filename
      db do_store db:filename
      db:common flags -= database_modified
  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
    cache_delete t:path+"/"+html_encode:k
    var Str filename := ds filename r
    file_delete filename


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


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 ''
export split_dispatch
submodule "/pliant/storage/database/split.pli"