home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / PASCAL / JPDOOR32.ZIP / TRAPEXIT.PAS < prev   
Pascal/Delphi Source File  |  1992-02-26  |  6KB  |  185 lines
  1. {$F+}
  2.  
  3. (* This exit procedure may be used to trap HALT codes.  If defined in the
  4.    main body of your program (DoorExit := TrapExit), this procedure will be
  5.    called whenever your program encounters a HALT code or runtime error.
  6.  
  7.    As shown below, if ErrorAddr <> NIL (no runtime error has occurred) the
  8.    runtime error information is displayed to the local console and is also
  9.    written to a file called PROG_ERR.LOG.  You may wish to change the name
  10.    of this error log file to something more fitting to your program.
  11.  
  12.    If ErrorAddr = NIL then this code assumes that no runtime error has
  13.    occurred but rather that a HALT code has been encountered.  You could
  14.    conceivably handle all your HALT functions within the TRAPEXIT procedure.
  15.    However, in this demonstration, we can see that we are passing the HALT
  16.    code onto the TERMINATE procedure which is located within your program's
  17.    code.
  18. *)
  19.  
  20. PROCEDURE TrapExit;
  21.  
  22. VAR
  23.    ErrFile    : TEXT ;
  24.  
  25.  
  26.    FUNCTION Error_message(Code: INTEGER): STRING;
  27.       {return message text for a given runtime error code}
  28.    VAR
  29.       Class:  STRING;
  30.       Msg:    STRING;
  31.    BEGIN
  32.       CASE Code OF
  33.            1.. 99: Class := 'DOS ERROR      :';
  34.          100..149: Class := 'I/O ERROR      :';
  35.          150..199: Class := 'CRITICAL ERROR :';
  36.          200..249: Class := 'FATAL ERROR    :';
  37.          ELSE      Class := 'UNKNOWN ERROR  :';
  38.       END;
  39.  
  40.       CASE Code OF
  41.            2: Msg := 'File not found';
  42.            3: Msg := 'Path not found';
  43.            4: Msg := 'Too many open files';
  44.            5: Msg := 'File access denied';
  45.            6: Msg := 'Bad file handle';
  46.           12: Msg := 'Bad file access code';
  47.           15: Msg := 'Bad drive number';
  48.           16: Msg := 'Can''t remove current dir';
  49.           17: Msg := 'Can''t rename across drives';
  50.  
  51.          100: Msg := 'Disk read error, read past eof on Typed File';
  52.          101: Msg := 'Disk write error';
  53.          102: Msg := 'File not assigned';
  54.          103: Msg := 'File not open';
  55.          104: Msg := 'File not open for input';
  56.          105: Msg := 'File not open for output';
  57.          106: Msg := 'Bad numeric format';
  58.  
  59.          150: Msg := 'Disk is write-protected';
  60.          151: Msg := 'Unknown diskette unit';
  61.          152: Msg := 'Drive not ready';
  62.          153: Msg := 'Unknown command';
  63.          154: Msg := 'CRC error in data';
  64.          155: Msg := 'Bad drive request structure length';
  65.          156: Msg := 'Disk seek error';
  66.          157: Msg := 'Unknown diskette type';
  67.          158: Msg := 'Sector not found';
  68.          159: Msg := 'Printer out of paper';
  69.          160: Msg := 'Device write fault';
  70.          161: Msg := 'Device read fault';
  71.          162: Msg := 'Hardware failure';
  72.  
  73.          200: Msg := 'Division by zero';
  74.          201: Msg := 'Range check';
  75.          202: Msg := 'Stack overflow';
  76.          203: Msg := 'Heap overflow'+' (Not enough memory to run)';
  77.          204: Msg := 'Bad pointer operation';
  78.          205: Msg := 'Floating point overflow';
  79.          206: Msg := 'Floating point underflow';
  80.          207: Msg := 'Bad floating point operation';
  81.  
  82.          ELSE STR(Code,Msg);
  83.       END;
  84.  
  85.       Error_message := Class + Msg;
  86.    END;
  87.  
  88.    FUNCTION Exit_message(Code: INTEGER): STRING;
  89.       {return message text for a given exit code}
  90.    VAR
  91.       Msg:    STRING;
  92.    BEGIN
  93.       CASE Code OF
  94.            0: Msg := 'Normal Termination';
  95.            1: Msg := 'Carrier Lost';
  96.            2: Msg := 'Time Limit Exceeded';
  97.            3: Msg := 'User Inactivity Timeout';
  98.            4: Msg := 'Cannot Find Dorinfo1.def';
  99.            5: Msg := 'Cannot Find ExitInfo.Bbs';
  100.            6: Msg := 'Directory Change/Read Error';
  101.            7: Msg := 'CTS Timeout';
  102.            8: Msg := 'Forced Exit via RAXIT Semaphore';
  103.            9: Msg := 'Cannot Find Door.Sys';
  104.          ELSE STR(Code,Msg);
  105.       END;
  106.       Exit_Message := Msg;
  107.    END;
  108.  
  109.  
  110.    FUNCTION Itoh(W: Word): STRING;
  111.       {hex conversion}
  112.    CONST
  113.       Hex: ARRAY[0..15] OF CHAR = '0123456789ABCDEF';
  114.    VAR
  115.       H: STRING[4];
  116.    BEGIN
  117.       H[0] := CHR(4);
  118.       H[1] := Hex[(W SHR 12) AND $0f];
  119.       H[2] := Hex[(W SHR  8) AND $0f];
  120.       H[3] := Hex[(W SHR  4) AND $0f];
  121.       H[4] := Hex[W          AND $0f];
  122.       Itoh := H;
  123.    END;
  124.  
  125. BEGIN
  126.    IF ErrorAddr = NIL THEN
  127.    Begin
  128.          If ExitCode = 0 then
  129.          Begin
  130.            Terminate(0) ;
  131.            Exit;
  132.          End;
  133.          ASSIGN(ErrFile,'PROG_ERR.LOG') ;
  134.          IF EXIST('PROG_ERR.LOG') THEN APPEND(ErrFile) ELSE
  135.          Begin
  136.            REWRITE(ErrFile) ;
  137.            If ProductName <> '' then
  138.            Begin
  139.              Writeln(ErrFile,'Error Log Generated by ',ProductName);
  140.              Writeln(ErrFile,' ');
  141.            End;
  142.          End;
  143.          WRITELN('Date : ',DateStr,' At ',TimeStr);
  144.          WRITELN('Program Termination');
  145.          WRITELN('Node : ',ThisNode);
  146.          WRITELN(Exit_Message(Exitcode));
  147.  
  148.          WRITELN(ErrFile,'Date : ',DateStr,' At ',TimeStr);
  149.          WRITELN(ErrFile,'Program Termination');
  150.          WRITELN(ErrFile,'Node : ',ThisNode);
  151.          WRITELN(ErrFile,Exit_Message(Exitcode));
  152.          flush(ErrFile) ;
  153.          Close(ErrFile) ;
  154.  
  155.          Terminate(ExitCode);
  156.          Delay(1000);
  157.    End ELSE
  158.    BEGIN
  159.          ASSIGN(ErrFile,'PROG_ERR.LOG') ;
  160.          IF EXIST('PROG_ERR.LOG') THEN APPEND(ErrFile) ELSE REWRITE(ErrFile) ;
  161.          WRITELN('Date : ',DateStr,' At ',TimeStr);
  162.          WRITELN('Run-time error occurred');
  163.          WRITELN('Node : ',ThisNode);
  164.          WRITELN('Exitcode = ', exitcode);
  165.          WRITELN(Error_Message(Exitcode));
  166.          WRITELN('Address of error:');
  167.          WRITELN('  Segment: ', ItoH(seg(erroraddr^)));
  168.          WRITELN('  Offset:  ', ItoH(ofs(erroraddr^))) ;
  169.  
  170.  
  171.          WRITELN(ErrFile,'Date : ',DateStr,' At ',TimeStr);
  172.          WRITELN(ErrFile,'Run-time error occurred');
  173.          WRITELN(ErrFile,'Node : ',ThisNode);
  174.          WRITELN(ErrFile,'Exitcode = ', exitcode);
  175.          WRITELN(ErrFile,Error_Message(Exitcode));
  176.          WRITELN(ErrFile,'Address of error:');
  177.          WRITELN(ErrFile,'  Segment: ', ItoH(seg(erroraddr^)));
  178.          WRITELN(ErrFile,'  Offset:  ', ItoH(ofs(erroraddr^))) ;
  179.          flush(ErrFile) ;
  180.          Close(ErrFile) ;
  181.    END ;
  182.    ErrorAddr := NIL ;
  183. END ;
  184. {$F-}             
  185.