home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / liststr2.zip / LISTSTRU.PAS < prev   
Pascal/Delphi Source File  |  1987-02-21  |  11KB  |  255 lines
  1. {  Name      : LISTSTRU.PAS
  2.    Version   : 1.0
  3.                2.0  -- with new SCS address
  4.    Created   : 07/25/1985
  5.    Revised   : 02/20/1987
  6.    Compiler  : Turbo Pascal V 3.01a
  7.    Includes  : none
  8.    Function  : lists structure of dBASE III database file
  9.    Notes     : use redirection for output to file or printer
  10.    Changes   :
  11.    Additions :
  12.    Usage     : LISTSTRU Filename.DBF > output file
  13.    Notes     : 02/20/1987 -- this is a really old file but it works.  There
  14.                              are newer versions (in 'C') but Pascal
  15.                              illustrates the structure of the header better.
  16. }
  17.  
  18.  
  19. {$G512,P512,D-}  (* enable redirection                             *)
  20. {$U+}            (* supposed to be able to interrupt but you can't *)
  21. program LISTSTRU(input,output);
  22.  
  23.   type
  24.       FileNameType    = string[64];     { 64 chars allows full path  }
  25.       String255       = string[255];
  26.       String10        = string[10];
  27.   var
  28.       x               : integer;
  29.       ch              : char;
  30.       hold            : string[5];      { temporary string           }
  31.       last_update     : string10;       { last update date           }
  32.       recs_in_file    : real;           { records in file            }
  33.       bytes_in_header : real;           { number of bytes in header  }
  34.       bytes_in_record : real;           { number of bytes in record  }
  35.       bytes_read      : integer;        { bytes read from .DBF file  }
  36.       f_name          : string[10];     { field name                 }
  37.       f_type          : char;           { field type                 }
  38.       f_len           : char;           { field length               }
  39.       f_dec           : char;           { field decimal places       }
  40.       f_num           : integer;        { field number for display   }
  41.       in_file         : text;           { input file                 }
  42.  
  43. {***************************************************************************}
  44. { get_last_update -- gets date of last database update and puts the result  }
  45. {                    into last_update variable                              }
  46. {***************************************************************************}
  47. procedure get_last_update;
  48.   var
  49.      yr,
  50.      mon,
  51.      day  : string[2];
  52.   begin
  53.      for x := 1 to 3 do
  54.          read(in_file,hold[x]);
  55.      str(ord(hold[1]):2,yr);         { convert bytes to string representation }
  56.      str(ord(hold[2]):2,mon);
  57.      str(ord(hold[3]):2,day);
  58.  
  59.      if mon[1] = ' ' then            { replace any leading space with 0 }
  60.         mon[1] := '0';
  61.      if day[1] = ' ' then
  62.         day[1] := '0';
  63.      last_update := mon + '-' + day + '-19' + yr;
  64.   end;
  65.  
  66. {****************************************************************************}
  67. { get_recs_in_file -- gets the number of records in a file and stores result }
  68. {                     in recs_in_file variable                               }
  69. {***************************************************************************}
  70. procedure get_recs_in_file;
  71.   begin
  72.      for x := 1 to 4 do
  73.          read(in_file,hold[x]);
  74.      recs_in_file := ord(hold[1]) +
  75.                      ord(hold[2]) shl 8               + { shift left   8 }
  76.                      ord(hold[3]) * (256 * 256)       + { shift left  16 }
  77.                      ord(hold[4]) * (256 * 256 * 256);  { shift left  24 }
  78.   end;
  79.  
  80. {***************************************************************************}
  81. { get_bytes_in_header -- gets number of bytes in the file header and stores }
  82. {                        the result in bytes_in_header variable             }
  83. {***************************************************************************}
  84. procedure get_bytes_in_header;
  85.   begin
  86.     read(in_file,hold[1]);
  87.     read(in_file,hold[2]);
  88.     bytes_in_header := ord(hold[1]) +
  89.                        ord(hold[2]) shl 8;
  90.   end;
  91.  
  92. {***************************************************************************}
  93. { get_bytes_in_record -- gets the number of bytes in each record and puts   }
  94. {                        the result in bytes_in_record variable             }
  95. {***************************************************************************}
  96. procedure get_bytes_in_record;
  97.   begin
  98.     read(in_file,hold[1]);
  99.     read(in_file,hold[2]);
  100.     bytes_in_record := ord(hold[1]) + ord(hold[2]) shl 8;
  101.   end;
  102.  
  103. {***************************************************************************}
  104. { skip_bytes -- reads bytes_to_skip bytes from the input file, used to skip }
  105. {               various non-essential parts of the DBF header               }
  106. {***************************************************************************}
  107. procedure skip_bytes(bytes_to_skip : integer);
  108.   begin
  109.     for x := 1 to bytes_to_skip do
  110.         read(in_file,ch);
  111.   end;
  112.  
  113. {****************************************************************************}
  114. { exist : returns TRUE if FileN exists else returns FALSE                    }
  115. {****************************************************************************}
  116. function Exist(FileN: FileNameType): boolean;
  117.    var F: file;
  118.    begin
  119.       {$I-}
  120.       assign(F,FileN);
  121.       reset(F);
  122.       {$I+}
  123.       if IOResult <> 0 then Exist := FALSE
  124.       else Exist := TRUE;
  125.    end;
  126.  
  127. {***************************************************************************}
  128. { usage -- displays err_mes and usage information then halts program        }
  129. {***************************************************************************}
  130. procedure usage(err_mes : String255);
  131.   begin
  132.     clrscr;
  133.     writeln;
  134.     writeln('LISTSTRU -- list the structure of a dBASE III database file');
  135.     writeln('            from the operating system.  Output can be redirected');
  136.     writeln('            to any device or used in pipes.');
  137.     writeln;
  138.     writeln('            Copyright 07-25-1985, 02-20-87 (yes we''re still here)');
  139.     writeln('            steiner computer services');
  140.     writeln('            94 forrest street');
  141.     writeln('            plaistow, NH 03865');
  142.     writeln('            603-382-1313');
  143.     writeln('            Write to the address above for a list of commercial dBASE');
  144.     writeln('            utilities available from steiner computer services');
  145.     writeln;
  146.     writeln('            This program is for non-commercial use only, may be freely copied');
  147.     writeln('            for personal use only, no guarantees etc. (you''ve read it before)');
  148.     writeln;
  149.     writeln(' Usage    : LISTSTRU In_file.DBF > output.fil');
  150.     writeln('            output may be redirected to any device or used in pipes');
  151.     writeln;
  152.     writeln(' Error    : ',err_mes);
  153.     halt(1);  { set ERRORLEVEL to 1 for system interrogation }
  154.   end;
  155.  
  156. {****************************************************************************}
  157. { space -- returns x spaces ala dBASE III space() function                   }
  158. {****************************************************************************}
  159. function space(x : integer) : String255;
  160.   var
  161.      y    : integer;
  162.      temp : String255;
  163.   begin
  164.     temp := '';
  165.     for y := 1 to x do begin
  166.        temp := temp + ' ';
  167.     end;
  168.     space := temp;
  169.   end;
  170.  
  171. {****************************************************************************}
  172. { f_trunc -- truncate the function name at the first 00 byte                 }
  173. {****************************************************************************}
  174.  
  175. procedure f_trunc(var name : string10);
  176.   var
  177.      zero_pos,
  178.      x        : integer;
  179.   begin
  180.      zero_pos := pos(chr(00),name);
  181.      if zero_pos <> 0 then
  182.         for x := zero_pos to 10 do
  183.             name[x] := ' ';
  184.   end;
  185.  
  186. {****************************************************************************}
  187. {                             main routine                                   }
  188. {****************************************************************************}
  189. begin
  190.   if paramstr(1) = '' then begin             { input file name entered ?  }
  191.      usage('No input file specified ');end
  192.   else if not(exist(paramstr(1))) then begin { does the file exist ?      }
  193.      usage('File not found -- '+ paramstr(1));end
  194.   else begin                                 { yes then open it for input }
  195.      assign(in_file,paramstr(1));
  196.      reset(in_file);
  197.   end;
  198.  
  199.   { grab the information pertaining to the header and dbf statistics      }
  200.   read(in_file,ch);                          { version number             }
  201.  
  202.   get_last_update;                           { get the rest of the stuff  }
  203.   get_recs_in_file;
  204.   get_bytes_in_header;
  205.   get_bytes_in_record;
  206.   skip_bytes(20);                            { skip the reserved bytes    }
  207.  
  208.   { write out the 'header header' }
  209.   writeln;
  210.   writeln('Structure for database : ', paramstr(1));
  211.   writeln('Number of data records : ', recs_in_file:10:0);
  212.   writeln('Date of last update    : ', last_update);
  213.   writeln('Field  Field name  Type       Width    Dec');
  214.   writeln('-----  ----------  ----       -----    ---');
  215.   bytes_read := 35;                 { insures that bytes_read will exceed
  216.                                       bytes_in_header when the last field
  217.                                       is read }
  218.   f_num      := 1;
  219.   while bytes_read < bytes_in_header do begin
  220.       f_name := space(10);          { blank the field information variables   }
  221.       f_type := space(1);
  222.       f_len  := space(1);
  223.       f_dec  := space(1);
  224.  
  225.       for x := 1 to 11 do           { field name -- supposed to be 00 filled }
  226.           read(in_file,f_name[x]);  { but occasionally contains chars after  }
  227.                                     { the first 00 byte, f_trunc removes all }
  228.                                     { chars from f_name following first 00   }
  229.       f_trunc(f_name);
  230.       read(in_file,f_type);         { field type                             }
  231.       skip_bytes(4);                { skip field data address                }
  232.       read(in_file,f_len);          { field length in binary                 }
  233.       read(in_file,f_dec);          { field decimal places in binary         }
  234.       skip_bytes(14);               { reserved bytes in the field descriptor }
  235.  
  236.       write(f_num:5,'  ');          { field number }
  237.       write(f_name,'  ');
  238.       case f_type of                { convert the C,N,L,D,M to name of type  }
  239.            'C' : write('Character   ');
  240.            'N' : write('Numeric     ');
  241.            'L' : write('Logical     ');
  242.            'D' : write('Date        ');
  243.            'M' : write('Memo        ');
  244.       end;
  245.       write(ord(f_len):4);
  246.       if f_type = 'N' then           { decimal places for numeric fields     }
  247.          write(ord(f_dec):7);
  248.       writeln;
  249.       bytes_read := bytes_read + 32; { 32 bytes per descriptor  }
  250.       f_num := f_num + 1;            { f_num is the field number }
  251.   end;
  252.   writeln('** Total **                  ',bytes_in_record:6:0);
  253. end.
  254.  
  255.