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