Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TURBO5.ZIP/FLIST.PAS

Pascal/Delphi Source File | 1986-12-26 | 12.8 KB | 467 lines

PROGRAM FLIST (INPUT,OUTPUT,LISTFILE);
{  ***************************************************************************
   Read text file and list with print formatting -- Source is Turbo PASCAL
   Published in the Public Domain for non-commercial use
   by Todd Merriman, Future Communications - Atlanta, Georgia 1984.
   ***************************************************************************
}
CONST
   REV              = '1.2';
   PAGELEN          = 66;
   TOPMARG          = 2;
   BOTMARG          = 2;
   HEADMARG         = 2;
   DEFLEFTMARG      = 0;
   DEFRIGHTMARG     = 0;
   PAPERWIDTH       = 80;
   HEADING          = 'FLIST - by Future Communications';
   TABSPACE         = 8;

LABEL
   EXIT;

TYPE
   STRING255        = STRING [255];

VAR
   I                : INTEGER;
   LISTFILE         : TEXT;
   LISTNAME,HEADNAME: STRING [14];
   PAGENO           : INTEGER;
   LINENO           : INTEGER;
   TEXTLINE         : STRING255;
   TOP              : BOOLEAN;
   DRIVE            : STRING [2];
   FILL             : STRING [40];
   ABORT            : BOOLEAN;
   LEFTMARG         : INTEGER;
   RIGHTMARG        : INTEGER;

{  ************************* DATE & TIME MODULE *****************************
   < BEGIN >
}
TYPE
   STRING8  = STRING [8];

FUNCTION DATE : STRING8;
{  **************************************************************************
   Read date from reserved memory location
   **************************************************************************
}
VAR
   TEMP     : ARRAY [0..2] OF BYTE ABSOLUTE $0010;
   I        : BYTE;
   STR      : STRING8;

BEGIN { DATE }

   STR      := '';
   FOR I := 0 TO 2 DO
   BEGIN
      STR := STR + CHR (((TEMP [I] AND $F0) SHR 4) + $30);
      STR := STR + CHR ((TEMP [I] AND $0F)+ $30);
      IF I < 2 THEN STR := STR + '/';
   END; { FOR }
   DATE := STR;

END; { DATE }


FUNCTION TIME : STRING8;
{  **************************************************************************
   Read time from reserved memory location
   **************************************************************************
}
VAR
   TEMP     : ARRAY [0..2] OF BYTE ABSOLUTE $0013;
   I        : BYTE;
   STR      : STRING8;

BEGIN { TIME }

   STR      := '';
   FOR I := 0 TO 2 DO
   BEGIN
      STR := STR + CHR (((TEMP [I] AND $F0) SHR 4) + $30);
      STR := STR + CHR ((TEMP [I] AND $0F) + $30);
      IF I < 2 THEN STR := STR + ':';
   END; { FOR }
   TIME := STR;

END; { TIME }


PROCEDURE CHECKDATIME (VAR GOOD : BOOLEAN);
{  ***************************************************************************
   See if valid date and time in memory
   ***************************************************************************
}
VAR
   CHECK,CODE    : INTEGER;

BEGIN { CHECKDATIME }
   GOOD := TRUE;
   VAL (COPY (DATE, 1, 2), CHECK, CODE);
   IF (CHECK > 12) OR
      (CHECK < 1) OR
      (CODE > 0) THEN
         GOOD := FALSE;
   VAL (COPY (TIME, 1, 2), CHECK, CODE);
   IF (CHECK > 23) OR
      (CODE > 0) THEN
         GOOD := FALSE;
END; { CHECKDATIME }


PROCEDURE CONVERT (VAR BIG : STRING8; VAR LITTLE : BYTE);
{  ***************************************************************************
   Convert a character string to BCD numbers
   ***************************************************************************
}
BEGIN { CONVERT }
   LITTLE := ((ORD (BIG [1]) - $30) SHL 4) OR (ORD (BIG [2]) - $30);
   DELETE (BIG,1,2);
   IF LENGTH (BIG) > 0 THEN DELETE (BIG,1,1);      { get the separator }
