File: dbf\db_file_io-db_format_specific.adb
1 --::::::::::
2 --dfidfosp.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 -- 1) время изменения обязано иметь точность до долей секунды.
13 -- (кое-какие данные можно положить сразу после описания полей).
14 -- 2) ширина поля может быть больше 256 байт.
15 -- 3) буквенное имя поля может быть больше 11 байт, но не более ??.
16 -- 4) use_error и end_error при чтении-записи row
17 -- 5) data_error при чтении заголовка и описания полей
18
19 separate (db_file_io)
20 package body db_format_specific is
21
22 use unsigned_io, unsigned;
23
24 dbf_base_year: constant := 1900;
25 dbf_base_month: constant := 0;
26 dbf_base_day: constant := 0;
27 dbf_header_pos: constant := 1;
28
29 type dbf_header is
30 record
31 version : byte;
32 year : byte;
33 month : byte;
34 day : byte;
35 num_records : long_word_bytes;
36 header_length : word_bytes;
37 record_length : word_bytes;
38 reserved : byte_string (1 .. 20);
39 end record;
40
41 type dbf_column is
42 record
43 name : byte_string (1 .. 11);
44 attr : byte;
45 pointer : long_word_bytes;
46 length : byte;
47 align : byte;
48 reserved : byte_string (1 .. 14);
49 end record;
50
51 procedure write_dbf_column is new write_bytes (dbf_column);
52 procedure write_dbf_header is new write_bytes (dbf_header);
53 procedure read_dbf_column is new read_bytes (dbf_column);
54 procedure read_dbf_header is new read_bytes (dbf_header);
55
56 function convert (name: byte_string) return string is
57 begin
58 return value (name);
59 end;
60
61 function convert (name: string) return byte_string is
62 begin
63 return value (name);
64 end;
65
66 procedure read_header (file: in out file_type; header: in out file_header) is
67 file_header: dbf_header;
68 len: word;
69 begin
70 set_index (file, dbf_header_pos);
71 read_dbf_header (file, file_header);
72 header.tab_attrib := tab_attribute (file_header.version);
73 len := value (file_header.header_length);
74 header.col_begins := uio.count (dbf_header'size/byte'size + 1);
75 header.col_count := natural (len - word (dbf_header'size/byte'size))
76 / natural (dbf_column'size/byte'size);
77 header.row_begins := uio.count (len + 1);
78 header.row_posinc := uio.count (word'(value (file_header.record_length)));
79 header.row_length := natural (header.row_posinc - 1);
80 header.row_count := count (long_word'(value (file_header.num_records )));
81 header.col_namelen := 11;
82 header.tab_updated :=
83 time_of (year_number (integer(file_header.year) + dbf_base_year),
84 month_number (integer(file_header.month) + dbf_base_month),
85 day_number (integer(file_header.day) + dbf_base_day));
86 end;
87
88 procedure read_desc (file: in out file_type;
89 desc: in out col_description;
90 end_of_cols: out boolean) is
91 col: dbf_column;
92 begin
93 read_dbf_column (file, col);
94 if col.name (1) /= 16#0d#
95 then
96 end_of_cols := false;
97 set_name (desc, convert (col.name));
98 desc.params.align := natural (col.align);
99 desc.params.length := natural (col.length);
100 desc.params.attrib := col_attribute (col.attr);
101 else
102 end_of_cols := true;
103 end if;
104 exception
105 when others => raise;
106 end;
107
108 procedure write_header (file: in out file_type; header: in file_header) is
109 year: year_number;
110 month: month_number;
111 day: day_number;
112 secs: day_duration;
113 file_header: dbf_header;
114 begin
115 split (header.tab_updated, year, month, day, secs);
116 file_header.version := byte (header.tab_attrib);
117 file_header.year := byte (year - dbf_base_year);
118 file_header.month := byte (month - dbf_base_month);
119 file_header.day := byte (day - dbf_base_day);
120
121 file_header.header_length := value (word (header.row_begins - 1));
122 -- dbf_header'size / byte'size +
123 -- dbf_column'size / byte'size *
124 -- header.col_count;
125
126 file_header.record_length := value (word (header.row_posinc));
127 file_header.num_records := value (long_word (header.row_count));
128 file_header.reserved := (others => 0);
129
130 set_index (file, dbf_header_pos);
131 write_dbf_header (file, file_header);
132 end;
133
134 procedure write_desc (file: in out file_type; desc: in col_description) is
135 col: dbf_column;
136 procedure put_name (name: in byte_string) is
137 begin
138 col.name (1..name'length) := name;
139 col.name (name'length + 1..col.name'last) := (others => 0);
140 end;
141 begin
142 put_name (convert (desc.name (1..desc.length)));
143 col.attr := byte (desc.params.attrib);
144 col.length := byte (desc.params.length);
145 col.align := byte (desc.params.align);
146 col.pointer := (others => 0);
147 col.reserved := (others => 0);
148 write_dbf_column (file, col);
149 end;
150
151 procedure read_info (file: in out file_type;
152 header: in out file_header;
153 tab: in out col_desc_table) is
154 eof_cols: boolean := false;
155 len_cols: natural := 0;
156 col_offs: natural := 0;
157 begin
158 read_header (file, header);
159 if header.col_count > tab'length
160 then
161 raise storage_error;
162 end if;
163 set_index (file, header.col_begins);
164 for n in tab'range
165 loop
166 read_desc (file, tab (n), eof_cols);
167 tab (n).offset := col_offs;
168 exit when eof_cols or else n >= header.col_count;
169 col_offs := col_offs + tab(n).params.length;
170 len_cols := len_cols + 1;
171 end loop;
172
173 if len_cols < 1
174 then
175 raise data_error;
176 end if;
177
178 exception
179 when storage_error => raise;
180 when others => raise data_error;
181 end;
182
183 procedure write_info (file: in out file_type;
184 header: in out file_header;
185 tab: in col_desc_table) is
186 begin
187
188 header.row_posinc := unsigned_io.count (header.row_length + 1);
189 header.col_namelen := 11;
190 header.col_begins := 33;
191 header.row_begins := 32 * tab'length + 1 + header.col_begins;
192
193 write_header (file, header);
194 set_index (file, header.col_begins);
195 for n in tab'range
196 loop
197 write_desc (file, tab (n));
198 end loop;
199 write (file, 16#0d#);
200 set_index (file, size (file) + 1);
201 write (file, 16#1a#);
202 exception
203 when device_error => raise;
204 when others => raise data_error;
205 end;
206
207 procedure write_record (file: in out file_type;
208 header: in file_header;
209 buf: in byte_string;
210 attr: in row_attribute;
211 to: in positive_count) is
212 begin
213 set_index (file, header.row_posinc * unsigned_io.count(to - 1)
214 + header.row_begins);
215 write (file, byte (attr));
216 write (file, buf);
217 end;
218
219 procedure read_record (file: in out file_type;
220 header: in file_header;
221 buf: out byte_string;
222 attr: out row_attribute;
223 from: in positive_count) is
224 attrib: byte;
225 begin
226 set_index (file, header.row_posinc * unsigned_io.count(from - 1)
227 + header.row_begins);
228 read (file, attrib);
229 attr := row_attribute (attrib);
230 read (file, buf);
231 end;
232
233 end;
234