/pliant/storage/database/split.pli
 
 1  abstract 
 2    [Split databases enable to handle very large sets of datas.] 
 3   
 4  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 5  # 
 6  # This program is free software; you can redistribute it and/or 
 7  # modify it under the terms of the GNU General Public License version 2 
 8  # as published by the Free Software Foundation. 
 9  # 
 10  # This program is distributed in the hope that it will be useful, 
 11  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 12  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 13  # GNU General Public License for more details. 
 14  # 
 15  # You should have received a copy of the GNU General Public License 
 16  # version 2 along with this program; if not, write to the Free Software 
 17  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 18   
 19  # scope "/pliant/storage/" "/pliant/appli/" 
 20  module "/pliant/language/compiler.pli" 
 21  module "/pliant/language/context.pli" 
 22  module "/pliant/language/stream.pli" 
 23  module "/pliant/language/stream/filesystembase.pli" 
 24  module "/pliant/admin/file.pli" 
 25  module "/pliant/util/encoding/html.pli" 
 26  module "/pliant/util/encoding/general.pli" 
 27  module "/pliant/admin/md5.pli" 
 28  module "/pliant/language/schedule/daemon.pli" 
 29  module "prototype.pli" 
 30  module "io.pli" 
 31  module "interface.pli" 
 32  module "pointer.pli" 
 33  module "/pliant/language/data/cache.pli" 
 34   
 35  constant split_default_modulus 1000 
 36   
 37   
 38  type DatabaseSplit 
 39    field Database_ common 
 40    field Str filename 
 41    field Arrow root 
 42    field Link:DataInterface_ root_interface 
 43    field Pointer:Database_ database_ 
 44    field Str subpath 
 45   
 46  CachePrototype maybe DatabaseSplit 
 47  Database_ maybe DatabaseSplit 
 48   
 49   
 50  method ds database -> db 
 51    arg DatabaseSplit ds ; oarg_C Database_ db 
 52    db :> (addressof ds:database_) omap Database_ 
 53   
 54  method ds adjust_flags 
 55    arg_rw DatabaseSplit ds 
 56    if ds:database:flags:database_compressed 
 57      ds:common:flags += database_compressed 
 58    else 
 59      ds:common:flags -= database_compressed 
 60   
 61  method ds drop 
 62    oarg_rw DatabaseSplit ds 
 63    if ds:common:flags:database_modified 
 64      database_trace trace "store and unload " ds:filename 
 65      ds adjust_flags 
 66      file_tree_create ds:filename 
 67      ds do_store ds:filename 
 68    else 
 69      database_trace trace "unload " ds:filename 
 70   
 71  method ds get_root d 
 72    arg DatabaseSplit ds ; arg_w Data_ d 
 73    d adr := ds root 
 74    d object := ds root 
 75    d interface :> ds root_interface 
 76    d base :> ds 
 77    d path1 :> "" 
 78    d path2 :> null map Str 
 79   
 80   
 81  method ds back d -> d2 
 82    arg_rw DatabaseSplit ds ; arg Data_ d d2 
 83    d2 := d 
 84    d2 path1 :> new Str ds:subpath+d:dbpath 
 85    d2 path2 :> null map Str 
 86    d2 base :> ds database 
 87   
 88  method ds notify_set d adr type 
 89    arg_rw DatabaseSplit ds ; arg Data_ d ; arg Address adr ; arg Type type 
 90    if not ds:common:flags:database_loading 
 91      ds:common flags += database_modified 
 92      ds:database notify_set (ds back d) adr type 
 93   
 94  method ds notify_reset d 
 95    arg_rw DatabaseSplit ds ; arg Data_ d 
 96    if not ds:common:flags:database_loading 
 97      ds:common flags += database_modified 
 98      ds:database notify_reset (ds back d) 
 99   
 100  method ds notify_create d k 
 101    arg_rw DatabaseSplit ds ; arg Data_ d ; arg Str k 
 102    if not ds:common:flags:database_loading 
 103      ds:common flags += database_modified 
 104      ds:database notify_create (ds back d) k 
 105   
 106  method ds notify_delete d k 
 107    arg_rw DatabaseSplit ds ; arg Data_ d ; arg Str k 
 108    if not ds:common:flags:database_loading 
 109      ds:common flags += database_modified 
 110      ds:database notify_delete (ds back d) k 
 111   
 112   
 113  method ds setup filename type interface database subpath 
 114    arg_rw DatabaseSplit ds ; arg Str filename ; arg Type type ; arg DataInterface_ interface ; arg Database_ database ; arg Str subpath 
 115    ds:common flags := cast 0 DatabaseFlags 
 116    ds:common path := database:path+subpath 
 117    ds filename := filename 
 118    ds root := entry_new type 
 119    ds root_interface :> interface 
 120    ds database_ :> database 
 121    ds subpath := subpath 
 122    ds sem :> database sem 
 123   
 124   
 125 
 
 126   
 127   
 128  method t split_type -> st 
 129    arg Type t ; arg_R Type st 
 130    st :> (t:properties first "split type") map Type 
 131   
 132   
 133  meta split_field e 
 134    var Pointer:Arrow c :> pliant_general_dictionary first "pliant type" 
 135    if c=null or entry_type:c<>Type 
 136      return 
 137    if e:size<2 or (e:0 constant Type)=null 
 138      return 
 139    var Link:Type t :> c map Type 
 140    var Link:Type st :> t split_type 
 141    if not exists:st 
 142      st :> new Type 
 143      st name := t:name+" split" 
 144      t:properties insert "split type" true addressof:st 
 145      (addressof:Universal map Type) maybe st 
 146    pliant_general_dictionary insert2 "pliant type" true addressof:st e:module 
 147    e compile_as (expression immediat (field t ids) substitute t e:0 substitute ids (e 1 e:size-1)) 
 148    pliant_general_dictionary remove "pliant type" addressof:st 
 149    st terminate_fields 
 150   
 151   
 152 
 
 153   
 154   
 155  type DataSplitFieldDef 
 156    field Pointer:DataInterface_ fixed_interface 
 157    field CBool split 
 158    field Int offset 
 159    field Link:DataInterface_ interface 
 160    field Str path 
 161    field Arrow default 
 162   
 163  type DataSplit 
 164    field Dictionary fields 
 165    field List base_fields all_fields 
 166    field Link:Type fixed_type split_type 
 167    field Int arrow_offset 
 168    field uInt modulus <- split_default_modulus 
 169    field Pointer:DataInterface_ split_interface 
 170    
 171  DataInterface_ maybe DataSplit 
 172   
 173   
 174  gvar (Array uInt8 256) db_code := general_code "" 
 175   
 176  function db_encode clear -> encoded 
 177    arg Str clear encoded 
 178    encoded := general_encode clear "_":number db_code 
 179   
 180  function db_decode encoded -> clear 
 181    arg Str encoded clear 
 182    clear := general_decode encoded "_":number 
 183   
 184  method s db_hash -> u 
 185    arg Str s ; arg uInt u 
 186    var Str md5 := string_md5_binary_signature s 
 187    u := md5:characters map uInt 
 188   
 189  method ds filename d -> name 
 190    arg DataSplit ds ; arg Data_ d ; arg Str name 
 191    var Str all := d:base query "filename" 
 192    var Int i := (all search_last "/" -1)+1 
 193    var Str path := all 0 i 
 194    path := replace path "security:/" "data:/pliant/split/" 
 195    var Str file := all i all:len 
 196    var Int i := file search_last "." file:len 
 197    var Str base := file 0 i 
 198    var Str ext := file i file:len 
 199    name := path+base+"/"+ds:fixed_type:name+"/"+(shunt ds:modulus<>1 (string d:key:db_hash%ds:modulus)+"/" "")+(db_encode d:key)+ext 
 200   
 201  method ds content d -> db 
 202    arg DataSplit ds ; arg Data_ d ; arg Link:DatabaseSplit db 
 203    # console "path = " d:path eol 
 204    if (cache_open d:path DatabaseSplit ((addressof Link:DatabaseSplit db) map Link:CachePrototype)) 
 205      var Str filename := ds filename d 
 206      database_trace trace "load " filename 
 207      db setup filename ds:split_type ds:split_interface d:base d:dbpath 
 208      db do_load filename 
 209      cache_ready ((addressof Link:DatabaseSplit db) map Link:CachePrototype) 
 210   
 211  method ds reset d -> status 
 212    oarg_rw DataSplit ds ; arg_rw Data_ d ; arg Status status 
 213    ds:fixed_type destroy_instance d:adr 
 214    ds:fixed_type build_instance d:adr 
 215    d:base notify_reset d 
 216    status := success 
 217   
 218   
 219  method f apply d d2 
 220    arg DataSplitFieldDef f ; arg Data_ d ; arg_w Data_ d2 
 221    d2 adr := d:adr translate Byte f:offset 
 222    d2 object := d object 
 223    d2 interface :> f interface 
 224    d2 base :> d base 
 225    if (addressof d:path2)=null 
 226      d2 path1 :> d path1 
 227      d2 path2 :> f path 
 228    else 
 229      d2 path1 :> new Str d:path1+d:path2+f:path 
 230      d2 path2 :> null map Str 
 231   
 232  method f apply ds d2 
 233    arg DataSplitFieldDef f ; arg DatabaseSplit ds ; arg_w Data_ d2 
 234    d2 adr := ds:root translate Byte f:offset 
 235    d2 object := ds:root 
 236    d2 interface :> f interface 
 237    d2 base :> ds 
 238    d2 path1 :> "" 
 239    d2 path2 :> f path 
 240   
 241  method ds search d k -> d2 
 242    oarg DataSplit ds ; arg Data_ d ; arg Str k ; arg Data_ d2 
 243    var Pointer:Arrow a :> ds:fields first k 
 244    if a<>null 
 245      var Pointer:DataSplitFieldDef f :> a map DataSplitFieldDef 
 246      if f:split 
 247        f apply (ds content d) d2 
 248      else 
 249        f apply d d2 
 250    else 
 251      d2 := data_null 
 252      d2 base :> d base 
 253      d2 path1 :> new Str d:dbpath+"/"+html_encode:k 
 254      d2 path2 :> null map Str 
 255   
 256  method ds next d start stop buf -> d2 
 257    oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg_rw DataScanBuffer buf ; arg Data_ d2 
 258    var Pointer:Arrow a 
 259    if buf:adr<>null 
 260      a :> ds:all_fields next (buf:adr map Arrow) 
 261    else 
 262      a :> ds:all_fields first 
 263    while a<>null 
 264      var Pointer:DataSplitFieldDef f :> a map DataSplitFieldDef 
 265      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) 
 266        if f:split 
 267          f apply (ds content d) d2 
 268        else 
 269          f apply d d2 
 270        buf adr := addressof a 
 271        return 
 272      a :> ds:all_fields next a 
 273    d2 adr := null 
 274   
 275  method ds first d start stop buf -> d2 
 276    oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg_w DataScanBuffer buf ; arg Data_ d2 
 277    buf adr := null 
 278    d2 := ds next d start stop buf 
 279   
 280  method ds count d start stop -> count 
 281    oarg_rw DataSplit ds ; arg Data_ d ; arg Str start stop ; arg Int count 
 282    if start:len=0 and stop:len=0 
 283      count := ds:fields count 
 284    else 
 285      count := 0 
 286      var Pointer:Arrow c :> ds:all_fields first 
 287      while c<>null 
 288        var Pointer:DataSplitFieldDef f :> c map DataSplitFieldDef 
 289        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) 
 290          count += 1 
 291        c :> ds:all_fields next c 
 292   
 293   
 294  method ds next_to_store d start stop buf -> d2 
 295    oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg_rw DataScanBuffer buf ; arg Data_ d2 
 296    var Pointer:Arrow a 
 297    if buf:adr<>null 
 298      a :> ds:base_fields next (buf:adr map Arrow) 
 299    else 
 300      a :> ds:base_fields first 
 301    while a<>null 
 302      var Pointer:DataSplitFieldDef f :> a map DataSplitFieldDef 
 303      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) 
 304        f apply d d2 
 305        buf adr := addressof a 
 306        return 
 307      a :> ds:base_fields next a 
 308    d2 adr := null 
 309   
 310  method ds first_to_store d start stop buf -> d2 
 311    oarg DataSplit ds ; arg Data_ d ; arg Str start stop ; arg_w DataScanBuffer buf ; arg Data_ d2 
 312    if (cache_search d:path (var Link:CachePrototype cp)) 
 313      var Link:DatabaseSplit db :> addressof:cp map DatabaseSplit 
 314      if db:common:flags:database_modified 
 315        db adjust_flags 
 316        file_tree_create db:filename 
 317        db do_store db:filename 
 318        db:common flags -= database_modified 
 319    buf adr := null 
 320    d2 := ds next_to_store d start stop buf 
 321   
 322   
 323  method ds pre_delete t k 
 324    arg DataSplit ds ; arg Data_ t ; arg Str k 
 325    var Data_ r := t:interface search t k 
 326    if r:adr<>null 
 327      cache_delete t:path+"/"+html_encode:k 
 328      var Str filename := ds filename r 
 329      file_delete filename 
 330   
 331   
 332 
 
 333   
 334   
 335  function split_interface t -> di 
 336    arg Type t ; arg Link:DataInterface_ di 
 337    var DataKind k := data_kind t 
 338    if k<>data_record 
 339      return 
 340    var Pointer:Type st :> t split_type 
 341    if not exists:st 
 342      return 
 343    var Link:DataSplit ds :> new DataSplit 
 344    ds fixed_type :> t 
 345    ds split_type :> st 
 346    ds split_interface :> data_interface st 
 347    var (Index Str Arrow) base_order all_order 
 348    for (var Int i) 0 t:nb_fields-1 
 349      var Pointer:TypeField tf :> t field i 
 350      if tf:name<>"split arrow" 
 351        var Link:DataSplitFieldDef f :> new DataSplitFieldDef 
 352        f fixed_interface :> ds 
 353        f split := false 
 354        f offset := tf offset 
 355        f interface :> data_interface tf:type 
 356        f path := "/"+(html_encode tf:name) 
 357        f default := tf initial_value 
 358        ds:fields insert tf:name false addressof:f 
 359        var Arrow a := addressof f 
 360        base_order insert tf:name a 
 361        all_order insert tf:name a 
 362      else 
 363        ds arrow_offset := tf:offset 
 364    for (var Int i) 0 st:nb_fields-1 
 365      var Pointer:TypeField tf :> st field i 
 366      var Link:DataSplitFieldDef f :> new DataSplitFieldDef 
 367      f fixed_interface :> ds 
 368      f split := true 
 369      f offset := tf offset 
 370      f interface :> data_interface tf:type 
 371      f path := "/"+(html_encode tf:name) 
 372      f default := tf initial_value 
 373      ds:fields insert tf:name false addressof:f 
 374      var Arrow a := addressof f 
 375      all_order insert tf:name a 
 376    var Pointer:Arrow c :> base_order first 
 377    while addressof:c<>null 
 378      ds:base_fields append c 
 379      c :> base_order next c 
 380    var Pointer:Arrow c :> all_order first 
 381    while addressof:c<>null 
 382      ds:all_fields append c 
 383      c :> all_order next c 
 384    di :> ds 
 385   
 386  data_interface_generators insert_before data_interface_generators:first addressof:(the_function split_interface Type -> Link:DataInterface_) 
 387   
 388   
 389 
 
 390   
 391   
 392  function map_field r def -> f 
 393    arg_rw Data_ r ; arg DataSplitFieldDef def ; arg Data_ f 
 394    if (addressof r:interface)=(addressof def:fixed_interface) 
 395      if def:split 
 396        var Pointer:DataSplit ds :> (addressof def:fixed_interface) map DataSplit 
 397        def apply (ds content r) f 
 398      else 
 399        def apply r f 
 400    else 
 401      r:base:sem rd_request 
 402      f := r:interface search r html_decode:(def:path 1 def:path:len) false 
 403      r:base:sem rd_release 
 404      if f:adr=null 
 405        f object := def default 
 406   
 407  meta '' e 
 408    if e:size<>2 or not e:1:is_pure_ident or not e:0:is_data 
 409      return 
 410    var Link:Type t :> unpointerto e:0:result:type 
 411    if entry_type:(addressof data_interface:t)<>DataSplit 
 412      return 
 413    var Pointer:DataSplit r :> (addressof data_interface:t) map DataSplit 
 414    for (var Int i) 0 t:nb_fields-1 
 415      var Pointer:TypeField f :> t field i 
 416      if f:name=e:1:ident 
 417        var Link:Type dt :> Data f:type 
 418        var Link:Argument a :> argument local dt 
 419        e suckup e:0 
 420        var Pointer:DataSplitFieldDef def :> (r:fields first f:name) map DataSplitFieldDef 
 421        e add (instruction (the_function map_field Data_ DataSplitFieldDef -> Data_) e:0:result (argument mapped_constant DataSplitFieldDef def) a) 
 422        e set_result a access_read+(e:0:access .and. access_write) 
 423        return 
 424    var Pointer:Type st :> t split_type 
 425    for (var Int i) 0 st:nb_fields-1 
 426      var Pointer:TypeField f :> st field i 
 427      if f:name=e:1:ident 
 428        var Link:Type dt :> Data f:type 
 429        var Link:Argument a :> argument local dt 
 430        e suckup e:0 
 431        var Pointer:DataSplitFieldDef def :> (r:fields first f:name) map DataSplitFieldDef 
 432        e add (instruction (the_function map_field Data_ DataSplitFieldDef -> Data_) e:0:result (argument mapped_constant DataSplitFieldDef def) a) 
 433        e set_result a access_read+(e:0:access .and. access_write) 
 434        return 
 435   
 436   
 437 
 
 438   
 439   
 440  function split_dispatch path modulus 
 441    arg Str path ; arg uInt modulus 
 442    var Array:FileInfo files := file_list path standard+recursive+relative 
 443    for (var Int i) 0 files:size-1 
 444      var Str key := db_decode files:i:stripped_name 
 445      var Str old := path+files:i:name 
 446      var Str name := path+(shunt modulus<>1 (string key:db_hash%modulus)+"/" "")+db_encode:key+".pdb" 
 447      if old<>name 
 448        file_tree_create name 
 449        file_move old name 
 450        old := old 0 (old search_last "/" -1)+1 
 451        file_delete old 
 452    files := file_list path standard+directories 
 453    for (var Int i) 0 files:size-1 
 454      if files:i:is_directory 
 455        file_delete files:i:name 
 456   
 457   
 458  export split_field '' 
 459  export split_dispatch