home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ERRTRP.ZIP / ERRTRP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-03-19  |  18.6 KB  |  560 lines
  1. {$I- $F+}
  2. Unit Errtrp;
  3. Interface
  4.  
  5. uses
  6. crt,
  7. dos;
  8.  
  9. const
  10. ScrSeg:word=$b800;
  11. FGNorm=lightgray;
  12. BGNorm=blue;
  13. FGErr=white;
  14. BGErr=red;
  15.  
  16. var
  17. SaveInt24 :pointer;
  18. ErrorRetry:boolean;
  19. IOCode    :integer;
  20. version   :integer;
  21.  
  22. procedure DisplayError(ErrNo:integer);
  23. procedure RuntimeError;
  24. procedure ErrTrap(ErrNo:integer);
  25.  
  26.  
  27. Implementation
  28.  
  29.  
  30. var
  31.   ExitSave:pointer;
  32.   regs:registers;
  33.  
  34.  
  35. {$I crsrst.inc }
  36. (**************************************************************************)
  37.  
  38. const
  39.  INT59ERROR  : integer  = 0;
  40.  ERRORACTION : byte = 0;
  41.  ERRORTYPE   : byte =0;
  42.  ERRORAREA   : byte =0;
  43.  ERRORRESP   : byte =0;
  44.  ERRORRESULT : integer=0;
  45.  
  46. type
  47. errmsg         = array [0..89] of string;
  48. ermsgPtr       =^errmsg;
  49.  
  50. var
  51. Errs:ermsgPTR;
  52.  
  53. procedure box;
  54. var
  55.  i:integer;
  56. begin
  57.   textcolor(FGErr);
  58.   textbackground(BGErr);
  59.   gotoxy(1,1);
  60.   writeln('┌───────────────  Critical Error  ───────────────┐');
  61.     for i:=1 to 5 do
  62.   writeln('│                                                │');
  63.   write  ('└────────────────────────────────────────────────┘');
  64. end;{box}
  65.  
  66. function DosVer:integer;
  67. var
  68.  Maj:shortint;
  69.  Min:shortint;
  70.  regs:registers;
  71.  
  72. begin
  73.  regs.ah:=$30;
  74.  MsDos(Regs);
  75.  Maj:=regs.al;
  76.  Min:=regs.ah;
  77.  DosVer:=Maj;
  78. end;
  79.  
  80. procedure InitErrs;
  81. begin
  82. new(Errs);
  83. Errs^[0]:=   '             No error occured           ';
  84. Errs^[1]:=    '          Invalid function number       ';
  85. Errs^[2]:=    '              File not found            ';
  86. Errs^[3]:=    '              Path not found            ';
  87. Errs^[4]:=    '            No handle available         ';
  88. Errs^[5]:=    '              Access denied             ';
  89. Errs^[6]:=    '             Invalid handle             ';
  90. Errs^[7]:=    '     Memory control blocks destroyed    ';
  91. Errs^[8]:=    '           Insufficient memory          ';
  92. Errs^[9]:=    '      Invalid memory block address      ';
  93. Errs^[10]:=    '       Invalid SET command string       ';
  94. Errs^[11]:=    '             Invalid format             ';
  95. Errs^[12]:=    '          Invalid access code           ';
  96. Errs^[13]:=    '              Invalid data              ';
  97. Errs^[14]:=    '                Reserved                ';
  98. Errs^[15]:=    '       Invalid drive specification      ';
  99. Errs^[16]:=    '   Attempt to remove current directory  ';
  100. Errs^[17]:=    '             Not same device            ';
  101. Errs^[18]:=    '        No more files to be found       ';
  102. Errs^[19]:=    '          Disk write protected          ';
  103. Errs^[20]:=    '            Unknown unit ID             ';
  104. Errs^[21]:=    '          Disk drive not ready          ';
  105. Errs^[22]:=    '          Command not defined           ';
  106. Errs^[23]:=    '            Disk data error             ';
  107. Errs^[24]:=    '      Bad request structure length      ';
  108. Errs^[25]:=    '             Disk seek error            ';
  109. Errs^[26]:=    '         Unknown disk media type        ';
  110. Errs^[27]:=    '          Disk sector not found         ';
  111. Errs^[28]:=    '          Printer out of paper          ';
  112. Errs^[29]:=    '      Write error - Printer Error?      ';
  113. Errs^[30]:=    '               Read error               ';
  114. Errs^[31]:=    '            General failure             ';
  115. Errs^[32]:=    '         File sharing violation         ';
  116. Errs^[33]:=    '         File locking violation         ';
  117. Errs^[34]:=    '          Improper disk change          ';
  118. Errs^[35]:=    '             No FCB available           ';
  119. Errs^[36]:=    '         Sharing buffer overflow        ';
  120. Errs^[37]:=    '                Reserved                ';
  121. Errs^[38]:=    '                Reserved                ';
  122. Errs^[39]:=    '                Reserved                ';
  123. Errs^[40]:=    '                Reserved                ';
  124. Errs^[41]:=    '                Reserved                ';
  125. Errs^[42]:=    '                Reserved                ';
  126. Errs^[43]:=    '                Reserved                ';
  127. Errs^[44]:=    '                Reserved                ';
  128. Errs^[45]:=    '                Reserved                ';
  129. Errs^[46]:=    '                Reserved                ';
  130. Errs^[47]:=    '                Reserved                ';
  131. Errs^[48]:=    '                Reserved                ';
  132. Errs^[49]:=    '                Reserved                ';
  133. Errs^[50]:=    '      Network request not supported     ';
  134. Errs^[51]:=    '      Remote computer not listening     ';
  135. Errs^[52]:=    '        Duplicate name on network       ';
  136. Errs^[53]:=    '         Network name not found         ';
  137. Errs^[54]:=    '             Network busy               ';
  138. Errs^[55]:=    '      Network device no longer exists   ';
  139. Errs^[56]:=    '      NetBIOS command limit exceeded    ';
  140. Errs^[57]:=    '      Network adapter hardware error    ';
  141. Errs^[58]:=    '      Incorrect response from network   ';
  142. Errs^[59]:=    '        Unexpected network error        ';
  143. Errs^[60]:=    '      Incompatible remote adapter       ';
  144. Errs^[61]:=    '            Print queue full            ';
  145. Errs^[62]:=    '      Not enough space for print file   ';
  146. Errs^[63]:=    '         Print file was deleted         ';
  147. Errs^[64]:=    '        Network name was deleted        ';
  148. Errs^[65]:=    '             Access denied              ';
  149. Errs^[66]:=    '       Network device type incorrect    ';
  150. Errs^[67]:=    '          Network name not found        ';
  151. Errs^[68]:=    '        Network name limit exceeded     ';
  152. Errs^[69]:=    '      NetBIOS session limit exceeded    ';
  153. Errs^[70]:=    '           Temporarily paused           ';
  154. Errs^[71]:=    '       Network request not accepted     ';
  155. Errs^[72]:=    '  Print or disk re-direction is paused  ';
  156. Errs^[73]:=    '                Reserved                ';
  157. Errs^[74]:=    '                Reserved                ';
  158. Errs^[75]:=    '                Reserved                ';
  159. Errs^[76]:=    '                Reserved                ';
  160. Errs^[77]:=    '                Reserved                ';
  161. Errs^[78]:=    '                Reserved                ';
  162. Errs^[79]:=    '                Reserved                ';
  163. Errs^[80]:=    '           File already exists          ';
  164. Errs^[81]:=    '                Reserved                ';
  165. Errs^[82]:=    '              Cannot make               ';
  166. Errs^[83]:=    '     Critical-error interrupt failure   ';
  167. Errs^[84]:=    '          Too many redirections         ';
  168. Errs^[85]:=    '          Duplicate redirection         ';
  169. Errs^[86]:=    '           Duplicate password           ';
  170. Errs^[87]:=    '            Invalid parameter           ';
  171. Errs^[88]:=    '            Network data fault          ';
  172. Errs^[89]:=    '             Undefined Error            ';
  173. end;
  174.  
  175. procedure CritError(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:WORD);
  176.  INTERRUPT;
  177. type
  178. ScrPtr         =^ScrBuff;
  179. ScrBuff        =array [1..4096] of byte;
  180.  
  181. var
  182.   Display,
  183.   SaveScr    : ScrPtr;
  184.  
  185.   c         :char;
  186.   ErrorPrompt,
  187.   msg        :string;
  188.   ErrNum     :byte;
  189.  
  190.   drive,
  191.   area,
  192.   al,ah      :byte;
  193.  
  194.   deviceattr :^word;
  195.   devicename :^char;
  196.   ch,
  197.   i          :shortint;
  198.   actmsg,
  199.   tmsg,
  200.   amsg,
  201.   dname      :string;
  202. begin
  203.     ah:=hi(ax);
  204.     al:=lo(ax);                            { in case DOS version < 3     }
  205.     ErrNum:=lo(DI)+19;                     { save the error and add      }
  206.     msg:=Errs^[ErrNum];                    { add 19 to convert to        }
  207.                                            { standard DOS error          }
  208.     tmsg:='';
  209.     actmsg:='';                            { we can't suggest a response }
  210.  
  211.  if (ah and $80)=0 then                    { if a disk error then        }
  212.    begin                                   { get the drive and area      }
  213.      amsg:=' drive '+chr(al+65)+':';
  214.      area:=(ah and 6) shr 1;
  215.      case area of
  216.      0:amsg:=amsg+' dos communications area ';
  217.      1:amsg:=amsg+' disk directory area ';
  218.      2:amsg:=amsg+' files area ';
  219.      end;
  220.    end
  221. else                                       { else if a device error }
  222.    begin                                   { get type of device     }
  223.      deviceattr:=ptr(bp,si+4);
  224.      i:=0;
  225.      if (deviceattr^ and $8000)<>0 then     { if a character device }
  226.        begin                                { like a printer        }
  227.          amsg:='character device';
  228.          ch:=0;
  229.          repeat
  230.          i:=i+1;
  231.          devicename:=ptr(bp,si+$0a+ch);      { get the device name  }
  232.          dname[i]:=devicename^;
  233.          dname[0]:=chr(i);
  234.          inc (ch);
  235.          until (devicename^ = chr(0)) or (ch>7);
  236.        end
  237.     else                                     { else }
  238.       begin                                  { just inform of the error }
  239.         dname:='disk in '+chr(al)+':';
  240.         msg:= ' general failure ' ;
  241.         end;
  242.      amsg:=amsg+' '+dname;
  243.      end;
  244.  
  245.  inline($FA);                           { Enable interrupts       }
  246.  Display:=ptr(ScrSeg,$0000);            { save the current screen }
  247.  new(SaveScr);
  248.  SaveScr^:=Display^;
  249.  Window(15,10,65,16);                   { make a box to display the}
  250.  textcolor(FGErr);                      { error message            }
  251.  textbackground(BGErr);
  252.  clrscr;
  253.  box;
  254.  
  255.   if Version >=3 then                     { check the DOS version   }
  256.   begin                                  { major component         }
  257.   regs.ah:=$59;                          { and use DosExtErr since }
  258.   regs.bx:=$00;                          { it is available         }
  259.   MsDos(Regs);
  260.   INT59ERROR:=regs.ax;
  261.   ERRORTYPE:=regs.bh;
  262.   ERRORACTION:=regs.bl;
  263.   ERRORAREA:=regs.ch;
  264.   msg:=Errs^[INT59ERROR];                { get the error information}
  265. (*
  266.   case ERRORAREA of
  267.   1: amsg:='Unknown';
  268.   2: amsg:='Block Device';               { usually disk access error}
  269.   3: amsg:='Network Problem';
  270.   4: amsg:='Serial Device';              { printer or COM problem   }
  271.   5: amsg:='Memory';                     { corrupted memory         }
  272.   end;
  273. *)
  274.   case ERRORTYPE of
  275.   1 : tmsg:='Out of Resource';            { no channels, space       }
  276.   2 : tmsg:='Temporary situation';        { file locked for instance;}
  277.                                           { not an error and will    }
  278.                                           { clear eventually         }
  279.   3 :tmsg:='Authorization Violation';     { permission problem e.g.  }
  280.                                           { write to read only file  }
  281.   4 :tmsg:='Internal Software Error';     { system software bug      }
  282.   5 :tmsg:='Hardware Error';              { serious trouble -- fix   }
  283.                                           { the machine              }
  284.   6 :tmsg:='System Error';                { serious trouble software }
  285.                                           { at fault -- e.g. missing }
  286.                                           { CONFIG file              }
  287.   7 :tmsg:='Program Error';               { inconsistent request     }
  288.                                           { from your program        }
  289.   8 :tmsg:='Not found';                   { as stated                }
  290.   9 :tmsg:='Bad Format';                  { as stated                }
  291.   10:tmsg:='Locked';                      { interlock situation      }
  292.   11:tmsg:='Media Error';                 { CRC error, wrong disk in }
  293.                                           { drive, bad disk cluster  }
  294.   12:tmsg:='Exists';                      { collision with existing  }
  295.                                           { item, e.g. duplicate     }
  296.                                           { device name              }
  297.   13:tmsg:='Unknown Error';
  298.   end;
  299.  
  300.   case ERRORACTION of
  301.   1: actmsg:='Retry';                     { retry a few times then   }
  302.                                           { give user abort option   }
  303.                                           { if not fixed             }
  304.   2: actmsg:='Delay Retry';               { pause, retry, then give  }
  305.                                           { user abort option        }
  306.   3: actmsg:='User Action';               { ask user to reenter item }
  307.                                           { e.g. bad drive letter or }
  308.                                           { filename used            }
  309.   4:actmsg:='Abort';                      { invoke an orderly shut   }
  310.                                           { down -- close files, etc }
  311.   5:actmsg:='Immediate Exit';             { don't clean up, you may  }
  312.                                           { really screw something up}
  313.   6: actmsg:='Ignore';
  314.   7: actmsg:='Retry';                     { after user intervention: }
  315.   end;                                    { let the user fix it first}
  316.  
  317.   end;
  318. amsg:=tmsg+amsg;
  319. actmsg:='Suggested Action: '+actmsg;
  320.  
  321. gotoxy((54-length(msg)) div 2,3);
  322. write(msg);
  323.  
  324. gotoxy((54-length(amsg)) div 2,4);
  325. write(amsg);
  326.  
  327. gotoxy((54-length(actmsg)) div 2,6);
  328. write(actmsg);
  329.                                           { display it              }
  330.  
  331. ErrorPrompt:=' I)gnore R)etry A)bort F)ail ? ';
  332. gotoxy((54-length(ErrorPrompt))div 2,5);
  333. write(ErrorPrompt);
  334. repeat                                     { get the user response  }
  335. c:=readkey;
  336. c:=upcase(c);
  337. until c in ['A','R','I','F'];
  338. Window(1,1,80,25);                         { restore the screen     }
  339. textcolor(FGNorm);
  340. textbackground(BGNorm);
  341. Display^:=SaveScr^;
  342. dispose(SaveScr);
  343. case c of
  344.   'I':begin
  345.         AX:=0;
  346.         ERRORRETRY:=false;
  347.       end;
  348.   'R':begin
  349.         AX:=1;
  350.         ERRORRETRY:=true;
  351.       end;
  352.   'A':begin
  353.         Ax:=2;
  354.         ERRORRETRY:=false;
  355.         cursor(true);
  356.       end;
  357.   'F':begin
  358.         Ax:=3;
  359.         ERRORRETRY:=false;
  360.         cursor(true);
  361.       end;
  362. end;
  363.  
  364. end;{procedure CritError}
  365.  
  366. (**************************************************************************)
  367. procedure DisplayError(ErrNo:integer);
  368. var
  369. msg,
  370. exitmsg:string;
  371. begin
  372.     case ErrNo of
  373.     2:exitmsg:='File not found';
  374.     3:exitmsg:='Path not found';
  375.     4:exitmsg:='Too many open files';
  376.     5:exitmsg:='Access denied';
  377.     6:exitmsg:='Invalid file handle';
  378.     12:exitmsg:='Invalid file access code';
  379.     15:exitmsg:='Invalid drive';
  380.     16:exitmsg:='Cannot remove current directory';
  381.     17:exitmsg:='Cannot rename across drives';
  382.     100:exitmsg:='Disk read error';
  383.     101:exitmsg:='Disk write error - Disk Full ?';
  384.     102:exitmsg:='File not assigned';
  385.     103:exitmsg:='File not opened';
  386.     104:exitmsg:='File not open for input';
  387.     105:exitmsg:='File not open for output';
  388.     106:exitmsg:='Invalid numeric format';
  389.     150:exitmsg:='Disk is write protected';
  390.     151:exitmsg:='Unknown unit';
  391.     152:exitmsg:='Drive not ready';
  392.     153:exitmsg:='Unkown command';
  393.     154:exitmsg:='CRC error in data';
  394.     155:exitmsg:='Bad drive request structure length';
  395.     156:exitmsg:='Disk seek error';
  396.     157:exitmsg:='Unknown media type';
  397.     158:exitmsg:='Sector not found';
  398.     159:exitmsg:='Printer out of paper';
  399.     160:exitmsg:='Device write fault';
  400.     161:exitmsg:='Device read fault';
  401.     162:exitmsg:='Hardware failure';
  402.     200:exitmsg:='Division by zero';
  403.     201:exitmsg:='Range check error';
  404.     202:exitmsg:='Stack overflow';
  405.     203:exitmsg:='Heap overflow';
  406.     204:exitmsg:='Invalid pointer operation';
  407.     205:exitmsg:='Floating point overflow';
  408.     206:exitmsg:='Floating point underflow';
  409.     207:exitmsg:='Invalid floating point operation'
  410.     else exitmsg:='Unknown Error # ';
  411.     end;
  412.  
  413.   msg:=exitmsg;
  414.  
  415.   textcolor(FGErr);
  416.   textbackground(BGErr);
  417.   gotoxy((50-length(msg)) div 2,3);
  418.   write(msg);
  419.  
  420. end;
  421. procedure ErrTrap(ErrNo:integer);
  422. type
  423. ScrPtr         =^ScrBuff;
  424. ScrBuff        =array [1..4096] of byte;
  425.  
  426. var
  427.   Display,
  428.   SaveScr    : ScrPtr;
  429.  
  430.   c         :char;
  431.   ErrorPrompt,
  432.   msg:string;
  433.  
  434. begin
  435.  
  436.  Display:=ptr(ScrSeg,$0000);            { save the current screen }
  437.  new(SaveScr);
  438.  SaveScr^:=Display^;
  439.  Window(15,10,65,16);                   { make a box to display the}
  440.  textcolor(FGErr);                      { error message            }
  441.  textbackground(BGErr);
  442.  clrscr;
  443.  box;
  444.  
  445.   ErrorRetry:=true;
  446.   DisplayError(ErrNo);
  447.  
  448.                                           { display it              }
  449.  
  450. ErrorPrompt:=' I)gnore R)etry A)bort F)ail ? ';
  451. gotoxy((54-length(ErrorPrompt))div 2,5);
  452. write(ErrorPrompt);
  453. repeat                                     { get the user response  }
  454. c:=readkey;
  455. c:=upcase(c);
  456. until c in ['A','R','I','F'];
  457. case c of
  458.   'I':ErrorRetry:=false;
  459.   'R':ErrorRetry:=true;
  460.   'A':begin
  461.         ErrorRetry:=false;
  462.         cursor(true);
  463.       end;
  464.   'F':begin
  465.         ErrorRetry:=false;
  466.         cursor(true);
  467.       end;
  468.   end;
  469.   if ErrorRetry=false then
  470.     begin
  471.       gotoxy(4,4);
  472.       write('If you are unable to correct the error');
  473.       gotoxy(4,5);
  474.       write('please report the error ',#40,Errno,#41,' and      ');
  475.       gotoxy(4,6);
  476.       write('exact circumstances when it occurred to us.');
  477.       Window(1,1,80,25);                         { restore the screen     }
  478.       textcolor(FGNorm);
  479.       textbackground(BGNorm);
  480.       Display^:=SaveScr^;
  481.       dispose(SaveScr);
  482.  
  483.       ErrorAddr:=nil;
  484.       gotoxy(1,1);
  485.       cursor(true);
  486.       halt;
  487.     end;
  488. Window(1,1,80,25);                         { restore the screen     }
  489. textcolor(FGNorm);
  490. textbackground(BGNorm);
  491. Display^:=SaveScr^;
  492. dispose(SaveScr);
  493.  
  494. end;
  495.  
  496. procedure RuntimeError;
  497.  
  498. type
  499. ScrPtr         =^ScrBuff;
  500. ScrBuff        =array [1..4096] of byte;
  501.  
  502. var
  503.   Display,
  504.   SaveScr    : ScrPtr;
  505.  
  506.   c         :char;
  507.   ErrorPrompt,
  508.   msg:string;
  509.  
  510. begin
  511.   if ErrorAddr<>nil then
  512.     begin
  513.       Display:=ptr(ScrSeg,$0000);            { save the current screen }
  514.       new(SaveScr);
  515.       SaveScr^:=Display^;
  516.       Window(15,10,65,16);                   { make a box to display the}
  517.       textcolor(FGErr);                      { error message            }
  518.       textbackground(BGErr);
  519.       clrscr;
  520.       box;
  521.       gotoxy(15,1);
  522.       write('   Fatal  Error   ');
  523.       DisplayError(ExitCode);
  524.       gotoxy(20,2);
  525.       write('Run time error ',ExitCode);
  526.       gotoxy(4,4);
  527.       write('If you are unable to correct the error');
  528.       gotoxy(4,5);
  529.       write('Please report the error and exact');
  530.       gotoxy(4,6);
  531.       write('circumstances when it occurred to us.');
  532.       gotoxy(4,7);
  533.       write( ' Press a key to continue ');
  534.       ErrorAddr:=nil;
  535.  
  536.       ExitProc:=ExitSave;
  537.       c:=readkey;
  538.     end;
  539.   Window(1,1,80,25);                         { restore the screen     }
  540.   textcolor(FGNorm);
  541.   textbackground(BGNorm);
  542.   Display^:=SaveScr^;
  543.   dispose(SaveScr);
  544.  
  545.   cursor(true);
  546.   textcolor(lightgray);
  547.   textbackground(black);
  548.  
  549.   SetIntVec($24,SaveInt24);
  550. end;
  551. (**************************************************************************)
  552. begin
  553.   InitErrs;
  554.   Version:=DosVer;
  555.   cursor(false);
  556.   GetIntVec($24,SaveInt24);
  557.   SetIntVec($24,@CritError);
  558.   ExitSave:=ExitProc;
  559.   ExitProc:=@RuntimeError;
  560. end.