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