Power-Programmierung/CD1.mdf/pascal/library/dos/database/db3wp/db3wp.pas

Pascal/Delphi Source File | 1986-08-02 | 21.5 KB | 755 lines

program dBaseIIIToSPSS;

{ dBASE III (and +) file handling routines written by
  J. Troutman, Compuserve ID 74746,1567
  File DBF.PAS
  Version 1.1  }

{$V-}

type RegPack = record
               AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS : integer
               end;
     AnyStr = string[255];

const
  ProgramTitle = 'dBASE III --> WordPerfect Merge File Conversion Utility';
  DisClaimer1 = 'dBASE III and dBASE III Plus are registered trademarks of Ashton-Tate.';
  DisClaimer2 = 'WordPerfect is a registered trademark of WordPerfect Incorporated.';
  CopyRight =
          'Copyright (C) 1986 by William J. Bliss and Northwestern University';
  Version = 'Version 1.0, July 1986';

  DefaultWPExt = 'DAT';
  UpCaseOnly = true;

  FieldDelim = ^R#10;
  RecordDelim = ^E#10;

type
  DOSFileNameType = string[64];
  ValidSetType = set of char;

var
  ControlFile,DataFile : text[4096];
  DOSdBASEFile, DOSWPFile : DOSFileNameType;
  Default : AnyStr;
  DefLen : byte absolute Default;

  Choice : char;
  Trim : (Yes, No, Undefined);


{ Constants, type and variable declarations for dBASE conversion }


CONST
  DB3File = 3;
  DB3WithMemo = $83;
  ValidTypes : SET OF Char = ['C', 'N', 'L', 'M', 'D'];
  MAX_HEADER = 4129;          { = maximum length of dBASE III header }
  MAX_BYTES_IN_RECORD = 4000; { dBASE III record limit }
  MAX_FIELDS_IN_RECORD = 128; { dBASE III field limit  }
  BYTES_IN_MEMO_RECORD = 512; { dBASE III memo field record size }

TYPE
  HeaderType = ARRAY[0..MAX_HEADER] OF Byte;
  HeaderPrologType = ARRAY[0..31] OF Byte; { dBASE III header prolog }
  FieldDescType = ARRAY[0..31] OF Byte; { dBASE III field definitions }
  DbfRecord = ARRAY[0..MAX_BYTES_IN_RECORD] OF Byte; { the 0 offset represents
                                                       the 'deleted' flag.   }
  Str255 = STRING[255];
  Str80 = STRING[80];
  Str64 = STRING[64];
  Str10 = STRING[10];
  Str8 = STRING[8];
  Str2 = STRING[2];
  DbfFileType = FILE;
  FieldRecord = RECORD
                  Name : Str10;
                  Typ : Char;
                  Len : Byte;
                  Dec : Byte;
                  Off : Integer;
                END;
  FieldArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF FieldRecord;
  MemoRecord = ARRAY[1..BYTES_IN_MEMO_RECORD] OF Byte;
  MemoFileType = FILE OF MemoRecord;
  DbfInfoType = RECORD
                  FileName     : Str64;
                  dFile        : DbfFileType;
                  HeadProlog   : HeaderPrologType;
                  Updated      : Boolean;
                  WithMemo     : Boolean;
                  DateOfUpdate : Str8;
                  NumRecs      : Real;
                  HeadLen      : Integer;
                  RecLen       : Integer;
                  NumFields    : Integer;
                  Fields       : FieldArray;
                  CurRecord    : DbfRecord;
                END;


var
  InputFile : DbfInfoType;


procedure PaintLogo;

begin
  ClrScr;
  TextColor(LightBlue);
  writeln(ProgramTitle,', ',Version);
  writeln(CopyRight);
  writeln('All Rights Reserved.');
  TextColor(Yellow);
  writeln;
  writeln(Disclaimer1);
  writeln(Disclaimer2);
  writeln
end;


procedure GetChar(var ch : char);

var
  registers : RegPack;
  AL,AH: byte;

begin
  registers.AX:=$0000;
  Intr($16,registers);

  ch := chr(Lo(registers.AX))  { Low order byte of AX }
end;


procedure WaitFor(ValidSet : ValidSetType;
                  UpperOnly : boolean;
                  var Response : char);

begin
  repeat
    GetChar(Response)
  until (UpCase(Response) in ValidSet);
  if UpperOnly then
    write(UpCase(Response))
  else
    write(Response)
end;


function FileExist(var FileName : DOSFileNameType) : boolean;

var
  TempFile : file;

