Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FIBMCM.ZIP/IOERROR.PAS

Pascal/Delphi Source File | 1989-05-09 | 11.3 KB | 357 lines

unit IOERROR;
  (* Error handling and other infrequent services.
     When driver output is to be shunted into a file, the file is opened here.
  Each such file contains one or more 512-character blocks of unaltered byte
  stream. *)

  interface
    uses
      DOS      (* FExpand, pathstr *);

    const
      LAST_WAITING = 24 (* MAX_WAITING - 1                *);
      MAX_WAITING  = 25 (* size of printer-channel buffer *);

    type
      destination = (TO_CONSOLE, TO_FILE, TO_PRINTER, TO_TRASH);
      record_number = 0 .. maxint;

    var
      WAITING_CHAR   (* 0 .. CHARS_WAITING-1 are real *):
                       packed array[0 .. LAST_WAITING] of char;
      OUTPUT_SINK    (* printer redirection           *): destination;
      CHARS_WAITING  (* printer-channel traffic       *): 0 .. MAX_WAITING;
      OUT_LINE_COUNT (* counts calls of HW_STABILIZE  *),
      PAGE_COUNT     (* total page count              *): integer;
      HEAP_USED      (* bytes of heap now in use      *),
      HEAP_ZENITH    (* most heap ever used           *),
      IN_LINE_COUNT  (* part of # of input lines      *): longint;
      SINK_FILE_NAME (* if non-null, output to file   *): pathstr;

    procedure BUILD_MESSAGE(RAW, NAME: string);
    function CAN_SHUNT_TO(TENTATIVE_FILE_NAME: string): boolean;
    procedure CLOSE_DEFER;
    procedure DEFER_TEXT;
    procedure INIT_IOERROR;
    procedure REPORT_IO_ERROR(F_NAME: pathstr; ERROR_NUMBER: integer);
    procedure SHUNT_TO_CONSOLE;
    procedure STATISTICS;
    procedure TIGHT_WRITE(R: real);
    procedure UNSHUNT;

  implementation
    uses
      CRT      (* ClrEol, GotoXY, WhereY *),
      SCRN_MGR (* ERROR_EXIT, INIT_SCREEN_MGR, LOUD_WRITE, nullstring,
                    READ_TIMER, STR_FN *);

    const
      DQUOTE  = '"';
      LPAR    = '(';
      RPAR    = ')';

      LAST_BYTE = 511 (* last in block of deferred file *);

      (* eject *)
    type
      defer_record = record
        NEXT_CHAR: integer;
            STUFF: packed array[0 .. LAST_BYTE] of char
        end (* defer_record *);

      defer_ptr = ^defer_record;

    var
      INITIALIZED  (* don't reinit SCRN_MGR *): boolean;
      DEFER_STATUS (* allocate iff used     *): defer_ptr;
      DEFER_FILE   (* redirected output     *): file;

    procedure WRITE_BUFFER; forward;

    procedure BUILD_MESSAGE(RAW, NAME: string);
      (* LOUD_WRITE the string RAW, replacing
           leading FFF by 'File <NAME>'
           XXX by NAME
      *)

      var
        XXX_POS: integer;

      begin (* BUILD_MESSAGE *)
        ClrEol;
        writeln;
        ClrEol;

        if pos('FFF', RAW) = 1 then
          begin (* File xxx ... *)
            LOUD_WRITE('File ');
            write(NAME);
            LOUD_WRITE(copy(RAW, 4, maxint))
          end   (* File xxx ... *)

        else
          begin (* assume that XXX present *)
            XXX_POS := pos('XXX', RAW);

            LOUD_WRITE(copy(RAW, 1, pred(XXX_POS)));
            write(NAME);
            LOUD_WRITE(copy(RAW, XXX_POS+3, maxint))
          end   (* assume that XXX present *);

        writeln;
        ClrEol
      end   (* BUILD_MESSAGE *);

      (* eject *)
    function CAN_SHUNT_TO(TENTATIVE_FILE_NAME: string): boolean;
      (* Open the named file for shunting, if possible; report success *)

      begin (* CAN_SHUNT_TO *)
        CAN_SHUNT_TO := false;
        SINK_FILE_NAME := FExpand(TENTATIVE_FILE_NAME);
        assign(DEFER_FILE, SINK_FILE_NAME);

        {$I-}
        rewrite(DEFER_FILE);
        if ioresult = 0 then
          begin (* file opened *)
            new(DEFER_STATUS);
            inc(HEAP_USED, sizeof(defer_record));
            if HEAP_USED > HEAP_ZENITH then
              HEAP_ZENITH := HEAP_USED;
            with DEFER_STATUS^ do
              begin (* fill defer_record *)
                fillchar(STUFF[0], succ(LAST_BYTE), #0);
                NEXT_CHAR := 0
              end   (* fill defer_record *);
            CAN_SHUNT_TO := true
          end   (* file opened *)
        {$I+}
      end   (* CAN_SHUNT_TO *);

    procedure CLOSE_DEFER;
      (* Finish up the open file of output whose printing will be deferred.
      *)

      var
        MY_IORESULT: integer;

      begin (* CLOSE_DEFER *);
        with DEFER_STATUS^ do
          begin (* with *)
            if NEXT_CHAR > 0 then
              WRITE_BUFFER;
            {$I-}
            close(DEFER_FILE);
            {$I+}

            MY_IORESULT := ioresult;
            if MY_IORESULT <> 0 then
              begin (* close failed *)
                REPORT_IO_ERROR(SINK_FILE_NAME, MY_IORESULT);
                ERROR_EXIT(nullstring)
              end   (* close failed *)
          end   (* with *)
      end   (* CLOSE_DEFER *);

      (* eject *)
    procedure DEFER_TEXT;
      (* Copy the contents of the CHARS_WAITING buffer into the file of
      deferred output *)

      var
        CHS_LEFT: 0 .. MAX_WAITING;
        CHS_MOVED, FIRST_REMAINING: integer;

      begin (* DEFER_TEXT *)
        CHS_LEFT := CHARS_WAITING;
        FIRST_REMAINING := 0;

        with DEFER_STATUS^ do
          while CHS_LEFT > 0 do
            begin (* move as many as we can into buffer *)
              CHS_MOVED := LAST_BYTE + 1 - NEXT_CHAR;
              if CHS_MOVED > CHS_LEFT then
                CHS_MOVED := CHS_LEFT;

              move(WAITING_CHAR[FIRST_REMAINING],
                   STUFF[NEXT_CHAR],
                   CHS_MOVED);
              dec(CHS_LEFT, CHS_MOVED);
              inc(NEXT_CHAR, CHS_MOVED);
              inc(FIRST_REMAINING, CHS_MOVED);

              if NEXT_CHAR > LAST_BYTE then
                WRITE_BUFFER
            end   (* move as many as we can into buffer *)
      end   (* DEFER_TEXT *);

    procedure INIT_IOERROR;
      (* Initialize the IOERROR unit and all underlying units *)

      begin (* INIT_IOERROR *)
        if not INITIALIZED then
          begin (* initialize *)
            INIT_SCRN_MGR;

            CHARS_WAITING := 0;
            HEAP_USED := 0;
            HEAP_ZENITH := 0;
            INITIALIZED := true;
            IN_LINE_COUNT := 0;
            OUT_LINE_COUNT := 0;
            PAGE_COUNT := 0
          end   (* initialize *)
      end   (* INIT_IOERROR *);

      (* eject *)
    procedure REPORT_IO_ERROR(F_NAME: pathstr; ERROR_NUMBER: integer);
      (* Decode ERROR_NUMBER (an IORESULT, arising during attempted
      reading of file F_NAME) to the console *)

      var
        RAW: string;

      begin (* REPORT_IO_ERROR *)
        case ERROR_NUMBER of
            2,
          102: RAW := 'FFF is improperly named or cannot be found.';
            3: RAW := '''XXX'' includes an illegal path name.';
            5: RAW := 'Access denied to file XXX.';
          100: RAW := 'FFF cannot be read.';
          101: RAW := 'FFF cannot be written.';
          103: RAW := 'FFF cannot be opened.';
          104: RAW := 'FFF not opened for reading.';
          105: RAW := 'FFF not opened for writing.'
          else RAW := 'I/O error #' + STR_FN(ERROR_NUMBER) +
                               ' signalled during reading of file XXX.'
          end (* case on ERROR_NUMBER *);

        BUILD_MESSAGE(RAW, F_NAME)
      end   (* REPORT_IO_ERROR *);

    procedure SHUNT_TO_CONSOLE;
      (* Copy the characters of CHARS_WAITING to the console *)

      var
        I: 0 .. MAX_WAITING;

      begin (* SHUNT_TO_CONSOLE *)
        for I := 0 to pred(CHARS_WAITING) do
          case WAITING_CHAR[I] of
            #32 .. #126: write(WAITING_CHAR[I])
                    else LOUD_WRITE(LPAR + STR_FN(ord(WAITING_CHAR[I])) + RPAR)
            end (* case on WAITING_CHAR[I] *);
        writeln
      end   (* SHUNT_TO_CONSOLE *);

      (* eject *)
    procedure STATISTICS;
      (* Print summary at end of document *)

      var
        SECONDS: longint;
        TOTAL_HOURS, TOTAL_MINUTES: real;

      begin (* STATISTICS *)
        writeln;
        writeln('Job size:');

        writeln(   HEAP_ZENITH:10, ' bytes of heap storage used at peak.');
        writeln( IN_LINE_COUNT:10, ' lines processed.');
        writeln(OUT_LINE_COUNT:10, ' lines composed.');

        write(PAGE_COUNT:10, ' page');
        if PAGE_COUNT <> 1 then
          write('s');
        writeln(' composed.');

        SECONDS := READ_TIMER;
        if SECONDS > 0 then
          begin (* we got timing data *)
            TOTAL_HOURS := SECONDS / 3600.0;
            TOTAL_MINUTES := SECONDS / 60.0;

            writeln;
            writeln('Job time:');
            writeln(nullstring:3,
                    SECONDS div 3600, 'h ',
                    (SECONDS mod 3600) div 60, ''' ',
                    SECONDS mod 60, DQUOTE);

            writeln;
            writeln('Job statistics:');
            writeln(round(IN_LINE_COUNT/TOTAL_MINUTES):10,
                    ' lines processed/minute');
            writeln(round(OUT_LINE_COUNT/TOTAL_MINUTES):10,
                    ' lines composed/minute');
            writeln(round(PAGE_COUNT/TOTAL_HOURS):10, ' pages composed/hour');
            writeln
          end   (* we got timing data *)
      end   (* STATISTICS *);

    procedure TIGHT_WRITE(R: real);
      (* Write R in integer format if possible, otherwise in F10.0 format *)

      begin (* TIGHT_WRITE *)
        if R > maxint then
          write(R:10:0)
        else
          write(trunc(R))
      end   (* TIGHT_WRITE *);

      (* eject *)
    procedure UNSHUNT;
      (* Reconsider shunting to file.  May be used ONLY if OUTPUT_SINK
      is about to be safely set *)

      begin (* UNSHUNT *)
        {$I-}
        close(DEFER_FILE);
        if ioresult > 0 then
          (* ignore it *);
        erase(DEFER_FILE);
        if ioresult > 0 then
          (* ignore it *);
        dispose(DEFER_STATUS);
        dec(HEAP_USED, sizeof(defer_record));
        {$I+}
        OUTPUT_SINK := TO_TRASH
      end   (* UNSHUNT *);

    procedure WRITE_BUFFER;
      (* Flush the buffer  *)

      var
        BLOCKS_WRITTEN, MY_IORESULT: integer;

      begin (* WRITE_BUFFER *)
        with DEFER_STATUS^ do
          begin (* with *)
            {$I-}
            blockwrite(DEFER_FILE, STUFF, 1, BLOCKS_WRITTEN);
            {$I+}
            MY_IORESULT := ioresult;
            if (MY_IORESULT <> 0) or (BLOCKS_WRITTEN <> 1) then
              begin (* failed to write *)
                REPORT_IO_ERROR(SINK_FILE_NAME, MY_IORESULT);
                ERROR_EXIT(nullstring)
              end   (* failed to write *)
            else
              begin (* succeeded, ready for next block *)
                fillchar(STUFF[0], succ(LAST_BYTE), #0);
                NEXT_CHAR := 0
              end   (* succeeded, ready for next block *)
          end   (* with *)
      end   (* WRITE_BUFFER *);

    begin (* IOERROR *)
      INITIALIZED := false
    end   (* IOERROR *).

END
T-------T-------T-------T-------T-------T-------T-------T-------T-------T-------T
$cursor=11521,10;$tag=2053,19;$last=11525,13;
FTL0R79P5.F0B7