Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FILER.ZIP/TRANSFER.PAS

Pascal/Delphi Source File | 1985-11-18 | 14.9 KB | 426 lines

(***************************************************************)
(*                                                             *)
(*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
(*                                                             *)
(*        (C) 1985 by  John M. Harlan                          *)
(*                     24000 Telegraph                         *)
(*                     Southfield, MI. 48034                   *)
(*                                                             *)
(*     The FILER GROUP of programs is released on a "FREE      *)
(*     SOFTWARE" basis.  The recipient is free to examine      *)
(*     and use the software with the understanding that if     *)
(*     the FILER GROUP of programs prove to be of use and      *)
(*     value,  a contribution to the author is encouraged.     *)
(*                                                             *)
(*     While reasonable effort has been made to ensure the     *)
(*     reliability of the FILER GROUP of programs, no war-     *)
(*     ranty is given. The recipient uses the programs at      *)
(*     his own risk  and in no event shall the author be       *)
(*     liable for damages arising from their use.              *)
(*                                                             *)
(*                                                             *)
(***************************************************************)


PROGRAM TRANSFER;  { ONE OF THE FILER GROUP OF PROGRAMS }
{  PROGRAM TO TRANSFER DATA FROM ONE FILER DATA FORMAT  }
{  TO A SECOND FILER DATA FORMAT                        }
{  TRANSFER.PAS  REVISION 2.0 }
{  INCLUDE FILES : TRANSFR1.PAS }
{  JUNE 24, 1985 }

TYPE
  RANGE            = ARRAY[1..256] OF CHAR;
  STRING60         =  STRING[60];
  STRING20         =  STRING[20];
  NAMESTR          =  STRING[12];

VAR
  FILERECCHGD      : BOOLEAN;    { FOR SOURCE FILE }
  RECADDEDTOFILE   : BOOLEAN;    { FOR SOURCE FILE }
  FILERECCHGD2     : BOOLEAN;    { FOR DESTINATION FILE }
  RECADDEDTOFILE2  : BOOLEAN;    { FOR DESTINATION FILE }
  FILEEXISTS       : BOOLEAN;
  NULLRECORD       : BOOLEAN;

  CH               : CHAR;

  FILENAME,FILENAME2         : STRING[6];
  FILEDATE,FILEDATE2,
  CURRDATE                   : STRING[8];
  SOURCENAME                 : STRING[14];
  SOURCENAMEDAT              : STRING[14];
  DESTINATIONNAME            : STRING[14];
  DESTINATIONNAMEDAT         : STRING[14];

  ANS                        : STRING60;
  MESSAGE                    : STRING60;
  THISKEY                    : STRING60;

   W, X, Y, Z, CODE, FIRST, LEN,
  MAXNBRREC, RCDLEN, DESTFIELDNBR,
  BLOCKINGFACTOR, FIELDPERRECORD,
  ASCII, KEYLENGTH, DESTNBR             : INTEGER;

  W2, X2, Y2, Z2, CODE2, FIRST2, LEN2,
  MAXNBRREC2, RCDLEN2,
  BLOCKINGFACTOR2, FIELDPERRECORD2,
  ASCII2, KEYLENGTH2                    : INTEGER;

  DATARECORD, DISKRECORD, PRECBYTE,
  DISKRECNOWINMEM, NBRDISKRECUSED,
  NBRRECUSED,LASTRECUSED                : INTEGER;  { FOR SOURCE FILE }

  DATARECORD2, DISKRECORD2, PRECBYTE2,
  DISKRECNOWINMEM2, NBRDISKRECUSED2,
  NBRRECUSED2,LASTRECUSED2              : INTEGER;  { FOR DESTINATION FILE }

  NUMVALUE                              :    REAL;

  LABELLENGTH, DATALEN, DATAFORM,
  LABELPOSN, DATAPOSN, ROW, COLUMN      :    ARRAY[1..32] OF INTEGER;

  LABELLENGTH2, DATALEN2, DATAFORM2,
  LABELPOSN2, DATAPOSN2, ROW2,
  COLUMN2, TRANSARRAY                   :    ARRAY[1..32] OF INTEGER;

  KEYFIELD                              :    ARRAY[0..10] OF INTEGER;
  LBL,LBL2                              :    ARRAY[1..384] OF CHAR;
  GETDATA                               :    RANGE;  { FOR SOURCE FILE }
  GETDATA2                              :    RANGE;  { FOR DESTINATION FILE }

  SOURCE                                :    FILE;
  DESTINATION                           :    FILE;


{================================================================}
{        BINARY CODED DECIMAL TO INTEGER FUNCTION                }
{================================================================}
FUNCTION BCDTOIN (CHA : CHAR) : INTEGER;
BEGIN
  BCDTOIN := ORD(CHA) - TRUNC(ORD(CHA)/16)*6;
END;
{================================================================}
{             CHARACTER TO INTEGER FUNCTION                      }
{================================================================}
FUNCTION CHTOIN(VAR CHARRAY : RANGE; START, LEN : INTEGER)  : INTEGER;
VAR
  CODE, RESULT : INTEGER;
  WORKSTRING   : STRING[10];
BEGIN
  WORKSTRING := '';
  FOR RESULT := 0 TO LEN-1  DO
    BEGIN
      IF CHARRAY[START + RESULT ] = ' ' THEN
        WORKSTRING := WORKSTRING + '0'
      ELSE WORKSTRING := WORKSTRING + CHARRAY[START+RESULT];
    END;
  VAL(WORKSTRING,RESULT,CODE);
  CHTOIN := RESULT;
END;
{================================================================}
{               TIDE (EDIT BACKWARDS) PROCEDURE                  }
{================================================================}
PROCEDURE TIDE( VAR MESSAGE : STRING60);
VAR W  :  INTEGER;
BEGIN
  FOR W := LENGTH(MESSAGE) DOWNTO 1 DO
    BEGIN
      IF MESSAGE[W] IN [',', '$', '+'] THEN
        BEGIN
          DELETE(MESSAGE,W,1);
          MESSAGE := ' ' + MESSAGE;
        END;
    END;
END;
{===============================================================}
{                      FUNCTION EDITNBR                         }
{===============================================================}
FUNCTION EDITNBR(X: REAL; Y,Z: INTEGER; DOLLAR: CHAR ) : STRING20;
VAR
  NUMSTRING : STRING[24];
BEGIN    { CONVERT THE REAL NUMBER TO A STRING VALUE }
  STR(X:18:Z,NUMSTRING);
  IF Z = 0 THEN Z := 16  { FIRST POSSIBLE COMMA LOCATION  }
  ELSE Z := POS('.',NUMSTRING)-3;  {    DITTO             }

  WHILE Z > 1 DO  {  INSERT COMMAS/SPACES IN THE NUMBER  }
    BEGIN
      IF NUMSTRING[Z-1] IN [' ','-'] THEN
        INSERT(' ',NUMSTRING,Z)
      ELSE INSERT(',',NUMSTRING,Z);
      Z := Z -3 ;  {  COMMAS OCCUR EVERY THIRD CHARACTER  }
    END;

  {  FIND THE FIRST NON SPACE CHARACTER IN THE NUMBER }
  Z := 0;
  REPEAT
    Z := Z + 1;
 UNTIL NUMSTRING[Z] <> ' ';

  { DELETE ANY SPACE FOLLOWING A MINUS SIGN }
  IF NUMSTRING[Z] = '-' THEN
    BEGIN
      IF NUMSTRING[Z+1] = ' ' THEN DELETE(NUMSTRING,Z+1,1);
      IF DOLLAR = '$' THEN INSERT('$',NUMSTRING,Z+1);
    END

  { ADD THE $/SPACE CHARACTER TO THE BEGINNING OF THE NUMBER }
  ELSE NUMSTRING[Z-1] := DOLLAR;

  { REPLACE THE NUMBER WITH A FIELD OF '<' IF IT IS TOO BIG  }
  Z := LENGTH(NUMSTRING)-Y;
  IF NUMSTRING[Z-1] = '-' THEN
      FOR Z := Y DOWNTO 0 DO NUMSTRING[Z] := '<'
  ELSE
    BEGIN
      IF NUMSTRING[Z] IN ['0'..'9',',','-','.'] THEN
          FOR Z := Y DOWNTO 0 DO NUMSTRING[Z] := '<';
    END;
  EDITNBR := COPY(NUMSTRING,Z+1,Y);

END;
{================================================================}
{               STRING TO REAL NUMBER PROCEDURE                  }
{================================================================}
PROCEDURE STRINGTOREAL(VAR SOURCE:STRING60;VAR NUMB:REAL;VAR CODE:INTEGER);
VAR
  W  :  INTEGER;
  CONDITION  :  BOOLEAN;
BEGIN
  W := 1;
  NUMB := 0;
  CONDITION := TRUE;
  TIDE(SOURCE); { ELIMINATE PUNCTUATION }
  REPEAT  { UNTIL CONDITION = FALSE }
    IF SOURCE[W] = ' ' THEN DELETE(SOURCE,1,1)
    ELSE CONDITION := FALSE;
    IF LENGTH(SOURCE) = 0 THEN
      BEGIN
        SOURCE := '0';
        CONDITION := FALSE;
      END;
  UNTIL CONDITION = FALSE;
  IF LENGTH(SOURCE) = 1 THEN CONDITION := TRUE;
  WHILE CONDITION = FALSE DO
    BEGIN
      IF SOURCE[W] = ' ' THEN
        BEGIN
          CONDITION := TRUE;
          W := W-2;
        END;
      IF LENGTH(SOURCE) = W THEN
        BEGIN
          CONDITION := TRUE;
          W := W-1;
        END;
      W := W + 1;
    END;
  SOURCE := COPY(SOURCE,1,W);
  VAL( SOURCE,NUMB,CODE );
END;
{================================================================}
{           CALCULATE DISKRECORD & PRECBYTE PROCEDURE            }
{================================================================}
PROCEDURE CALCULATE;
  BEGIN
    DISKRECORD := TRUNC((DATARECORD-1)/BLOCKINGFACTOR)*2+7;
    PRECBYTE := ((DATARECORD-1) MOD BLOCKINGFACTOR)*RCDLEN;
  END;
{================================================================}
{                   GET DATA RECORD PROCEDURE                    }
{================================================================}
PROCEDURE GETDATAREC;
  BEGIN
    CALCULATE;
    IF DISKRECORD <> DISKRECNOWINMEM THEN
      BEGIN
        IF FILERECCHGD = TRUE THEN
          BEGIN
            IF DISKRECNOWINMEM > NBRDISKRECUSED THEN
              BEGIN                 { GET NEXT AVAILABLE RECORD }
                SEEK(SOURCE,NBRDISKRECUSED+2);
                NBRDISKRECUSED := DISKRECNOWINMEM;
              END
            ELSE
              BEGIN
                SEEK(SOURCE,DISKRECNOWINMEM);
              END;
            BLOCKWRITE(SOURCE,GETDATA,2);  {SAVE CHANGED DATA}
            FILERECCHGD := FALSE;
          END;
        IF DISKRECORD <= NBRDISKRECUSED THEN
          BEGIN
            SEEK(SOURCE,DISKRECORD);
            BLOCKREAD(SOURCE,GETDATA,2);         {  RECORD DATA  }
          END
        ELSE FILLCHAR(GETDATA[1],256,' '); {SPACES FOR EMPTY REC }
        DISKRECNOWINMEM := DISKRECORD;
      END;
  END;
{================================================================}
{     CALCULATE DESTINATION DISKRECORD & PRECBYTE PROCEDURE      }
{================================================================}
PROCEDURE CALCULATE2;
  BEGIN
    DISKRECORD2 := TRUNC((DATARECORD2-1)/BLOCKINGFACTOR2)*2+7;
    PRECBYTE2 := ((DATARECORD2-1) MOD BLOCKINGFACTOR2)*RCDLEN2;
  END;
{================================================================}
{            GET DESTINATION DATA RECORD PROCEDURE               }
{================================================================}
PROCEDURE GETDATAREC2;
  BEGIN
    CALCULATE2;
    IF DISKRECORD2 <> DISKRECNOWINMEM2 THEN
      BEGIN
        IF FILERECCHGD2 = TRUE THEN
          BEGIN
            IF DISKRECNOWINMEM2 > NBRDISKRECUSED2 THEN
              BEGIN                 { GET NEXT AVAILABLE RECORD }
                SEEK(DESTINATION,NBRDISKRECUSED2+2);
                NBRDISKRECUSED2 := DISKRECNOWINMEM2;
              END
            ELSE
              BEGIN
                SEEK(DESTINATION,DISKRECNOWINMEM2);
              END;
            BLOCKWRITE(DESTINATION,GETDATA2,2);  {SAVE CHANGED DATA}
            FILERECCHGD2 := FALSE;
          END;
        IF DISKRECORD2 <= NBRDISKRECUSED2 THEN
          BEGIN
            SEEK(DESTINATION,DISKRECORD2);
            BLOCKREAD(DESTINATION,GETDATA2,2);         {  RECORD DATA  }
          END
        ELSE FILLCHAR(GETDATA2[1],256,' '); {SPACES FOR EMPTY REC }
        DISKRECNOWINMEM2 := DISKRECORD2;
      END;
  END;
{================================================================}
{               GET DATA FROM ARRAY PROCEDURE                    }
{================================================================}
PROCEDURE GETDATAFROMARRAY(VAR MESSAGE : STRING60; Z : INTEGER);
VAR W :  INTEGER;
BEGIN
  MESSAGE := '';
  FOR W := PRECBYTE+DATAPOSN[Z] TO PRECBYTE+DATAPOSN[Z+1]-1 DO
    MESSAGE := MESSAGE + GETDATA[W];
END;
{================================================================}
{                 PRINT LABEL AND FIELD NUMBER                   }
{================================================================}
PROCEDURE PRINTLABFLDNBR( Z: INTEGER);
VAR
  W      :  INTEGER;
BEGIN
  IF ROW[Z] <22 THEN
    BEGIN
      GOTOXY(COLUMN[Z],ROW[Z]);
      FOR W := LABELPOSN[Z] TO LABELPOSN[Z+1]-1 DO
      WRITE (LBL[W]);
      WRITE('= ',Z);
    END;
END;
{================================================================}
{                      PRINT LABEL                               }
{================================================================}
PROCEDURE PRINTLABEL( Z: INTEGER);
VAR
  W      :  INTEGER;
BEGIN
  WRITE(Z,' : ');
  FOR W := LABELPOSN[Z] TO LABELPOSN[Z+1]-1 DO
  WRITE (LBL[W]);
  WRITELN;
END;
{================================================================}
{              DISPLAY ONE RECORD PROCEDURE, SOURCE              }
{================================================================}
PROCEDURE DISPLAYREC;
BEGIN
  CLRSCR;
  FOR Z := 1 TO FIELDPERRECORD DO
  PRINTLABFLDNBR(Z);
  GOTOXY(70,23);
  WRITE('RECORD ',DATARECORD);
  LASTRECUSED := DATARECORD;
END;

{================================================================}
{               GET DATA FROM ARRAY2 PROCEDURE                   }
{================================================================}
PROCEDURE GETDATAFROMARRAY2(VAR MESSAGE : STRING60; Z : INTEGER);
VAR W :  INTEGER;
BEGIN
  MESSAGE := '';
  FOR W := PRECBYTE2+DATAPOSN2[Z] TO PRECBYTE2+DATAPOSN2[Z+1]-1 DO
    MESSAGE := MESSAGE + GETDATA2[W];
END;
{================================================================}
{        PRINT DESTINATION LABEL AND FIELD NUMBER                }
{================================================================}
PROCEDURE PRINTLABFLDNBR2( Z: INTEGER);
VAR
  W      :  INTEGER;
BEGIN
  IF ROW2[Z] <22 THEN
    BEGIN
      GOTOXY(COLUMN2[Z],ROW2[Z]);
      FOR W := LABELPOSN2[Z] TO LABELPOSN2[Z+1]-1 DO
      WRITE (LBL2[W]);
      WRITE('= ',Z);
    END;
END;
{================================================================}
{                PRINT DESTINATION LABEL                         }
{================================================================}
PROCEDURE PRINTLABEL2( Z: INTEGER);
VAR
  W      :  INTEGER;
BEGIN
  WRITE(Z,' : ');
  FOR W := LABELPOSN2[Z] TO LABELPOSN2[Z+1]-1 DO
  WRITE (LBL2[W]);
  WRITELN;
END;
{================================================================}
{           DISPLAY ONE RECORD PROCEDURE, DESTINATION            }
{================================================================}
PROCEDURE DISPLAYREC2;
BEGIN
  CLRSCR;
  FOR Z := 1 TO FIELDPERRECORD2 DO
  PRINTLABFLDNBR2(Z);
  GOTOXY(70,23);
  WRITE('RECORD ',DATARECORD2);
  LASTRECUSED2 := DATARECORD2;
END;
{===============================================================}
{                       FUNCTION EXIST                          }
{===============================================================}
FUNCTION EXIST(FILENAME : NAMESTR) : BOOLEAN;
VAR
  FIL :  FILE;
BEGIN
  ASSIGN(FIL,FILENAME);
  {$I-}
  RESET(FIL);
  {$I+}
  EXIST := (IORESULT = 0)
END;
{================================================================}
{           FUNCTION GET NUMBER IN GETDATA FIELD ( Z )           }
{================================================================}
FUNCTION FNBRINFLD(Z : INTEGER) : REAL;
VAR
  REALVAL : REAL;
  BEGIN
    GETDATAFROMARRAY(ANS,Z);
    IF DATAFORM[Z] <> ASCII THEN
      STRINGTOREAL(ANS,REALVAL,CODE)
    ELSE REALVAL := 0;
    FNBRINFLD := REALVAL;
  END;
{$ITRANSFR1.PAS}