begin
  {$I-}
  assign(TempFile,FileName);
  reset(TempFile);
  {$I-}
  FileExist := (IOResult = 0)
end;


procedure OutputExists(var FileName : DOSFileNameType);

var
  TempFile : file;
  Response : char;

begin
  writeln('File ',FileName,' already exists.');
  write('Overwrite it or specify Another file (O/A)? ');
  WaitFor(['O','A'],UpCaseOnly,Response);
  writeln;

  case UpCase(Response) of

       'O' : begin
               assign(TempFile,FileName);
               erase(TempFile)
             end;

       'A' : FileName := '';

  end  { case }

end;


procedure GetInputFile(var FileName : DOSFileNameType);

var
  Continue : boolean;
  i : integer;

begin

  if not FileExist(FileName) then
    begin

      if FileName <> '' then
        begin
          writeln;
          writeln('File ',FileName,' not found.');
          writeln
        end;

      repeat
        write('File to convert (d:filename, .DBF assumed, RETURN to quit)? ');
        read(FileName);
        for i := 1 to Length(FileName) do
          FileName[i] := UpCase(FileName[i]);

        if (Pos('.',FileName) = 0) and (Length(FileName) > 0) then
          FileName := FileName + '.DBF';

        Continue := ((length(FileName) = 0) or FileExist(FileName));

        writeln;
        if not Continue then
          begin
            writeln;
            write('Cannot find file ',FileName,'.');
            writeln;
            writeln
          end

      until Continue

    end;  { if not FileExist(FileName) }

  writeln

end;


procedure GetOutputFile(var FileName : DOSFileNameType;
                            Default : AnyStr);

var
  Continue : boolean;
  Choice : char;
  Phrase : AnyStr;
  i : integer;

begin
  Phrase := 'WordPerfect merge';

  if FileName = DOSdBaseFile then
    begin
      writeln;
      write('ERROR: ');
      writeln('The output file cannot be the same as the input file.');
      writeln;
      FileName := ''
    end;

  if FileExist(FileName) then
    OutputExists(FileName);

  if FileName = '' then
    repeat
      write('Name of ',Phrase,' file (Default = ',Default,')? ');
      read(FileName);
      for i := 1 to Length(FileName) do
        FileName[i] := UpCase(FileName[i]);
      writeln;
      if FileName = '' then
        FileName := Default;

      if FileName = DOSdBaseFile then
        begin
          writeln;
          write('ERROR: ');
          writeln('An output file cannot be the same as the input file.');
          writeln;
          FileName := ''
        end;

      if FileExist(FileName) then
        OutputExists(FileName)

    until length(FileName) <> 0;

end;