END; { CONVERT }


PROCEDURE SETDATE;
{  ***************************************************************************
   Prompt for date and set in memory
   ***************************************************************************
}
CONST
   DIGITS   : SET OF CHAR = ['0'..'9'];

VAR
   TEMP     : ARRAY [0..2] OF BYTE ABSOLUTE $0010;
   I        : BYTE;
   STR      : STRING8;

BEGIN { SETDATE }
   WRITE ('Enter date [MM/DD/YY] ');
   READLN (STR);
   IF LENGTH (STR) > 0 THEN
   BEGIN
      FOR I := 0 TO 2 DO
      BEGIN
         IF (STR [1] IN DIGITS) AND (NOT (STR [2] IN DIGITS)) THEN
            STR := '0' + STR;          { insure leading zeros }
         CONVERT (STR,TEMP [I]);
      END; { FOR }
   END; { IF }
END; { SETDATE }


PROCEDURE SETIME;
{  ***************************************************************************
   Prompt for time and set in memory
   ***************************************************************************
}
CONST
   DIGITS   : SET OF CHAR = ['0'..'9'];

VAR
   TEMP     : ARRAY [0..2] OF BYTE ABSOLUTE $0013;
   I        : BYTE;
   STR      : STRING8;

BEGIN { SETIME }
   WRITE ('Enter time [HH:MM] ');
   READLN (STR);
   IF LENGTH (STR) > 0 THEN
   BEGIN
      INSERT (':00',STR,LENGTH (STR)+1);             { add seconds }
      FOR I := 0 TO 2 DO
      BEGIN
         IF (STR [1] IN DIGITS) AND (NOT (STR [2] IN DIGITS)) THEN
            STR := '0' + STR;          { insure leading zeros }
         CONVERT (STR,TEMP [I]);
      END; { FOR }
   END; { IF }
END; { SETIME }

{  ************************* DATE & TIME MODULE *****************************
   < END >
}
FUNCTION CMDLINE: STRING255;
{  ***************************************************************************
   Get command from command line
   ***************************************************************************
}
CONST
   BUF = $80;

VAR
   I:INTEGER;
   ST:STRING255;

BEGIN { CMDLINE }

   ST:='';
   FOR I:= BUF+2 TO BUF + ORD (MEM [BUF]) DO
   BEGIN
      ST [0] := SUCC (ST [0]);
      ST [ORD (ST [0])] := CHR (MEM [I]);
   END;

   CMDLINE:=ST;

END; { CMDLINE }


FUNCTION PARSE (VAR SOURCE:STRING255): STRING255;
{  ***************************************************************************
   Parse a string from the command line
   ***************************************************************************
}
VAR
   DEST: STRING255;
   DELIMIT: SET OF CHAR;

BEGIN { PARSE }

   DELIMIT:=[' ',',','='];
   DEST:='';
   IF (LENGTH(SOURCE) <> 0) THEN
   BEGIN
      REPEAT
         IF (SOURCE[1] IN DELIMIT) THEN DELETE(SOURCE,1,1);
      UNTIL ((NOT(SOURCE[1] IN DELIMIT)) OR (LENGTH(SOURCE) = 0));
      IF (LENGTH(SOURCE) <> 0) THEN
      REPEAT
         IF (NOT(SOURCE[1] IN DELIMIT)) THEN
         BEGIN
            DEST:= CONCAT(DEST,COPY(SOURCE,1,1));
               DELETE(SOURCE,1,1);
         END;
      UNTIL ((SOURCE[1] IN DELIMIT) OR (LENGTH(SOURCE) = 0));
   END;
   PARSE:= DEST;

END; { PARSE }


