Patch title: Release 85 bulk changes
Abstract:
File: /pliant/appli/database/pointer.pli
Key:
    Removed line
    Added line
abstract
  [This module will define the 'Data' and 'Database' generic data types that the application will use in order to access a database, and that will completely hide the undertlying implementation.]

# 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/data/string_cast.pli"
module "/pliant/util/encoding/html.pli"
module "set.pli"
module "prototype.pli"
module "inmemory.pli"
module "io.pli"
module "file.pli"
module "mount.pli"
module "interface.pli"


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

doc
  ['Data' is very much like 'Pointer', but it's dedicated to pointing objects in the database and ensure nice properties such as automatic locking, so you can use them safely in a multithreaded environment (the HTTP server), and not crashing if accessing a non existing data.] ; eol
  [It will map objects implemented in ] ; link "inmemory.pli" "inmemory.pli"


gvar Relation 'pliant data types'
export 'pliant data types'

function Data t -> tt
  arg Type t ; arg_R Type tt
  has_no_side_effect

  var Address adr := 'pliant data types' query addressof:t null
  if adr<>null
    return (adr map Type)

  runtime_compile  Value t  Data (cast "(Data "+t:name+")" Ident)  getdata (cast "cast "+t:name Ident)  is_field (cast (shunt data_kind:t=data_field "true" "false") Ident)  default (cast "default "+t:name Ident)

    type Data
      field Data_ data

    if is_field

      from_string addressof:(gvar Value default) Value "" "db"

      function getdata d -> v
        arg Data d ; arg Value v
        implicit
        if (d:data:interface get d:data addressof:v Value)=failure
          v := default

    export Data '. data'
    if is_field
      export getdata
    'pliant data types' define addressof:Value null addressof:Data
    'pliant data types' define null addressof:Data addressof:Value
    (addressof:'pliant star types' map Relation) define addressof:Data null addressof:Value

  var Address adr := 'pliant data types' query addressof:t null
  check adr<>null
  return (adr map Type)

export Data
alias Anything Anything from "/pliant/appli/database/inmemory.pli"
export Anything


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

doc
  ['Database' is the generic data type that will store in memory all the data of a database, enable to load or store them to the disk using a single command, and update the log so that in case of an application crash, no data will be lost.] ; eol
  [A 'Database' object is the visible part (the one the application uses) or an underlying '] ; link "DatabaseFile" "file.pli" ; [' object.]


gvar Relation 'pliant database types'
export 'pliant database types'

function Database t -> tt
  arg Type t ; arg_R Type tt
  has_no_side_effect

  var Address adr := 'pliant database types' query addressof:t null
  if adr<>null
    return (adr map Type)

  Data t
  runtime_compile  Value t  Database (cast "(Database "+t:name+")" Ident)  Data (cast "(Data "+t:name+")" Ident)  casttodata (cast "cast (Data "+t:name+")" Ident)  interface_arrow (cast "interface "+t:name Ident)

    type Database
      field DatabaseFile file
      field Value value

    DatabaseFile maybe Database

    constant interface_arrow (cast (addressof data_interface:Value) Arrow)
    function build  db
      arg_w Database db
      db:file:root_interface :> interface_arrow omap DataInterface_

    method db data -> d
      oarg Database db ; arg Data d
      (addressof:db omap Database_) get_root (addressof:d map Data_)
    ((the_function '. data' Database -> Data) arg 1) access += access_result_consistent
 
    export '. data'
    'pliant database types' define addressof:Value null addressof:Database
    'pliant database types' define null addressof:Database addressof:Value

  var Address adr := 'pliant database types' query addressof:t null
  check adr<>null
  return (adr map Type)
    

method a is_data -> c
  arg Type a ; arg CBool c
  has_no_side_effect
  c := ('pliant data types' query null addressof:a)<>null

method e is_data -> c
  arg_rw Expression e ; arg CBool c
  c := false
  e compile ?
  e uncast
  var Link:Type t :> e:result type
  while not t:is_data
    if not t:is_pointer
      return
    t :> unpointerto t
  if not (e cast t)
    return
  c := true


meta '. load' e
  if e:size<2 or not (e:0 cast DatabaseFile) or not (e:1 cast Str)
    return
  var Link:Argument log :> e:1:result
  var Link:Argument mount :> argument constant Str ""
  var Int i := 2
  while i<e:size
    if e:i:ident="log" and i+1<e:size and (e:(i+1) cast Str)
      e suckup e:(i+1)
      log :> e:(i+1):result
      i += 2
    eif e:i:ident="mount" and i+1<e:size and (e:(i+1) cast Str)
      e suckup e:(i+1)
      mount :> e:(i+1):result
      i += 2
    eif e:i:ident="nolog"
      log :> argument constant Str ""
      i += 1
    else
      return
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function '. setup' DatabaseFile Str Str Str) e:0:result e:1:result log mount)
  e set_void_result