(* The routines in this file present some fairly general purpose tools for
   accessing dBASE III and dBASE III Plus files from within a Turbo Pascal
   program.  There is much room for improvement: the error checking is
   rudimentary, no routines to access memo files, no buffering of data,
   no support for index files, etc.
   The main routines are:

      FUNCTION OpenDbf(VAR D : DbfInfoType;) : Integer;
      FUNCTION CloseDbf(VAR D : DbfInfoType) : Integer;
      PROCEDURE GetDbfRecord(VAR D : DbfInfoType; RecNum : Real);

      A skeletal program would go something like:
        BEGIN
        {...initialize and get filename of .dbf file into FileName field
            of DbfInfoType Record variable ...  }
        IF OpenDbf(...)  { to open the file              }
        {... the rest of your program including calls to
             GetDbfRecord as needed  }
        IF CloseDbf (...) { to close the file            }
        END.

      Upon exit from the GetDbfRecord Procedure, the CurRecord field of the
      DbfInfoType variable contains the current record contents.  Each field
      can be accessed using its offset into the CurRecord with the variable
      Off in the Fields array.

      See the demo program for some examples.
      While I intend to upload more complete routines and better
      documentation at some time, if you should have any problems with
      these routines, please leave me a note.

dBASE III Database File Structure
The structure of a dBASE III database file is composed of a
header and data records.  The layout is given below.
dBASE III DATABASE FILE HEADER:
+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0      |  1 byte           | dBASE III version number        |
|         |                   |  (03H without a .DBT file)      |
|         |                   |  (83H with a .DBT file)         |
+---------+-------------------+---------------------------------+
|  1-3    |  3 bytes          | date of last update             |
|         |                   |  (YY MM DD) in binary format    |
+---------+-------------------+---------------------------------+
|  4-7    |  32 bit number    | number of records in data file  |
+---------+-------------------+---------------------------------+
|  8-9    |  16 bit number    | length of header structure      |
+---------+-------------------+---------------------------------+
|  10-11  |  16 bit number    | length of the record            |
+---------+-------------------+---------------------------------+
|  12-31  |  20 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
|  32-n   |  32 bytes each    | field descriptor array          |
|         |                   |  (see below)                    | --+
+---------+-------------------+---------------------------------+   |
|  n+1    |  1 byte           | 0DH as the field terminator     |   |
+---------+-------------------+---------------------------------+   |
|
|
A FIELD DESCRIPTOR:      <------------------------------------------+
+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0-10   |  11 bytes         | field name in ASCII zero-filled |
+---------+-------------------+---------------------------------+
|  11     |  1 byte           | field type in ASCII             |
|         |                   |  (C N L D or M)                 |
+---------+-------------------+---------------------------------+
|  12-15  |  32 bit number    | field data address              |
|         |                   |  (address is set in memory)     |
+---------+-------------------+---------------------------------+
|  16     |  1 byte           | field length in binary          |
+---------+-------------------+---------------------------------+
|  17     |  1 byte           | field decimal count in binary   |
+---------+-------------------+--------------------------------
|  18-31  |  14 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
The data records are layed out as follows:
1. Data records are preceeded by one byte that is a
space (20H) if the record is not deleted and an
asterisk (2AH) if it is deleted.
2. Data fields are packed into records with no field
separators or record terminators.
3. Data types are stored in ASCII format as follows:
DATA TYPE      DATA RECORD STORAGE
---------      --------------------------------------------
Character      (ASCII characters)
Numeric        - . 0 1 2 3 4 5 6 7 8 9
Logical        ? Y y N n T t F f  (? when not initialized)
Memo           (10 digits representing a .DBT block number)
Date           (8 digits in YYYYMMDD format, such as
                19840704 for July 4, 1984)

This information came directly from the Ashton-Tate Forum.
It can also be found in the Advanced Programmer's Guide available
from Ashton-Tate.
*)


  (*
  Notice that if you need to access more than one .DBF file simultaneously
  you could declare ARRAYs of DbfFileType, DbfInfoType, etc.
  *)

  PROCEDURE ErrorHalt(Msg : Str80);

  BEGIN
  WriteLn;
  WriteLn(Msg);
  Halt;
  END;

  FUNCTION MakeReal(VAR b) : Real;
  VAR
    r : ARRAY[1..4] OF Byte ABSOLUTE b;

  BEGIN
    MakeReal := (r[1]*1)+(r[2]*256)+(r[3]*65536.0)+(r[4]*16777216.0);
  END;

  FUNCTION MakeInt(VAR b) : Integer;
  VAR
    i : Integer ABSOLUTE b;

  BEGIN
    MakeInt := i;
  END;

  FUNCTION MakeStr(b : Byte) : Str2;
  VAR
    i : Integer;
    s : Str2;
  BEGIN
    i := b;
    Str(i:2, s);
    MakeStr := s;
  END;


  PROCEDURE UpdateHeader(VAR D : DbfInfoType);

  TYPE
    RegType  = Record  Case Integer of
                 1 : (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
                 2 : (AL,AH,BL,BH,CL,CH,DL,DH : Byte);
               END;

  VAR
    Reg : RegType;
    r : Real;


  BEGIN
  WITH D DO
    BEGIN
      Reg.AX := $2A00;  { Get DOS Date }
      Intr ($21,Reg);
      HeadProlog[1] := Reg.CX - 1900; {Year}
      HeadProlog[2] := Reg.DH;        {Month}
      HeadProlog[3] := Reg.DL;        {Day}
      r := NumRecs;
      HeadProlog[7] := Trunc(r / 16777216.0);
      r := r - (HeadProlog[7] * 16777216.0);
      HeadProlog[6] := Trunc(r / 65536.0);
      r := r - (HeadProlog[6] * 65536.0);
      HeadProlog[5] := Trunc(r / 256);
      r := r - (HeadProlog[5] * 256);
      HeadProlog[4] := Trunc(r);
      LongSeek(dFile,0);
      {$I-} BlockWrite(dFile,HeadProlog,SizeOf(HeadProlog)); {$I+}
      IF IOResult <> 0 THEN ErrorHalt('Error Closing file.');
    END; {WITH}
  END;


  FUNCTION CloseDbf(VAR D : DbfInfoType) : Integer;
  VAR
    b : Byte;

  BEGIN
  WITH D DO
    BEGIN
    IF Updated THEN
      BEGIN
        UpdateHeader(D);
        b := $1A;
        LongSeek(dFile,HeadLen+NumRecs*RecLen);
        BlockWrite(dFile,b,1); {Put EOF marker }
      END;
    {$I-} Close(dFile);             {$I+}
    CloseDbf := IOResult;
    END; {WITH}
  END;

  PROCEDURE ProcessHeader(VAR Header : HeaderType;
                          VAR D : DbfInfoType);

    PROCEDURE GetOneFieldDesc(VAR F; VAR Field : FieldRecord;
                              VAR Offset : Integer);

    VAR
      i : Integer;
      FD : FieldDescType ABSOLUTE F;

    BEGIN
    WITH Field DO
      BEGIN
        i := 0;
        Name := '          ';
      REPEAT
        Name[Succ(i)] := Chr(FD[i]);
        i := Succ(i);
      UNTIL FD[i] = 0;
      Name[0] := Chr(i);
      Typ := Char(FD[11]);
      Len := FD[16];
      Dec := FD[17];
      Off := Offset;
      Offset := Offset+Len;
      IF NOT(Typ IN ValidTypes) THEN
        ErrorHalt('Invalid Type in Field '+Name);
      END;                    {WITH}
    END;                      {GetOneFieldDesc}


  VAR
    o, i : Integer;

  BEGIN                       {ProcessHeader}
  WITH D DO
    BEGIN
    CASE Header[0] OF
      DB3File : WithMemo := False;
      DB3WithMemo : WithMemo := True;
    ELSE
      ErrorHalt('Not a valid dBASE III File.');
    END;                      {CASE}
    DateOfUpdate := MakeStr(Header[2])+'/'+MakeStr(Header[3])+'/'
                    +MakeStr(Header[1]);
    NumRecs := MakeReal(Header[4]);
    HeadLen := MakeInt(Header[8]);
    RecLen := MakeInt(Header[10]); { Includes the Deleted Record Flag }
    Updated := FALSE;
    NumFields := 0;
    FOR i := 0 TO SizeOf(HeadProlog) DO
      HeadProlog[i] := Header[i];
    o := 1;                   {Offset within dbf record of current field }
    i := 32;                  {Index for Header }
    WHILE Header[i] <> $0D DO
      BEGIN
        NumFields := Succ(NumFields);
        GetOneFieldDesc(Header[i], Fields[NumFields], o);
        i := i+32;
      END;                    {While}
    IF Header[Succ(HeadLen)] = 0 THEN
      HeadLen := Succ(HeadLen);
    END;                      {With}
  END;                        {ProcessHeader}

  PROCEDURE GetHeader(VAR D : DbfInfoType);

  VAR
    Result : Integer;
    H      : HeaderType;

  BEGIN
  WITH D DO
    BEGIN
    {$I-} BlockRead(dFile, H, MAX_HEADER, Result); {$I+}
    IF IOResult <> 0 THEN
      ErrorHalt('Error reading header.');
      ProcessHeader(H, D);
    END; {WITH}
  END;

  FUNCTION OpenDbf(VAR D : DbfInfoType) : Integer;

  BEGIN
  WITH D DO
    BEGIN
    Assign(dFile, FileName);
    {$I-} Reset(dFile, 1); {$I+}    {the '1' parameter sets the record size}
    IF IOResult <> 0 THEN
      ErrorHalt('Error opening data file.');
      GetHeader(D);
      OpenDbf := IOResult;
    END; {WITH}
  END;


  PROCEDURE GetDbfRecord(VAR D : DbfInfoType; RecNum : Real);

  VAR
    Result : Integer;

  BEGIN
  WITH D DO
    BEGIN
    IF RecNum > NumRecs THEN
      ErrorHalt('Tried to read past EOF.');
    LongSeek(dFile, HeadLen+(RecNum-1)*RecLen);
    BlockRead(dFile, CurRecord, RecLen, Result);
    IF Result <> RecLen THEN
      ErrorHalt('Error reading DBF File');
    END;                      { WITH }
  END;                        {GetDbfRecord}


PROCEDURE CreateData(VAR D : DbfInfoType);

var
  r,i : integer;

    PROCEDURE WriteField(VAR a; VAR F : FieldRecord);

    VAR
      Data : array [1..255] of char ABSOLUTE a;
      Start,TempLen : integer;

    BEGIN
      WITH F DO
        BEGIN
          CASE Typ OF
            'N' : begin
                    Start := 1;
                    while Data[Start] = ' ' do
                      Start := Start + 1;
                    write(DataFile,Copy(Data,Start,Len))
                  end;

            'C',
            'L' : begin
                    TempLen := Len;
                    if Trim = Yes then
                      while Data[TempLen] = ' ' do
                        TempLen := TempLen - 1;
                      write(DataFile,Copy(Data, 1, TempLen));
                  end;
            'M' : ;
            'D' : write(DataFile,Copy(Data, 5, 2), '/',
                  Copy(Data, 7, 2), '/',
                  Copy(Data, 1, 2));
          END;                    {CASE}
        end;                    {WITH F}
      END;                      { WriteField }


BEGIN   { CreateData }

  WITH D DO
    BEGIN
      r := 1;
      write(r:5,' records written to WordPerfect merge file...');
      WHILE r <= NumRecs DO
        BEGIN
          GotoXY(1,WhereY);
          write(r:5);
          GetDbfRecord(D, r);
          FOR i := 1 TO NumFields DO
            begin
              WriteField(CurRecord[Fields[i].Off], Fields[i]);
              write(DataFile,FieldDelim)
            end;
          write(DataFile,RecordDelim);
          r := r+1
        END;                { WHILE r    }
    END;                    { WITH D     }
  GotoXY(1,WhereY);
  ClrEOL;
  writeln((r-1):5,' records written to WordPerfect merge file ',DOSWPFile,'.')
END;                        { CreateData }


begin
  DOSdBaseFile := ParamStr(1);
  if DOSdBaseFile = '?' then
    begin
      ClrScr;
      writeln(ProgramTitle);
      writeln;
      TextColor(LightBlue);
      writeln('Usage: DB3WP dBaseFile[.DBF] MergeFile[.DAT] Y/N');
      TextColor(Yellow);
      writeln('               ',#24,'               ',#24,'              ',#24);
      writeln('             dBASE III or    WordPerfect     Trim trailing');
      writeln('             dBASE III +     Secondary       blanks from');
      writeln('             input file      Merge file      character fields');
      writeln;
      writeln('You may specify an asterisk ("*") as the filename for the MergeFile.');
      writeln('This will create a merge file with a filename the same as the .DBF');
      writeln('file but with the appropriate extension (.DAT).');
      writeln;
      writeln('Example: DB3WP ADDRESS.DBF ADDRESS.DAT Y');
      writeln('Result:  Creates ADDRESS.DAT from ADDRESS.DBF; trims trailing blanks');
      writeln('         from character fields.');
      writeln;
      writeln('Example: DB3SPSS ADDRESS * N');
      writeln('Result:  Same as above, but does not trim trailing blanks.');
      writeln;
      writeln('If you simply type DB3WP alone, you will be prompted for each file name and');
      writeln('whether or not you wish to trim trailing blanks from character fields.');
      Halt
   end;

  DOSWPFile := ParamStr(2);

  if ParamStr(3) = '' then
    Trim := Undefined
  else
    case UpCase(Copy(ParamStr(3),1,1)) of
      'Y' : Trim := Yes;
      'N' : Trim := No
    else
      Trim := Undefined
    end;

  if (DOSdBaseFile <> '') and (Pos('.',DOSdBaseFile) = 0) then
    DOSdBaseFile := DOSdBaseFile + '.DBF';

  if (ParamCount < 1) or FileExist(DOSWPFile) then
    PaintLogo;

  GetInputFile(DOSdBaseFile);
  if length(DOSdBaseFile) = 0 then
    halt;

  Default := DOSdBaseFile;
  while Default[DefLen] <> '.' do
    DefLen := Pred(DefLen);

  if DOSWPFile = '*' then
    DOSWPFile := Default + DefaultWPExt;

  GetOutputFile(DOSWPFile,Default + DefaultWPExt);

  if Trim = Undefined then
    begin
      writeln;
      write('Trim trailing blanks of character fields (Y/N)? Y');
      GotoXY(WhereX-1,WhereY);
      repeat
        GetChar(Choice)
      until UpCase(Choice) in ['Y','N',#13];
      case UpCase(Choice) of
        'Y',#13 : Trim := Yes;
        'N'     : begin
                    write('N');
                    Trim := No
                  end
      end
    end;

  InputFile.FileName := DOSdBaseFile;

  if OpenDBF(InputFile) <> 0 then
    ErrorHalt('Error in opening file '+DOSdBaseFile);

  assign(DataFile,DOSWPFile);
  rewrite(DataFile);

  PaintLogo;

  writeln('Generating data file ',DOSWPFile,' from ',DOSdBaseFile);

  CreateData(InputFile);

  LowVideo;
  if CloseDbf(InputFile) <> 0 then
    writeln('Error closing ',DOSdBaseFile);
  Close(DataFile);
  writeln

end.