PROCEDURE MARGIN (NUM : BYTE);
{  ***************************************************************************
   Move NUM spaces from left margin
   ***************************************************************************
}
VAR
   I       : BYTE;

BEGIN { EMPTYLINE }
   FOR I := 1 TO NUM DO WRITE (LST,' ');
END; { EMPTYLINE }


PROCEDURE EMPTYLINE;
{  ***************************************************************************
   Print a line with something in it for funky Anadex
   ***************************************************************************
}
VAR
   I                        : INTEGER;

BEGIN { EMPTYLINE }
   MARGIN (LEFTMARG);
   WRITE (LST,'.');
   MARGIN (PAPERWIDTH - LEFTMARG - RIGHTMARG -2);
   WRITELN (LST,'.');
END; { EMPTYLINE }


PROCEDURE PAGEHEAD;
{  ***************************************************************************
   Print heading for each page of listing
   ***************************************************************************
}
VAR
     I                        : INTEGER;

BEGIN { PAGEHEAD }

   WHILE (LINENO >= PAGELEN - BOTMARG) OR (TOP) DO
   BEGIN
      IF NOT TOP THEN WRITE(LST,^L);
      TOP                      := FALSE;
      LINENO                   := 1;
      FOR I := 1 TO TOPMARG DO
      BEGIN
         EMPTYLINE;
         LINENO              := LINENO + 1;
      END; { FOR }

      MARGIN (LEFTMARG);
      WRITELN (LST,HEADNAME,FILL,TIME,'  ',DATE,FILL,'Page ',PAGENO);
      LINENO                   := LINENO + 1;

      FOR I := 1 TO HEADMARG DO
      BEGIN
         EMPTYLINE;
         LINENO              := LINENO + 1;
      END; { FOR }

      PAGENO                   := PAGENO + 1;

   END; { WHILE }

END; { PAGEHEAD }


PROCEDURE SKIPHEAD;
{  ***************************************************************************
   Skip form feeds and headings
   ***************************************************************************
}
BEGIN
   REPEAT
      IF KEYPRESSED THEN ABORT := TRUE;
      READLN (LISTFILE,TEXTLINE);
   UNTIL (LENGTH (TEXTLINE) > 0) OR (EOF (LISTFILE)) OR (ABORT);

END; { SKIPHEAD }


PROCEDURE PRINTLINE;
{  ***************************************************************************
   Expand tabs and print line with truncation to margins
   ***************************************************************************
}
VAR
   TNUM,LNUM,I,J   : BYTE;

BEGIN
   IF LENGTH (TEXTLINE) > 0 THEN
   BEGIN
      TNUM := 1;
      LNUM := 1;
      I    := 1;
      WHILE  I <  PAPERWIDTH - LEFTMARG - RIGHTMARG DO
      BEGIN
         IF TEXTLINE [LNUM] = #9 THEN
         BEGIN
            FOR J := TNUM TO TABSPACE DO
            BEGIN
               I := I + 1;
               WRITE (LST,' ');
            END; { FOR }
            TNUM := 1;
            LNUM := LNUM + 1;
         END
         ELSE
         BEGIN
            WRITE (LST,TEXTLINE[LNUM]);
            LNUM := LNUM + 1;
            TNUM := TNUM + 1;
            I    := I + 1;
            IF TNUM > TABSPACE THEN TNUM := 1;
            IF LNUM > LENGTH (TEXTLINE) THEN I := PAPERWIDTH;
         END; { ELSE }
      END; { WHILE }
   END; { IF LENGTH }
   WRITELN (LST);
END; { PRINTLINE }


