Patch title: Release 84 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


gvar Int split_counter := 0
abstract
  [Split databases enable to handle very large sets of datas


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


type DataSplit
  field Dictionary fields


type DataSplit
  field Dictionary fields
  field List all_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



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



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
  a:sem request "aquire database slit record semaphore "+d:path
  if not (exists a:database)
  if not (exists a:database)
    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:b
    db do_load filename
    split_counter += 1
    if split_counter>=split_count_threshold and memory_curre
      daemon "database unload daemon"
        split_unload
    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 next d start stop buf -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg
  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 DataSplitFieldD
    if (start:len=0 or html_decode:(f:path 1 f:path:len)>=st
  else
    db :> a database
  a:sem release


method ds next d start stop buf -> d2
  oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg
  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 DataSplitFieldD
    if (start:len=0 or html_decode:(f:path 1 f:path:len)>=st
      f apply d d2
      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


      buf adr := addressof a
      return
    a :> ds:all_fields next a
  d2 adr := null


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
  var Pointer:SplitArrow a :> (d:adr translate Byte ds:arrow
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
  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
  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
  d2 := ds first d start stop buf
  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


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
    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 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) order
  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
  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
      order insert tf:name a
      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
    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 Pointer:Arrow c :> order first
    var Arrow a := addressof f
    all_order insert tf:name a
  var Pointer:Arrow c :> base_order first
  while addressof:c<>null
  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
    ds:all_fields append c
    c :> order next c
    c :> all_order next c
  di :> ds


export split_field '' split_unload
  di :> ds


export split_field '' split_unload
export split_count_threshold split_memory_threshold
export split_cache
export split_dispatch



export split_dispatch