meta '. store' e
  if e:size=1 and (e:0 cast DatabaseFile)
    var Link:Argument s :> argument local Status
    e suckup e:0
    e add (instruction (the_function '. store' DatabaseFile -> Status) e:0:result s)
    e set_result s access_read

meta '. configure' e
  if e:size=2 and (e:0 cast DatabaseFile) and (e:1 cast Str)
    var Link:Argument s :> argument local Status
    e suckup e:0 ; e suckup e:1
    e add (instruction (the_function '. configure' Database_ Str -> Status) e:0:result e:1:result s)
    e set_result s access_read


export Database
export '. is_data'
export '. load' '. store' '. configure'

alias data_store data_store from "/pliant/appli/database/file.pli"
alias data_file_switch data_file_switch from "/pliant/appli/database/file.pli"
export data_store data_file_switch


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


doc
  [Sets a Data pointer.]

meta ':>' e
  if e:size<>2
    return
  if not e:0:is_data or (e:0:access .and. access_write)=0
    return
  var Pointer:Type t :> unpointerto e:0:result:type
  e:1 compile ?
  if addressof:(e:1 cast e:1:result e:1:access Data:t function_flag_implicit .or. function_flag_extension .or. function_flag_reduction)=null
    return
  e suckup e:1
  e suckup e:0
  e add (instruction (the_function 'copy Universal' Universal Universal Type) e:1:result e:0:result (argument mapped_constant Type Data_))
  e set_void_result
    
  
doc
  [Set the value of a field.]

function data_set d v t
  arg_rw Data_ d ; arg Universal v ; arg Type t
  d:base:sem request "database set "+d:path
  d:interface set d addressof:v t
  d:base:sem release

meta ':=' e
  if e:size<>2 or not e:0:is_data or (e:0:access .and. access_write)=0
    return
  var Link:Type t :> unpointerto e:0:result:type
  if data_kind:t<>data_field
    return
  e:1 compile ?
  if addressof:(e:1 cast e:1:result e:1:access t function_flag_implicit .or. function_flag_extension .or. function_flag_reduction)=null
    return
  e suckup e:1
  e suckup e:0
  e add (instruction (the_function data_set Data_ Universal Type) e:0:result e:1:result (argument mapped_constant Type t))
  e set_void_result
    

doc
  [Get a field in a record.]

function map_field r def -> f
  arg_rw Data_ r ; arg DataRecordFieldDef def ; arg Data_ f
  if (addressof r:interface)=(addressof def:record_interface)
    def apply r f
  else
    r:base:sem rd_request "database map field "+r:path+def:path
    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)<>DataRecord
    return
  var Pointer:DataRecord r :> (addressof data_interface:t) map DataRecord
  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:DataRecordFieldDef def :> (r:fields first f:name) map DataRecordFieldDef
      e add (instruction (the_function map_field Data_ DataRecordFieldDef -> Data_) e:0:result (argument mapped_constant DataRecordFieldDef def) a)
      e set_result a access_read+(e:0:access .and. access_write)
      return


doc
  [Get a record in a set.]

function map_record s key -> r
  arg_rw Data_ s ; arg Str key ; arg Data_ r
  s:base:sem rd_request "database map record "+s:path+"/"+html_decode:key
  r := s:interface search s key false
  s:base:sem rd_release

meta '' e
  if e:size<>2 or not (e:1 cast Str) or not e:0:is_data
    return
  var Link:Type t :> unpointerto e:0:result:type
  if data_kind:t<>data_set
    return
  var Link:Argument a :> argument local (Data t:value_type)
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function map_record Data_ Str -> Data_) e:0:result e:1:result a)
  e set_result a access_read+(e:0:access .and. access_write)


doc
  [Get the number of records in a set.]

function data_size s -> n
  arg_rw Data_ s ; arg Int n
  s:base:sem rd_request "database get size "+s:path
  n := s:interface count s "" ""
  s:base:sem rd_release

meta '. size' e
  if e:size<>1 or not e:0:is_data
    return
  var Link:Type t :> unpointerto e:0:result:type
  if data_kind:t<>data_set
    return
  var Link:Argument a :> argument local Int
  e suckup e:0
  e add (instruction (the_function data_size Data_ -> Int) e:0:result a)
  e set_result a access_read


