File: dbf\dbase_io.adb
1 --::::::::::
2 --dbase_io.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 with unsigned, calendar, db_file_io, text_io;
12 use unsigned, calendar;
13
14 package body dbase_io is
15
16 package dbio renames db_file_io;
17
18 tab_attr: constant dbio.tab_attribute := 3;
19
20 procedure pad (temp: out string; item: in natural) is
21 numb: natural := item;
22 begin
23 for n in reverse temp'range
24 loop
25 if numb > 0
26 then
27 temp (n) := character'val(character'pos('0') + numb mod 10);
28 numb := numb / 10;
29 else
30 temp (n) := '0';
31 end if;
32 end loop;
33 end;
34 --------------------------------------------------------------------------
35
36 function convert (attr: col_attribute) return dbio.col_attribute is
37 begin
38 case attr is
39 when db_character => return dbio.col_attribute (67);
40 when db_date => return dbio.col_attribute (68);
41 when db_boolean => return dbio.col_attribute (76);
42 when db_memo => return dbio.col_attribute (77);
43 when db_numeric => return dbio.col_attribute (78);
44 when others => raise col_data_error;
45 end case;
46 end;
47
48 --------------------------------------------------------------------------
49
50 function convert (attr: dbio.col_attribute) return col_attribute is
51 begin
52 case attr is
53 when 67 => return db_character;
54 when 68 => return db_date;
55 when 76 => return db_boolean;
56 when 77 => return db_memo;
57 when 78 | 70 => return db_numeric;
58 when others => return db_unknown;
59 end case;
60 end;
61
62 --------------------------------------------------------------------------
63
64 procedure convert (to: in out col_stat; from: in dbio.col_stat) is
65 begin
66 to.attrib := convert (from.attrib);
67 case to.attrib is
68 when db_date => to.length := 8; to.align := 0;
69 when db_boolean => to.length := 1; to.align := 0;
70 when db_unknown => to.length := 0; to.align := 0;
71 when others => to.length := from.length;
72 to.align := from.align;
73 end case;
74 end;
75
76 --------------------------------------------------------------------------
77
78 procedure convert (to: in out dbio.col_stat; from: in col_stat) is
79 begin
80 to.attrib := convert (from.attrib);
81 case from.attrib is
82 when db_date => to.length := 8; to.align := 0;
83 when db_boolean => to.length := 1; to.align := 0;
84 when others => to.length := from.length;
85 to.align := from.align;
86 end case;
87 end;
88
89 --------------------------------------------------------------------------
90
91 function convert (attr: row_attribute) return dbio.row_attribute is
92 begin
93 case attr is
94 when true => return dbio.row_attribute (32);
95 when false => return dbio.row_attribute (42);
96 when others => raise row_data_error;
97 end case;
98 end;
99
100 --------------------------------------------------------------------------
101
102 function convert (attr: dbio.row_attribute) return row_attribute is
103 begin
104 case attr is
105 when 32 => return true;
106 when 42 => return false;
107 when others => raise row_data_error;
108 end case;
109 end;
110
111 --------------------------------------------------------------------------
112
113 function convert (bool: byte) return boolean is
114 begin
115 case bool is
116 when 121 | 89 |
117 116 | 84 |
118 49 => return true;
119 when 110 | 78 |
120 102 | 70 |
121 48 => return false;
122 when others => raise col_data_error;
123 end case;
124 end;
125
126 --------------------------------------------------------------------------
127
128 function convert (bool: boolean) return byte is
129 begin
130 case bool is
131 when true => return 89;
132 when false => return 78;
133 end case;
134 end;
135
136
137 --------------------------------------------------------------------------
138
139 package body table_io is
140
141 procedure ensure_status (file: in file_type) is
142 begin
143 if not is_open (file)
144 then
145 raise dbio.status_error;
146 end if;
147 end;
148
149 -----------------------------------------------------------------------
150
151 procedure ensure_type (file: in file_type;
152 name: in identify;
153 attr: in col_attribute) is
154 begin
155 if col_attrib (file, name) = attr
156 then
157 return;
158 end if;
159 raise col_data_error;
160 end;
161
162 -----------------------------------------------------------------------
163
164 function convert (tab: in table) return dbio.table is
165 tmp: dbio.table (1..tab'length);
166 len: natural := 0;
167 begin
168 for name in tab'range
169 loop
170 if tab (name).attrib /= db_unknown
171 then
172 len := len + 1;
173 convert (tmp (len), tab (name));
174 end if;
175 end loop;
176 return tmp (1..len);
177 exception
178 when others => raise tab_data_error;
179 end;
180
181 -----------------------------------------------------------------------
182
183 procedure get_table (file : in file_type;
184 tab : in out table) is
185
186 tmp: dbio.col_stat;
187
188 begin
189 ensure_status (file);
190 for name in tab'range
191 loop
192 if file.where (name) > 0
193 then
194 tmp.attrib := dbio.col_attrib (file.file, file.where (name));
195 tmp.length := dbio.col_length (file.file, file.where (name));
196 tmp.align := dbio.col_align (file.file, file.where (name));
197 convert (tab (name), tmp);
198 else
199 tab (name).attrib := db_unknown;
200 tab (name).length := 0;
201 tab (name).align := 0;
202 end if;
203 end loop;
204 end get_table;
205
206 -----------------------------------------------------------------------
207
208 procedure except_mode (file: in file_type; which: in file_mode) is
209 begin
210 if mode (file) = which
211 then
212 raise dbio.mode_error;
213 end if;
214 end;
215
216 -----------------------------------------------------------------------
217
218 procedure close (file : in out file_type) is
219 begin
220 dbio.close (file.file);
221 end close;
222
223 -----------------------------------------------------------------------
224
225 procedure reset (file : in out file_type) is
226 begin
227 dbio.reset (file.file);
228 end reset;
229
230 -----------------------------------------------------------------------
231
232 procedure reset (file : in out file_type;
233 mode : in file_mode) is
234 begin
235 dbio.reset (file.file, dbio.file_mode (mode));
236 end reset;
237
238 -----------------------------------------------------------------------
239
240 function mode (file : in file_type) return file_mode is
241 begin
242 return file_mode (dbio.mode (file.file));
243 end mode;
244
245 -----------------------------------------------------------------------
246
247 function name (file : in file_type) return string is
248 begin
249 return dbio.name (file.file);
250 end name;
251
252 -----------------------------------------------------------------------
253
254 function form (file : in file_type) return string is
255 begin
256 return dbio.form (file.file);
257 end form;
258
259 -----------------------------------------------------------------------
260
261 function is_open (file : in file_type) return boolean is
262 begin
263 return dbio.is_open (file.file);
264 end is_open;
265
266 -----------------------------------------------------------------------
267
268 function tab_length (file: in file_type) return count is
269 begin
270 return count (dbio.tab_length (file.file));
271 end tab_length;
272
273 -----------------------------------------------------------------------
274
275 function tab_updated (file : in file_type) return time is
276 begin
277 return dbio.tab_updated (file.file);
278 end tab_updated;
279
280 -----------------------------------------------------------------------
281
282 procedure row_attrib (file : in out file_type;
283 new_attr : in row_attribute) is
284 begin
285 ensure_status (file);
286 except_mode (file, in_file);
287 dbio.row_attrib (file.file, convert (new_attr));
288 end row_attrib;
289
290 -----------------------------------------------------------------------
291
292 function row_attrib (file : in file_type) return row_attribute is
293 begin
294 return convert (dbio.row_attrib (file.file));
295 end row_attrib;
296
297 -----------------------------------------------------------------------
298
299 procedure row_index (file : in out file_type;
300 to : in positive_count) is
301 begin
302 dbio.row_index (file.file, dbio.positive_count(to));
303 end row_index;
304
305 -----------------------------------------------------------------------
306
307 function row_index (file : in file_type) return positive_count is
308 begin
309 return positive_count (dbio.row_index (file.file));
310 end row_index;
311
312 -----------------------------------------------------------------------
313
314 procedure col_align (file : in out file_type;
315 name : in identify;
316 new_align : in natural) is
317 begin
318 if col_exist (file, name)
319 then
320 except_mode (file, in_file);
321 dbio.col_align (file.file, file.where (name), new_align);
322 else
323 raise col_data_error;
324 end if;
325 end col_align;
326
327 -----------------------------------------------------------------------
328
329 procedure col_attrib (file : in out file_type;
330 name : in identify;
331 new_attr : in col_attribute) is
332 begin
333 if col_exist (file, name)
334 then
335 except_mode (file, in_file);
336 dbio.col_attrib (file.file, file.where (name), convert(new_attr));
337 else
338 raise col_data_error;
339 end if;
340 end col_attrib;
341
342 -----------------------------------------------------------------------
343
344 function col_index (file: in file_type;
345 from: in identify) return natural is
346 begin
347 ensure_status (file);
348 return file.where (from);
349 end;
350
351 -----------------------------------------------------------------------
352
353 function col_count (file: in file_type) return positive is
354 begin
355 ensure_status (file);
356 return dbio.col_count (file.file);
357 end;
358
359 -----------------------------------------------------------------------
360
361 function col_align (file : in file_type;
362 from : in identify) return natural is
363 begin
364 if col_exist (file, from)
365 then
366 return dbio.col_align (file.file, file.where (from));
367 else
368 raise col_data_error;
369 end if;
370 return 0;
371 end col_align;
372
373 -----------------------------------------------------------------------
374
375 function col_attrib (file : in file_type;
376 from : in identify) return col_attribute is
377 begin
378 if col_exist (file, from)
379 then
380 return convert (dbio.col_attrib (file.file, file.where (from)));
381 else
382 return db_unknown;
383 end if;
384 end col_attrib;
385
386 -----------------------------------------------------------------------
387
388 function col_length (file : in file_type;
389 from : in identify) return natural is
390 begin
391 if col_exist (file, from)
392 then
393 return dbio.col_length (file.file, file.where (from));
394 else
395 raise col_data_error;
396 end if;
397 end col_length;
398
399 -----------------------------------------------------------------------
400
401 function col_exist (file: in file_type;
402 name: in identify) return boolean is
403 begin
404 ensure_status (file);
405 return file.where (name) in 1..dbio.col_count (file.file);
406 end;
407
408 -----------------------------------------------------------------------
409
410 procedure create(file : in out file_type;
411 cols : in table;
412 name : in string := "";
413 form : in string := "") is
414 pos: natural := 0;
415 begin
416 dbio.create (file.file, convert (cols), tab_attr, name, form);
417 for name in identify
418 loop
419 if cols (name).attrib /= db_unknown
420 then
421 pos := pos + 1;
422 file.where (name) := pos;
423 dbio.col_name (file.file, pos, identify'image (name));
424 else
425 file.where (name) := 0;
426 end if;
427 end loop;
428 exception
429 when others => if dbio.is_open (file.file)
430 then
431 dbio.close (file.file);
432 end if;
433 raise;
434 end create;
435
436 -----------------------------------------------------------------------
437
438 procedure open (file : in out file_type;
439 mode : in file_mode;
440 name : in string;
441 form : in string := "") is
442 use db_file_io;
443 begin
444 dbio.open (file.file, dbio.file_mode (mode), name, form);
445 if dbio.tab_attrib (file.file) = tab_attr
446 then
447 for name in identify
448 loop
449 file.where (name) := dbio.col_index (file.file,
450 identify'image (name));
451 end loop;
452 else
453 raise data_error;
454 end if;
455 exception
456 when others => if dbio.is_open (file.file)
457 then
458 dbio.close (file.file);
459 end if;
460 raise;
461 end open;
462
463 -----------------------------------------------------------------------
464
465 procedure get (file: in out file_type;
466 name: in identify;
467 item: out byte_string) is
468 begin
469 if col_exist (file, name)
470 then
471 dbio.get (file.file, file.where (name), item);
472 else
473 raise col_data_error;
474 end if;
475 end get;
476
477
478 -----------------------------------------------------------------------
479
480 procedure put (file: in out file_type;
481 name: in identify;
482 item: in byte_string) is
483 begin
484 if col_exist (file, name)
485 then
486 except_mode (file, in_file);
487 dbio.put (file.file, file.where (name), item);
488 else
489 raise col_data_error;
490 end if;
491 end put;
492
493 -----------------------------------------------------------------------
494
495 procedure get (file: in out file_type;
496 name: in identify;
497 item: out string) is
498 begin
499 if col_length (file, name) > item'length
500 then
501 raise storage_error;
502 end if;
503 declare
504 temp: byte_string (1..col_length (file, name));
505 begin
506 get (file, name, temp);
507 if temp'length = item'length
508 then
509 item := value (temp);
510 else
511 item (1..temp'length) := value (temp);
512 for ws in temp'length + 1..item'last
513 loop
514 item (ws) := ' ';
515 end loop;
516 end if;
517 end;
518 end;
519
520 -----------------------------------------------------------------------
521
522 procedure put (file: in out file_type;
523 name: in identify;
524 item: in string) is
525 begin
526 except_mode (file, in_file);
527 if col_length (file, name) < item'length
528 then
529 raise storage_error;
530 end if;
531
532 declare
533 temp: byte_string (1..col_length (file, name));
534 begin
535 if temp'length = item'length
536 then
537 temp := value (item);
538 else
539 temp (1..item'length) := value (item);
540 for ws in item'length + 1..temp'last
541 loop
542 temp (ws) := 32;
543 end loop;
544 end if;
545 put (file, name, temp);
546 end;
547 end;
548
549 -----------------------------------------------------------------------
550
551 procedure get (file: in out file_type;
552 name: in identify;
553 item: out boolean) is
554 begin
555 ensure_type (file, name, db_boolean);
556 declare
557 temp: byte_string (1..col_length (file, name));
558 begin
559 get (file, name, temp);
560 item := convert (temp (1));
561 end;
562 end;
563
564 -----------------------------------------------------------------------
565
566 procedure put (file: in out file_type;
567 name: in identify;
568 item: in boolean) is
569 begin
570 ensure_type (file, name, db_boolean);
571 except_mode (file, in_file);
572 declare
573 temp: byte_string (1..col_length (file, name));
574 begin
575 get (file, name, temp);
576 temp (1) := convert (item);
577 put (file, name, temp);
578 end;
579 end;
580
581 -----------------------------------------------------------------------
582
583 procedure get (file: in out file_type;
584 name: in identify;
585 item: out time) is
586 begin
587 ensure_type (file, name, db_date);
588 declare
589 yr: year_number;
590 mn: month_number;
591 dy: day_number;
592
593 temp: string (1..8);
594 begin
595 get (file, name, temp);
596
597 begin
598 yr := year_number'value (temp (1..4));
599 mn := month_number'value (temp (5..6));
600 dy := day_number'value (temp (7..8));
601 item := time_of (yr, mn, dy);
602 exception
603 when others => raise col_data_error;
604 end;
605 end;
606 end;
607
608 -----------------------------------------------------------------------
609
610 procedure put (file: in out file_type;
611 name: in identify;
612 item: in time) is
613 begin
614 ensure_type (file, name, db_date);
615 declare
616 yr: year_number;
617 mn: month_number;
618 dy: day_number;
619 sc: day_duration;
620
621 temp: string (1..8);
622 begin
623 split (item, yr, mn, dy, sc);
624
625 pad (temp (1..4), yr);
626 pad (temp (5..6), mn);
627 pad (temp (7..8), dy);
628
629 put (file, name, temp);
630
631 end;
632 end;
633
634 -----------------------------------------------------------------------
635
636 package body integer_io is
637
638 package num_io is new text_io.integer_io (num);
639
640 procedure get (file : in out file_type;
641 name : in identify;
642 item : out num) is
643 begin
644 ensure_type (file, name, db_numeric);
645
646 declare
647 temp: string (1..col_length (file, name));
648 last: positive;
649 begin
650 get (file, name, temp);
651 num_io.get (temp, item, last);
652 end;
653 end get;
654
655 procedure put (file : in out file_type;
656 name : in identify;
657 item : in num) is
658 begin
659 ensure_type (file, name, db_numeric);
660 except_mode (file, in_file);
661
662 declare
663 temp: string (1..col_length (file, name));
664 begin
665 num_io.put (temp, item, base => 10);
666 put (file, name, temp);
667 end;
668 end put;
669
670 end integer_io;
671
672 -----------------------------------------------------------------------
673
674 package body fixed_io is
675
676 package num_io is new text_io.fixed_io (num);
677
678 procedure get (file : in out file_type;
679 name : in identify;
680 item : out num) is
681 begin
682 ensure_type (file, name, db_numeric);
683
684 declare
685 temp: string (1..col_length (file, name));
686 last: positive;
687 begin
688 get (file, name, temp);
689 num_io.get (temp, item, last);
690 end;
691 end get;
692
693 procedure put (file : in out file_type;
694 name : in identify;
695 item : in num) is
696 begin
697 ensure_type (file, name, db_numeric);
698 except_mode (file, in_file);
699
700 declare
701 temp: string (1..col_length (file, name));
702 begin
703 num_io.put (temp, item, aft => col_align (file, name));
704 put (file, name, temp);
705 end;
706 end put;
707
708 end fixed_io;
709
710 -----------------------------------------------------------------------
711
712 package body enumeration_io is
713
714 package enum_io is new text_io.enumeration_io (enum);
715
716 procedure get (file : in out file_type;
717 name : in identify;
718 item : out enum) is
719 begin
720 ensure_type (file, name, db_character);
721 declare
722 temp: string (1..col_length (file, name));
723 last: positive;
724 begin
725 get (file, name, temp);
726 enum_io.get (temp, item, last);
727 end;
728 end get;
729
730 procedure put (file : in out file_type;
731 name : in identify;
732 item : in enum) is
733 begin
734 ensure_type (file, name, db_character);
735 except_mode (file, in_file);
736
737 declare
738 temp: string (1..col_length (file, name));
739 begin
740 enum_io.put (temp, item);
741 put (file, name, temp);
742 end;
743 end put;
744 end enumeration_io;
745
746 end table_io;
747
748 end dbase_io;
749