{  ***************************************************************************
}
BEGIN { FLIST }

   PAGENO   := 1;
   LINENO   := 1;
   LEFTMARG := DEFLEFTMARG;
   RIGHTMARG:= DEFRIGHTMARG;
   TOP      := TRUE;
   WRITELN ('---------- ',HEADING,' ----------');
   WRITELN ('           Rev. ',REV);
   WRITELN ('Text file listing with print formatting and tab expansion');
   WRITELN;

   TEXTLINE := CMDLINE;
   LISTNAME := PARSE (TEXTLINE);
   IF LENGTH (LISTNAME) = 0 THEN
   BEGIN
      WRITELN ('Usage:  A>FLIST <filename.ext> [leftmargin] [rightmargin]');
      ABORT := TRUE;
      GOTO EXIT;
   END; { IF }
   DRIVE := '';
   IF LENGTH (TEXTLINE) > 0 THEN
   BEGIN
      DRIVE := PARSE (TEXTLINE);
      VAL (DRIVE,LEFTMARG,I);
      IF I > 0 THEN LEFTMARG := DEFLEFTMARG;
   END; { IF }
   IF LENGTH (TEXTLINE) > 0 THEN
   BEGIN
      DRIVE := PARSE (TEXTLINE);
      VAL (DRIVE,RIGHTMARG,I);
      IF I > 0 THEN RIGHTMARG := DEFRIGHTMARG;
   END; { IF }
   ASSIGN (LISTFILE,LISTNAME);
   {$I-}
   RESET (LISTFILE);
   {$I+}
   IF IORESULT <> 0 THEN
   BEGIN
      WRITELN (#7,'? Error: ',LISTNAME,' does not exist');
      ABORT := TRUE;
      GOTO EXIT;
   END;
   CHECKDATIME (ABORT);
   IF NOT ABORT THEN
   BEGIN
      SETDATE;
      SETIME;
   END; { IF NOT }
   ABORT := FALSE;
   IF (LEFTMARG = DEFLEFTMARG) AND (RIGHTMARG = DEFRIGHTMARG) THEN
   BEGIN
      WRITELN ('Left and right margins may follow filename on command line');
      WRITELN ('Usage:  A>FLIST <filename.ext> [leftmargin] [rightmargin]');
   END;
   WRITELN (CON,'> File: ',LISTNAME);
   WRITE (CON,'> Paper width= ',PAPERWIDTH);
   WRITE (CON,'     Left margin= ',LEFTMARG);
   WRITELN (CON,'     Right margin= ',RIGHTMARG);
   WRITELN ('> Press any key to abort list');

   IF POS (':',LISTNAME) = 0 THEN
   BEGIN
      HEADNAME       := LISTNAME;
      DRIVE          := '';
   END { IF }
   ELSE
   BEGIN
      HEADNAME       := COPY (LISTNAME,3,LENGTH (LISTNAME)-2);
      DRIVE          := COPY(LISTNAME,1,2);
   END; { ELSE }
   FILL                     := ' ';
   FOR I := 1 TO (PAPERWIDTH - LEFTMARG - RIGHTMARG - 42 +
      12 - LENGTH (HEADNAME)) DIV 2 DO
      FILL := FILL + '-';
                                       { 42 spaces and characters in heading }
   FILL := FILL + ' ';

   WHILE NOT (EOF(LISTFILE) OR ABORT) DO
   BEGIN
      IF KEYPRESSED THEN ABORT := TRUE;
      PAGEHEAD;
      TEXTLINE := '';
      READLN (LISTFILE,TEXTLINE);
      IF COPY (TEXTLINE,1,1) = #12 THEN SKIPHEAD;    { filter form-feeds }
      MARGIN (LEFTMARG);                             { left margin }
      PRINTLINE;
      LINENO    := LINENO + 1;
   END; { WHILE }

   EXIT:;
   IF (PAGENO > 1) OR (LINENO > 1) THEN WRITE (LST,#12);
   IF ABORT THEN WRITELN (#7,'> List Aborted')
   ELSE WRITELN ('> Last page= ',PAGENO,'   Last line= ',LINENO);
   WRITELN ('> End <');
   CLOSE (LISTFILE);

END. { FLIST }