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