File: dbf\db_file_io.adb
1 --::::::::::
2 --dbfileio.adb
3 --::::::::::
4 -- Developed by (C) Wasiliy W. Molostoff 1994, 1995.
5 -- Moscow, Russia,
6 -- Voice: 7 (095) 398-23-38
7 -- e-mail: edv@edv.msk.ru
8 -- This is free software; you can freely redistribute it and/or
9 -- modify it without any restrictions. Please report any errors.
10 -- All corrections will be made as soon as possible.
11
12 with calendar, unsigned, unsigned_io, unchecked_conversion,
13 unchecked_deallocation, choice;
14
15 use calendar, unsigned;
16
17 package body db_file_io is
18
19 tab_desc_length: constant := 64;
20
21 package uio renames unsigned_io;
22
23 function max is new choice (integer, ">");
24 function min is new choice (integer, "<");
25
26 type col_description is
27 record
28 name : string (1..32);
29 length : natural; -- name length
30 offset : natural; -- offset in the rec_buffer (from 0)
31 params : col_stat;
32 end record;
33
34 procedure set_name (desc: in out col_description; name: in string);
35
36 package db_format_specific is
37
38 subtype col_desc_index is positive range 1..tab_desc_length;
39 type col_desc_table is array (col_desc_index range <>) of col_description;
40
41 type file_header is
42 record
43
44 tab_attrib : tab_attribute;
45 tab_updated : time;
46 col_begins,
47 row_begins : unsigned_io.count;
48 row_posinc : unsigned_io.count;
49 row_length : natural;
50 row_count : count;
51 col_count,
52 col_namelen : natural;
53
54 end record;
55
56 subtype file_type is unsigned_io.file_type;
57
58 procedure read_info (file: in out file_type;
59 header: in out file_header;
60 tab: in out col_desc_table);
61
62 procedure write_info (file: in out file_type;
63 header: in out file_header;
64 tab: in col_desc_table);
65
66 procedure write_record (file: in out file_type;
67 header: in file_header;
68 buf: in byte_string;
69 attr: in row_attribute;
70 to: in positive_count);
71
72 procedure read_record (file: in out file_type;
73 header: in file_header;
74 buf: out byte_string;
75 attr: out row_attribute;
76 from: in positive_count);
77
78 end db_format_specific;
79
80 use db_format_specific;
81
82 type byte_buffer is access byte_string;
83 type col_desc_buffer is access col_desc_table;
84
85 type file_object is
86 record
87
88 uio_file : uio.file_type;
89 headings : file_header;
90
91 rec_index : count; -- current record index
92 rec_iopos : count; -- record really located
93 rec_buffer : byte_buffer; -- pointer to the record
94 rec_attrib : row_attribute; -- abstract record attribute
95 rec_changed : boolean; -- record/attribute data changed
96
97 col_table : col_desc_buffer; -- pointer to the column table
98 tab_changed : boolean; -- col_table is changed
99
100 end record;
101
102 package body db_format_specific is separate;
103
104 --------------------------------------------------------------------------
105
106 procedure set_name (desc: in out col_description;
107 name: in string) is
108 safe_length: natural := min (name'length, desc.name'length);
109 begin
110 desc.name (1..safe_length) := name (name'first..name'first - 1 +
111 safe_length);
112 desc.length := safe_length;
113 for n in 1..safe_length
114 loop
115 case desc.name (n) is
116 when 'A'..'Z' | '_' | 'a'..'z' | '0'..'9' => null;
117 when others =>
118 desc.length := n - 1;
119 exit;
120 end case;
121 end loop;
122 exception
123 when others => raise data_error;
124 end;
125
126 procedure release (file: in out file_type) is
127 procedure destroy is new unchecked_deallocation (file_object, file_type);
128 procedure destroy is new unchecked_deallocation (byte_string, byte_buffer);
129 procedure destroy is new unchecked_deallocation (col_desc_table, col_desc_buffer);
130
131 begin
132 if file /= null
133 then
134 if uio.is_open (file.uio_file)
135 then
136 uio.close (file.uio_file);
137 end if;
138 destroy (file.rec_buffer);
139 destroy (file.col_table);
140 destroy (file);
141 end if;
142 end;
143
144 --------------------------------------------------------------------------
145
146 procedure ensure_status (file: in file_type) is
147 begin
148 if not is_open (file) then
149 raise status_error;
150 end if;
151 end;
152
153 procedure except_mode (file: in file_type; which: in file_mode) is
154 begin
155 if mode (file) = which then
156 raise mode_error;
157 end if;
158 end;
159
160 procedure ensure_data (file: in file_type) is
161
162 head: file_header renames file.headings;
163
164 -- invalid_data_location : exception;
165 -- incomplete_data_record : exception;
166 -- invalid_name_passed : exception;
167 -- invalid_description_logic : exception;
168
169 begin
170
171 -- if size (file.uio_file) < head.row_begins or else
172 -- size (file.uio_file) < uio.count (head.row_length)
173 -- + head.row_begins
174 -- then
175 -- raise data_error;
176 -- end if;
177
178 if head.row_count > 0 and then
179 (size (file.uio_file) - head.row_begins + 1)
180 / uio.count (head.row_count)
181 < uio.count(head.row_length)
182 then
183 raise data_error;
184 end if;
185 exception
186 when others => raise data_error;
187 end;
188
189 procedure ensure_col (file: in file_type; col: in natural) is
190 begin
191 if not (col in file.col_table'range)
192 then
193 raise use_error;
194 end if;
195 end;
196
197 procedure update (file: in out file_type) is
198 begin
199 if mode (file) /= in_file
200 then
201 if file.tab_changed
202 then
203 write_info (file.uio_file, file.headings, file.col_table.all);
204 file.tab_changed := false;
205 end if;
206 if file.rec_changed
207 then
208 write_record (file.uio_file,
209 file.headings,
210 file.rec_buffer.all,
211 file.rec_attrib,
212 file.rec_iopos);
213 file.rec_changed := false;
214 end if;
215 end if;
216 end;
217
218 procedure seek_current (file: in out file_type) is
219 begin
220 if file.rec_index /= file.rec_iopos
221 then
222 read (file, file.rec_buffer.all, file.rec_attrib);
223 file.rec_iopos := file.rec_index;
224 end if;
225 end;
226
227 --------------------------------------------------------------------------
228
229 function is_open (file : in file_type) return boolean is
230 begin
231 return file /= null and then uio.is_open (file.uio_file);
232 end;
233
234 --------------------------------------------------------------------------
235
236 procedure get_table (file : in file_type;
237 tab : in out table) is
238 begin
239 ensure_status (file);
240
241 if file.col_table = null or else
242 file.col_table'length > tab'length
243 then
244 raise storage_error;
245 end if;
246
247 declare
248 diff: integer := tab'first - file.col_table'first;
249 begin
250 for n in file.col_table'range
251 loop
252 tab (n + diff) := file.col_table (n).params;
253 end loop;
254 end;
255 end;
256
257 --------------------------------------------------------------------------
258
259 procedure delete (file : in out file_type) is
260 begin
261 ensure_status (file);
262 uio.delete (file.uio_file);
263 release (file);
264 exception
265 when others => release (file);
266 raise;
267 end;
268
269 --------------------------------------------------------------------------
270
271 function mode (file : in file_type) return file_mode is
272 begin
273 ensure_status (file);
274 return file_mode(uio.mode(file.uio_file));
275 end;
276
277 --------------------------------------------------------------------------
278
279 function name (file : in file_type) return string is
280 begin
281 ensure_status (file);
282 return uio.name (file.uio_file);
283 end;
284
285 --------------------------------------------------------------------------
286
287 function form (file : in file_type) return string is
288 begin
289 ensure_status (file);
290 return uio.form (file.uio_file);
291 end;
292
293 --------------------------------------------------------------------------
294
295 procedure reset (file : in out file_type;
296 mode : in file_mode) is
297 begin
298 ensure_status (file);
299 update (file);
300 uio.reset (file.uio_file, uio.file_mode(mode));
301 end;
302
303 --------------------------------------------------------------------------
304
305 procedure reset (file : in out file_type) is
306 begin
307 ensure_status (file);
308 update (file);
309 uio.reset (file.uio_file);
310 end;
311
312 --------------------------------------------------------------------------
313
314 procedure close (file : in out file_type) is
315 begin
316 ensure_status (file);
317 update (file);
318 uio.close (file.uio_file);
319 release (file);
320 end;
321
322 --------------------------------------------------------------------------
323
324 function tab_updated (file : in file_type) return time is
325 begin
326 ensure_status (file);
327 return file.headings.tab_updated;
328 end;
329
330 --------------------------------------------------------------------------
331
332 function tab_attrib (file : in file_type) return tab_attribute is
333 begin
334 ensure_status (file);
335 return file.headings.tab_attrib;
336 end;
337
338 --------------------------------------------------------------------------
339
340 function tab_length (file : in file_type) return count is
341 begin
342 ensure_status (file);
343 return file.headings.row_count;
344 end;
345
346 --------------------------------------------------------------------------
347
348 function row_index (file : in file_type) return positive_count is
349 begin
350 ensure_status (file);
351 return file.rec_index;
352 end;
353
354
355 --------------------------------------------------------------------------
356
357 function row_length (file : in file_type) return natural is
358 begin
359 ensure_status (file);
360 return file.rec_buffer'length;
361 end;
362
363 --------------------------------------------------------------------------
364
365 function row_attrib (file : in file_type) return row_attribute is
366 begin
367 ensure_status (file);
368 return file.rec_attrib;
369 end;
370
371 --------------------------------------------------------------------------
372
373 function col_count (file : in file_type) return positive is
374 begin
375 ensure_status (file);
376 return file.headings.col_count;
377 end;
378
379 --------------------------------------------------------------------------
380
381 function col_length (file : in file_type; from: in positive) return natural is
382 begin
383 ensure_status (file);
384 ensure_col (file, from);
385 return file.col_table (from).params.length;
386 end;
387
388 --------------------------------------------------------------------------
389
390 function col_index (file : in file_type;
391 from : in string) return natural is
392 begin
393 ensure_status (file);
394 for i in 1..col_count (file)
395 loop
396 if col_name (file, i) = from
397 then
398 return i;
399 end if;
400 end loop;
401 return 0;
402 end;
403
404 --------------------------------------------------------------------------
405
406 function col_align (file : in file_type; from: in positive) return natural is
407 begin
408 ensure_status (file);
409 ensure_col (file, from);
410 return file.col_table (from).params.align;
411 end;
412
413 --------------------------------------------------------------------------
414
415 function col_attrib (file : in file_type; from: in positive) return col_attribute is
416 begin
417 ensure_status (file);
418 ensure_col (file, from);
419 return file.col_table (from).params.attrib;
420 end;
421
422 --------------------------------------------------------------------------
423
424 function col_name (file : in file_type; from: in positive) return string is
425 begin
426 ensure_status (file);
427 ensure_col (file, from);
428 return file.col_table (from).name (1..file.col_table (from).length);
429 end;
430
431 --------------------------------------------------------------------------
432
433 procedure tab_attrib (file: in out file_type; new_attr: in tab_attribute) is
434 begin
435 ensure_status (file);
436 except_mode (file, in_file);
437 file.headings.tab_attrib := new_attr;
438 file.tab_changed := true;
439 file.headings.tab_updated := clock;
440 end;
441
442 --------------------------------------------------------------------------
443
444 procedure row_index (file : in out file_type;
445 to : in positive_count) is
446 begin
447 ensure_status (file);
448 file.rec_index := to;
449 end;
450
451 --------------------------------------------------------------------------
452
453 procedure row_attrib (file: in out file_type; new_attr: in row_attribute) is
454 begin
455 ensure_status (file);
456 except_mode (file, in_file);
457 file.rec_attrib := new_attr;
458 file.rec_changed := true;
459 file.headings.tab_updated := clock;
460 end;
461
462 --------------------------------------------------------------------------
463
464 procedure col_align (file : in out file_type;
465 col : in positive;
466 new_align : in natural) is
467 begin
468 ensure_status (file);
469 except_mode (file, in_file);
470 ensure_col (file, col);
471 file.col_table (col).params.align := new_align;
472 file.tab_changed := true;
473 file.headings.tab_updated := clock;
474 end;
475
476 --------------------------------------------------------------------------
477
478 procedure col_attrib (file: in out file_type;
479 col: in positive;
480 new_attr: in col_attribute) is
481 begin
482 ensure_status (file);
483 except_mode (file, in_file);
484 ensure_col (file, col);
485 file.col_table (col).params.attrib := new_attr;
486 file.tab_changed := true;
487 file.headings.tab_updated := clock;
488 end;
489
490 --------------------------------------------------------------------------
491
492 procedure col_name (file: in out file_type;
493 col: in positive;
494 new_name: in string) is
495
496 begin
497 ensure_status (file);
498 except_mode (file, in_file);
499 ensure_col (file, col);
500 set_name (file.col_table (col), new_name);
501 file.tab_changed := true;
502 file.headings.tab_updated := clock;
503 end;
504
505 --------------------------------------------------------------------------
506
507 procedure get (file: in out file_type;
508 col: in positive;
509 buf: out byte_string) is
510 m, n: natural;
511 begin
512 ensure_status (file);
513 ensure_col (file, col);
514 if buf'length < file.col_table (col).params.length
515 then
516 raise storage_error;
517 end if;
518
519 if file.rec_index > file.headings.row_count
520 then
521 raise use_error; -- true for input
522 end if;
523
524 seek_current (file);
525
526 m := file.col_table (col).offset + file.rec_buffer'first;
527 n := file.col_table (col).params.length - 1;
528 buf (buf'first..buf'first + n) := file.rec_buffer (m..m + n);
529 end;
530
531 --------------------------------------------------------------------------
532
533 procedure put (file: in out file_type;
534 col: in positive;
535 buf: in byte_string) is
536
537 offs, n: natural;
538
539 procedure clear (buf: in out byte_buffer; fill: in byte) is
540 begin
541 for n in buf'range
542 loop
543 buf (n) := fill;
544 end loop;
545 end;
546
547 begin
548 ensure_status (file);
549 except_mode (file, in_file);
550 ensure_col (file, col);
551
552 if buf'length < file.col_table (col).params.length
553 then
554 raise storage_error;
555 end if;
556
557 if file.rec_index > file.headings.row_count
558 then
559
560 update (file);
561 clear (file.rec_buffer, 32);
562 file.rec_attrib := 32;
563 file.rec_iopos := 0;
564
565 write (file, file.rec_buffer.all, file.rec_attrib);
566
567 file.rec_index := file.rec_index - 1;
568 file.rec_iopos := file.rec_index;
569
570 end if;
571
572 seek_current (file);
573
574 offs := file.col_table (col).offset + file.rec_buffer'first;
575 n := file.col_table (col).params.length - 1;
576
577 file.rec_buffer (offs..offs + n) := buf (buf'first..buf'first + n);
578 file.rec_changed := true;
579 file.headings.tab_updated := clock;
580 end;
581
582 --------------------------------------------------------------------------
583
584 procedure write (file: in out file_type;
585 buff: in byte_string;
586 attr: in row_attribute) is
587 begin
588 ensure_status (file);
589 except_mode (file, in_file);
590 if buff'length < file.rec_buffer'length
591 then
592 raise storage_error;
593 end if;
594 if file.rec_index = file.rec_iopos
595 then
596 file.rec_buffer.all := buff (buff'first..buff'first +
597 file.rec_buffer'length - 1);
598 file.rec_attrib := attr;
599 file.rec_changed := true;
600 file.headings.tab_updated := clock;
601 else
602 update (file);
603 write_record (file.uio_file,
604 file.headings,
605 buff (buff'first..buff'first +
606 file.rec_buffer'length - 1),
607 attr, file.rec_index);
608 if file.rec_index > file.headings.row_count
609 then
610 file.headings.row_count := file.rec_index;
611 end if;
612 end if;
613 file.rec_index := file.rec_index + 1;
614 file.tab_changed := true;
615 file.headings.tab_updated := clock;
616 end;
617
618 --------------------------------------------------------------------------
619
620 procedure read (file: in out file_type;
621 buff: out byte_string;
622 attr: out row_attribute) is
623 begin
624 ensure_status (file);
625 if buff'length < file.rec_buffer'length
626 then
627 raise storage_error;
628 end if;
629 if file.rec_index = file.rec_iopos
630 then
631 buff (buff'first..buff'first +
632 file.rec_buffer'length - 1) := file.rec_buffer.all;
633 attr := file.rec_attrib;
634 else
635 update (file);
636 read_record (file.uio_file, file.headings,
637 buff (buff'first..buff'first +
638 file.rec_buffer'length - 1),
639 attr, file.rec_index);
640 file.rec_iopos := file.rec_index;
641 file.rec_index := file.rec_index + 1;
642 end if;
643 end;
644
645 --------------------------------------------------------------------------
646
647 procedure open (file : in out file_type;
648 mode : in file_mode;
649 name : in string;
650 form : in string := "") is
651 tab: col_desc_table (1..tab_desc_length);
652 use uio;
653 begin
654 file := new file_object;
655 open (file.uio_file, uio.file_mode (mode), name, form);
656 read_info (file.uio_file, file.headings, tab);
657 ensure_data (file);
658 file.col_table := new col_desc_table'(tab (1..file.headings.col_count));
659 file.rec_buffer := new byte_string (1..file.headings.row_length);
660 file.rec_changed := false;
661 file.tab_changed := false;
662 file.rec_index := 1;
663 file.rec_iopos := 0;
664 exception
665 when others => release (file);
666 raise;
667 end;
668
669 --------------------------------------------------------------------------
670
671 procedure create (file : in out file_type;
672 cols : in table;
673 attr : in tab_attribute;
674 name : in string := "";
675 form : in string := "") is
676 use uio;
677 len: long_integer;
678 begin
679 if cols'length = 0
680 then
681 raise use_error;
682 end if;
683 file := new file_object;
684 uio.create (file.uio_file, inout_file, name, form);
685
686 file.col_table := new col_desc_table (1..cols'length);
687
688 len := 0;
689 begin
690
691 for i in file.col_table'range
692 loop
693 file.col_table (i).params := cols (cols'first + i - 1);
694 file.col_table (i).length := 0;
695 file.col_table (i).offset := natural (len);
696
697 len := len + long_integer (file.col_table (i).params.length);
698 if len > long_integer (natural'last)
699 then
700 raise data_error;
701 end if;
702 end loop;
703
704 file.headings.row_length := natural (len);
705 file.headings.tab_attrib := attr;
706 file.headings.tab_updated := clock;
707 file.headings.row_count := 0;
708 file.headings.col_count := cols'length;
709
710 exception
711 when others => raise data_error;
712 end;
713
714 write_info (file.uio_file, file.headings, file.col_table.all);
715
716 file.rec_buffer := new byte_string (1..file.headings.row_length);
717 file.rec_changed := false;
718 file.tab_changed := false;
719 file.rec_index := 1;
720 file.rec_iopos := 0;
721
722 exception
723 when others => release (file);
724 raise;
725 end;
726
727 end db_file_io;
728