doc
  [Create a record in a set.]

function data_create s key -> status
  arg_rw Data_ s ; arg Str key ; arg Status status
  s:base:sem request "database create "+s:path+"/"+html_encode:key
  status := s:interface create s key
  s:base:sem release

function data_create s key record -> status
  arg_rw Data_ s ; arg Str key ; arg Type record ; arg Status status
  s:base:sem request "database create "+s:path+"/"+html_encode:key
  status := s:interface create s key
  if status=success
    var Data_ r := s:interface search s key
    for (var Int i) 0 record:nb_fields-1
      r:interface create r (record field i):name
  s:base:sem release

meta '. create' e
  if e:size<>2 or not (e:1 cast Str) or not e:0:is_data
    return
  var Link:Type t :> unpointerto e:0:result:type
  if data_kind:t<>data_set
    return
  var Link:Type v :> t value_type
  var Link:Argument a :> argument local Status
  e suckup e:0 ; e suckup e:1
  if exists:v and data_kind:v=data_record
    e add (instruction (the_function data_create Data_ Str Type -> Status) e:0:result e:1:result (argument mapped_constant Type v) a)
  else
    e add (instruction (the_function data_create Data_ Str -> Status) e:0:result e:1:result a)
  e set_result a access_read


doc
  [Delete a record in a set.]

function data_delete s key -> status
  arg_rw Data_ s ; arg Str key ; arg Status status
  s:base:sem request "database delete "+s:path+"/"+html_encode:key
  status := s:interface delete s key
  s:base:sem release

meta '. delete' e
  if e:size<>2 or not (e:1 cast Str) or not e:0:is_data
    return
  var Link:Type t :> unpointerto e:0:result:type
  if data_kind:t<>data_set
    return
  var Link:Argument a :> argument local Status
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function data_delete Data_ Str -> Status) e:0:result e:1:result a)
  e set_result a access_read


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


doc
  [Test if we are pointing to a data that already exists.]

function data_exists d -> c
  arg_rw Data_ d ; arg CBool c
  c := d:adr<>null

meta exists e
  if e:size<>1 or not e:0:is_data
    return
  var Link:Type t :> unpointerto e:0:result:type
  var Link:Argument a :> argument local CBool
  e suckup e:0
  e add (instruction (the_function data_exists Data_ -> CBool) e:0:result a)
  e set_result a access_read


doc
  [Get the key of the data. The key is the last level in the data path.]

meta keyof e
  if e:size<>1 or not e:0:is_data
    return
  var Link:Type t :> unpointerto e:0:result:type
  var Link:Argument a :> argument local Str
  e suckup e:0
  e add (instruction (the_function '. key' Data_ -> Str) e:0:result a)
  e set_result a access_read


doc
  [Get the all path to the data.]

meta pathof e
  if e:size<>1 or not e:0:is_data
    return
  var Link:Type t :> unpointerto e:0:result:type
  var Link:Argument a :> argument local Str
  e suckup e:0
  e add (instruction (the_function '. path' Data_ -> Str) e:0:result a)
  e set_result a access_read


