/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