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

Pascal/Delphi Source File | 1985-11-18 | 10.2 KB | 296 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 STARTER; { ONE OF THE FILER GROUP OF PROGRAMS }
{  A GENERALIZED FRAMEWORK FOR A CUSTOMIZED OUTPUT REPORT  }
{  STARTER.PAS  VERSION 2.0 }
{  INCLUDE FILES : STARTER1.PAS }
{  NOV 15, 1984 }

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

VAR
  FILERECCHGD      : BOOLEAN;
  FILEEXISTS       : BOOLEAN;
  RECADDEDTOFILE   : BOOLEAN;

  CH               : CHAR;

  FILENAME       : STRING[6];
  FILEDATE,
  CURRDATE       : STRING[8];
  SOURCENAME     : STRING[14];
  ANS            : STRING60;
  MESSAGE        : STRING60;
  PREVCONTENTS   : STRING60;

  W,X,Z, CODE, LEN,
  MAXNBRREC, NBRRECUSED, RCDLEN,
  BLOCKINGFACTOR, FIELDPERRECORD,
  DATARECORD, DISKRECORD, PRECBYTE,
  DISKRECNOWINMEM, NBRDISKRECUSED,
  LASTRECUSED, FIRST,
  ASCII,PAGE,LINE,PAGEFULLLINECOUNT          :    INTEGER;

  NUMVALUE                                   :    REAL;

  LABELLENGTH, DATALEN, DATAFORM,
  LABELPOSN, DATAPOSN, ROW,
  COLUMN, FIELDNBR                  :    ARRAY[1..32] OF INTEGER;
  LBL                               :    ARRAY[1..384] OF CHAR;
  GETDATA                           :    RANGE;
  ASCIIFIELD                        :    ARRAY[1..32] OF STRING60;
  NUMFIELD                          :    ARRAY[1..32] OF REAL;
  SUBTOTAL                          :    ARRAY[1..32] OF REAL;
  GRANDTOTAL                        :    ARRAY[1..32] OF REAL;

  SOURCE                            :    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;
{================================================================}
{               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;
{================================================================}
{               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;
{===============================================================}
{                       FUNCTION EXIST                          }
{===============================================================}
FUNCTION EXIST(FILENAME : NAMESTR) : BOOLEAN;
VAR
  FIL :  FILE;
BEGIN
  ASSIGN(FIL,FILENAME);
  {$I-}
  RESET(FIL);
  {$I+}
  EXIST := (IORESULT = 0)
END;
{================================================================}
{           READ RECORD AND PLACE DATA IN ARRAYS                 }
{================================================================}
PROCEDURE MOVERECORDDATATOARRAY;
  BEGIN
    CALCULATE;
    GETDATAREC;
    FOR Z := 1 TO FIELDPERRECORD DO
      BEGIN
        GETDATAFROMARRAY(ASCIIFIELD[Z],Z);
        IF DATAFORM[Z] <> ASCII THEN
          BEGIN
            STRINGTOREAL(ASCIIFIELD[Z],NUMFIELD[Z],CODE);
          END
        ELSE NUMFIELD[Z] := 0;
      END;
  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;
{$ISTARTER1.PAS}