doc
  [Get a pointer to a data specifyed using it's path.]

method d1 search_path path createit -> d2
  arg Data_ d1 ; arg Str path ; arg CBool createit ; arg Data_ d2
  var Pointer:Database_ b :> d1 base
  b:sem rd_request "database search path "+d1:path+" "+path
  var CBool rw := false
  d2 := d1
  var Str p := path
  while (p parse "/" any:(var Str k) "/" any:(var Str remain))
    if (addressof d2:base:sem)<>(addressof b:sem)
      if rw
        b:sem release
      else
        b:sem rd_release
      b :> d2 base
      if rw
        b:sem request "database search path "+d1:path+" "+path
      else
        b:sem rd_request "database search path "+d1:path+" "+path
    var Data_ temp := d2:interface search d2 html_decode:k
    if temp:adr=null and createit
      if not rw
        b:sem rd_release
        b:sem request "database search path "+d1:path+" "+path
        rw := true
      if (d2:interface create d2 html_decode:k)=success
        temp := d2:interface search d2 html_decode:k
    d2 := temp ; p := "/"+remain
  if (p parse "/" any:(var Str k))
    if (addressof d2:base:sem)<>(addressof b:sem)
      if rw
        b:sem release
      else
        b:sem rd_release
      b :> d2 base
      if rw
        b:sem request "database search path "+d1:path+" "+path
      else
        b:sem rd_request "database search path "+d1:path+" "+path
    var Data_ temp := d2:interface search d2 html_decode:k
    if temp:adr=null and createit
      if not rw
        b:sem rd_release
        b:sem request "database search path "+d1:path+" "+path
        rw := true
      if (d2:interface create d2 html_decode:k)=success
        temp := d2:interface search d2 html_decode:k
    d2 := temp
  if rw
    b:sem release
  else
    b:sem rd_release

meta '. pmap' e
  if e:size=2 and (e:0 cast Str) and (e:1 constant Type)<>null
    var Pointer:Type t :> (e:1 constant Type) map Type
    var Link:Argument a :> argument local Data:t
    e suckup e:0
    e add (instruction (the_function '. search_path' Data_ Str CBool -> Data_) (argument mapped_constant Data_ data_root) e:0:result (argument constant CBool false) a)
    e set_result a access_read+access_write
  eif e:size=3 and e:0:is_data and (e:1 cast Str) and (e:2 constant Type)<>null
    var Pointer:Type t :> (e:2 constant Type) map Type
    var Link:Argument a :> argument local Data:t
    e suckup e:0 ; e suckup e:1
    e add (instruction (the_function '. search_path' Data_ Str CBool -> Data_) e:0:result e:1:result (argument constant CBool false) a)
    e set_result a access_read+(e:0:access .and. access_write)


function data_reset d
  arg_rw Data_ d
  d:base:sem request "database reset "+d:path
  d:interface reset d
  d:base:sem release

meta data_reset e
  if e:size<>1 or not e:0:is_data or (e:0:access .and. access_write)=0
    return
  e suckup e:0
  e add (instruction (the_function data_reset Data_) e:0:result)
  e set_void_result
    

doc
  ['data_copy' will allow you to copy datas that have completely different type, the mapping beeing performed though matching subpath.]

function data_rec_copy src dest
  arg_rw Data_ src dest
  var Pointer:Type t :> src:interface type src
  if t<>Void
    var Arrow a := entry_new t
    if (src:interface get src a t)=success
      dest:interface set dest a t
  var Data_ src2 := src:interface first src "" "" (var DataScanBuffer buf)
  while src2:adr<>null
    var Data_ dest2 := dest:interface search dest src2:key true
    if dest2:adr<>null
      data_rec_copy src2 dest2
    src2 := src:interface next src "" "" buf

function data_copy src dest
  arg_rw Data_ src dest
  part copy "database copy "+src:path+" -> "+dest:path
    dest:base:sem request
    if (addressof src:base:sem)<>(addressof dest:base:sem)
      src:base:sem rd_request
    dest:interface reset dest
    data_rec_copy src dest
    if (addressof src:base:sem)<>(addressof dest:base:sem)
      src:base:sem rd_release
    dest:base:sem release

meta data_copy e
  if e:size<>2 or not e:0:is_data or not e:1:is_data or (e:1:access .and. access_write)=0
    return
  e suckup e:0 ; e suckup e:1
  e add (instruction (the_function data_copy Data_ Data_) e:0:result e:1:result)
  e set_void_result


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


doc
  [And now the big 'each' meta that will allow to scan all the elements of a set, filter them, and sort them.]

function scan_first d c buf -> some
  arg Data_ d ; arg_w Data_ c ; arg_w DataScanBuffer buf ; arg CBool some
  var Pointer:Database_ db :> d base
  db:sem rd_request "database search first "+d:path
  c := d:interface first d "" "" buf
  db:sem rd_release
  some := c:adr<>null

function scan_next d c buf -> some
  arg Data_ d ; arg_w Data_ c ; arg_rw DataScanBuffer buf ; arg CBool some
  var Pointer:Database_ db :> d base
  db:sem rd_request "database search next "+d:path
  c := d:interface next d "" "" buf
  db:sem rd_release
  some := c:adr<>null

function is_null a -> c
  arg Address a ; arg CBool c
  c := a=null

function pick_function id t0 t1 t2 t3 n r m -> f
  arg Str id ; arg Type t0 t1 t2 t3 ; arg Int n r ; arg Module m ; arg_R Function f
  for (var Int lap) 0 1
    var Link:Module module
    if lap=0
      module :> m
    else
      module :> the_module "/pliant/language/type/set/index.pli"
    var Pointer:Arrow c :> module first id
    while c<>null
      if entry_type:c=Function
        f :> c map Function
        if f:nb_args=n and f:nb_args_with_result=r and (not exists:t0 or (f arg 0):type=t0) and (not exists:t1 or (f arg 1):type=t1) and (not exists:t2 or (f arg 2):type=t2) and (not exists:t3 or (f arg 3):type=t3)
          return
      c :> module next id c
  f :> null map Function
  error error_id_compile "failed to pick function "+id

meta each e
  if e:size<3 or not e:0:is_pure_ident
    return
  var Pointer:Expression filter :> null map Expression
  var Pointer:Expression sort :> null map Expression
  var CBool reversed := false
  var Int i := 2
  while i<e:size-1
    if e:i:ident="filter" and i+1<e:size-1
      filter :> e i+1
      i += 2
    eif e:i:ident="sort" and i+1<e:size-1
      sort :> e i+1
      i += 2
    eif e:i:ident="reversed" and exists:sort
      reversed := true
      i += 1
    else
      return
  e:1 compile ?
  var Pointer:Type set :> e:1:result:type:real_data_type
  if set:category<>"Set"
    return
  var Link:Argument buf :> argument local DataScanBuffer
  var Link:Argument some :> argument local CBool
  var Link:Argument item :> e local_variable e:0:ident (Data set:value_type)
  var Link:Argument item :> e local_variable e:0 (Data set:value_type)
  if not exists:item
    return
  if addressof:filter<>null and not (filter cast CBool)
    return
  if addressof:sort<>null
    sort compile ?
    var Pointer:Type key :> sort:result:type real_data_type
    if not (sort cast key)
      return
    var Link:Argument idx :> argument local (Index key Data_)
    var Link:Argument adr :> argument local Address
    e add (instruction (the_function 'address Universal' Universal -> Address) idx adr)
    e add (instruction (the_function '. destroy_instance' Type Address) (argument mapped_constant Type (Index key Data_)) adr)
    e add (instruction (the_function '. build_instance' Type Address) (argument mapped_constant Type (Index key Data_)) adr)
  (e e:size-1) compile ?
  e:1 cast Data:set ; e suckup e:1
  var Link:Instruction next :> instruction the_function:'do nothing'
  var Link:Instruction end :> instruction the_function:'do nothing'
  e add (instruction (the_function scan_first Data_ Data_ DataScanBuffer -> CBool) e:1:result item buf some)
  e add (instruction (the_function 'jump if not' CBool) some jump end)
  var Link:Instruction body :> instruction the_function:'do nothing'
  e add body
  if addressof:filter<>null
    e suckup filter
    e add (instruction (the_function 'jump if not' CBool) filter:result jump next)
  if addressof:sort=null
    e suckup (e e:size-1)
  else
    e suckup sort
    var Link:Function f :>pick_function ". insert" (Index key Data_) key Data_ Data_ 3 4 e:module ?
    e add (instruction f idx sort:result item (argument indirect Data_ (argument local Address) 0))
  if addressof:filter<>null
    e add next
  e add (instruction (the_function scan_next Data_ Data_ DataScanBuffer -> CBool) e:1:result item buf some)
  e add (instruction (the_function 'jump if' CBool) some jump body)
  e add end
  if addressof:sort<>null
    var Link:Argument ptr :> argument local Address
    var Link:Argument cursor :> argument indirect Data_ ptr 0
    var Link:Argument cond :> argument local CBool
    var Link:Instruction stop :> instruction the_function:'do nothing'
    var Link:Function f :> pick_function (shunt reversed ". last" ". first") (Index key Data_) Data_ (null map Type) (null map Type) 1 2 e:module ?
    e add (instruction f idx cursor)
    e add (instruction (the_function is_null Address -> CBool) ptr cond)
    e add (instruction (the_function 'jump if' CBool) cond jump stop)
    var Link:Instruction again :> instruction the_function:'do nothing'
    e add again
    e add (instruction (the_function 'copy Universal' Universal Universal Type) cursor item (argument mapped_constant Type Data_))
    e suckup (e e:size-1)
    var Link:Function f :>pick_function (shunt reversed ". previous" ". next") (Index key Data_) Data_ Data_ (null map Type) 2 3 e:module ?
    e add (instruction f idx cursor cursor)
    e add (instruction (the_function is_null Address -> CBool) ptr cond)
    e add (instruction (the_function 'jump if not' CBool) cond jump again)
    e add stop
  e set_void_result


export '. search_path'

export ':>' ':=' '' '. size' '. create' '. delete' keyof pathof exists
export '. pmap' data_reset data_copy
export each