home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ETRAP8.ZIP / ETRAP8.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-04-22  |  17.3 KB  |  500 lines
  1. {$I- $F+}
  2. Unit Etrap8;
  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. type
  30.   XTCoord=1..80;   { X Text coordinate }
  31.   YTCoord=1..25;   { Y Text coordinate }
  32.   XTCoord0=0..80;  { X Text coordinate + 0 for nothing }
  33.   YTCoord0=0..25;  { Y Text coordinate + 0 for nothing }
  34.   WindowRec=Record
  35.               XSize: XTCoord;
  36.               YSize: YTCoord;
  37.               XPosn: XTCoord;
  38.               YPosn: YTCoord;
  39.               Contents: Array [0..1999] Of Integer;
  40.             End;
  41.   WindowPtr=^WindowRec;
  42.   string80=string[80];
  43.  
  44. var
  45.   ExitSave:pointer;
  46.   regs:registers;
  47.  
  48.  
  49. {$I crsrst.inc }
  50. {$I keydefs.inc }
  51. {$I getakey.inc }
  52. {$I constr.inc }
  53. {$I movfrscr.inc }
  54. {$I mov2scr.inc }
  55. {$I scrwrite.inc }
  56. {$I windptr.inc }
  57. {$I blankbox.inc }
  58. {$I box.inc }
  59. {$I mkwin.inc }
  60. {$I rmwin.inc }
  61. (**************************************************************************)
  62.  
  63. const
  64.  INT59ERROR  : integer  = 0;
  65.  ERRORACTION : byte = 0;
  66.  ERRORTYPE   : byte =0;
  67.  ERRORAREA   : byte =0;
  68.  ERRORRESP   : byte =0;
  69.  ERRORRESULT : integer=0;
  70.  
  71. type
  72. errmsg         = array [0..89] of string;
  73. ermsgPtr       =^errmsg;
  74.  
  75. var
  76. Errs:ermsgPTR;
  77.  
  78. function DosVer:integer;
  79. var
  80.  Maj:shortint;
  81.  Min:shortint;
  82.  regs:registers;
  83.  
  84. begin
  85.  regs.ah:=$30;
  86.  MsDos(Regs);
  87.  Maj:=regs.al;
  88.  Min:=regs.ah;
  89.  DosVer:=Maj;
  90. end;
  91.  
  92. procedure InitErrs;
  93. begin
  94. new(Errs);
  95. Errs^[0]:=   '             No error occured           ';
  96. Errs^[1]:=    '          Invalid function number       ';
  97. Errs^[2]:=    '              File not found            ';
  98. Errs^[3]:=    '              Path not found            ';
  99. Errs^[4]:=    '            No handle available         ';
  100. Errs^[5]:=    '              Access denied             ';
  101. Errs^[6]:=    '             Invalid handle             ';
  102. Errs^[7]:=    '     Memory control blocks destroyed    ';
  103. Errs^[8]:=    '           Insufficient memory          ';
  104. Errs^[9]:=    '      Invalid memory block address      ';
  105. Errs^[10]:=    '       Invalid SET command string       ';
  106. Errs^[11]:=    '             Invalid format             ';
  107. Errs^[12]:=    '          Invalid access code           ';
  108. Errs^[13]:=    '              Invalid data              ';
  109. Errs^[14]:=    '                Reserved                ';
  110. Errs^[15]:=    '       Invalid drive specification      ';
  111. Errs^[16]:=    '   Attempt to remove current directory  ';
  112. Errs^[17]:=    '             Not same device            ';
  113. Errs^[18]:=    '        No more files to be found       ';
  114. Errs^[19]:=    '          Disk write protected          ';
  115. Errs^[20]:=    '            Unknown unit ID             ';
  116. Errs^[21]:=    '          Disk drive not ready          ';
  117. Errs^[22]:=    '          Command not defined           ';
  118. Errs^[23]:=    '            Disk data error             ';
  119. Errs^[24]:=    '      Bad request structure length      ';
  120. Errs^[25]:=    '             Disk seek error            ';
  121. Errs^[26]:=    '         Unknown disk media type        ';
  122. Errs^[27]:=    '          Disk sector not found         ';
  123. Errs^[28]:=    '          Printer out of paper          ';
  124. Errs^[29]:=    '      Write error - Printer Error?      ';
  125. Errs^[30]:=    '               Read error               ';
  126. Errs^[31]:=    '            General failure             ';
  127. Errs^[32]:=    '         File sharing violation         ';
  128. Errs^[33]:=    '         File locking violation         ';
  129. Errs^[34]:=    '          Improper disk change          ';
  130. Errs^[35]:=    '             No FCB available           ';
  131. Errs^[36]:=    '         Sharing buffer overflow        ';
  132. Errs^[37]:=    '                Reserved                ';
  133. Errs^[38]:=    '                Reserved                ';
  134. Errs^[39]:=    '                Reserved                ';
  135. Errs^[40]:=    '                Reserved                ';
  136. Errs^[41]:=    '                Reserved                ';
  137. Errs^[42]:=    '                Reserved                ';
  138. Errs^[43]:=    '                Reserved                ';
  139. Errs^[44]:=    '                Reserved                ';
  140. Errs^[45]:=    '                Reserved                ';
  141. Errs^[46]:=    '                Reserved                ';
  142. Errs^[47]:=    '                Reserved                ';
  143. Errs^[48]:=    '                Reserved                ';
  144. Errs^[49]:=    '                Reserved                ';
  145. Errs^[50]:=    '      Network request not supported     ';
  146. Errs^[51]:=    '      Remote computer not listening     ';
  147. Errs^[52]:=    '        Duplicate name on network       ';
  148. Errs^[53]:=    '         Network name not found         ';
  149. Errs^[54]:=    '             Network busy               ';
  150. Errs^[55]:=    '      Network device no longer exists   ';
  151. Errs^[56]:=    '      NetBIOS command limit exceeded    ';
  152. Errs^[57]:=    '      Network adapter hardware error    ';
  153. Errs^[58]:=    '      Incorrect response from network   ';
  154. Errs^[59]:=    '        Unexpected network error        ';
  155. Errs^[60]:=    '      Incompatible remote adapter       ';
  156. Errs^[61]:=    '            Print queue full            ';
  157. Errs^[62]:=    '      Not enough space for print file   ';
  158. Errs^[63]:=    '         Print file was deleted         ';
  159. Errs^[64]:=    '        Network name was deleted        ';
  160. Errs^[65]:=    '             Access denied              ';
  161. Errs^[66]:=    '       Network device type incorrect    ';
  162. Errs^[67]:=    '          Network name not found        ';
  163. Errs^[68]:=    '        Network name limit exceeded     ';
  164. Errs^[69]:=    '      NetBIOS session limit exceeded    ';
  165. Errs^[70]:=    '           Temporarily paused           ';
  166. Errs^[71]:=    '       Network request not accepted     ';
  167. Errs^[72]:=    '  Print or disk re-direction is paused  ';
  168. Errs^[73]:=    '                Reserved                ';
  169. Errs^[74]:=    '                Reserved                ';
  170. Errs^[75]:=    '                Reserved                ';
  171. Errs^[76]:=    '                Reserved                ';
  172. Errs^[77]:=    '                Reserved                ';
  173. Errs^[78]:=    '                Reserved                ';
  174. Errs^[79]:=    '                Reserved                ';
  175. Errs^[80]:=    '           File already exists          ';
  176. Errs^[81]:=    '                Reserved                ';
  177. Errs^[82]:=    '              Cannot make               ';
  178. Errs^[83]:=    '     Critical-error interrupt failure   ';
  179. Errs^[84]:=    '          Too many redirections         ';
  180. Errs^[85]:=    '          Duplicate redirection         ';
  181. Errs^[86]:=    '           Duplicate password           ';
  182. Errs^[87]:=    '            Invalid parameter           ';
  183. Errs^[88]:=    '            Network data fault          ';
  184. Errs^[89]:=    '             Undefined Error            ';
  185. end;
  186.  
  187. procedure CritError(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:WORD);
  188.  INTERRUPT;
  189.  
  190. var
  191.   c         :char;
  192.   ErrorPrompt,
  193.   msg        :string;
  194.   ErrNum     :byte;
  195.  
  196.   ErrWin:WindowPTR;
  197.  
  198.   drive,
  199.   area,
  200.   al,ah      :byte;
  201.  
  202.   deviceattr :^word;
  203.   devicename :^char;
  204.   ch,
  205.   i          :shortint;
  206.   actmsg,
  207.   tmsg,
  208.   amsg,
  209.   dname      :string;
  210. begin
  211.     ah:=hi(ax);
  212.     al:=lo(ax);                            { in case DOS version < 3     }
  213.     ErrNum:=lo(DI)+19;                     { save the error and add      }
  214.     msg:=Errs^[ErrNum];                    { add 19 to convert to        }
  215.                                            { standard DOS error          }
  216.     tmsg:='';
  217.     actmsg:='';                            { we can't suggest a response }
  218.  
  219.  if (ah and $80)=0 then                    { if a disk error then        }
  220.    begin                                   { get the drive and area      }
  221.      amsg:=' drive '+chr(al+65)+':';
  222.      area:=(ah and 6) shr 1;
  223.      case area of
  224.      0:amsg:=amsg+' dos communications area ';
  225.      1:amsg:=amsg+' disk directory area ';
  226.      2:amsg:=amsg+' files area ';
  227.      end;
  228.    end
  229. else                                       { else if a device error }
  230.    begin                                   { get type of device     }
  231.      deviceattr:=ptr(bp,si+4);
  232.      i:=0;
  233.      if (deviceattr^ and $8000)<>0 then     { if a character device }
  234.        begin                                { like a printer        }
  235.          amsg:='character device';
  236.          ch:=0;
  237.          repeat
  238.          i:=i+1;
  239.          devicename:=ptr(bp,si+$0a+ch);      { get the device name  }
  240.          dname[i]:=devicename^;
  241.          dname[0]:=chr(i);
  242.          inc (ch);
  243.          until (devicename^ = chr(0)) or (ch>7);
  244.        end
  245.     else                                     { else }
  246.       begin                                  { just inform of the error }
  247.         dname:='disk in '+chr(al)+':';
  248.         msg:= ' general failure ' ;
  249.         end;
  250.      amsg:=amsg+' '+dname;
  251.      end;
  252.  
  253.  inline($FA);                           { Enable interrupts       }
  254.  MkWin(ErrWin,15,20,15,65,FGErr,BGErr);
  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. scrwrite('Critical Error',34,15,FGErr,BGErr);
  322. scrwrite(msg,(80-length(msg)) div 2,16,FGErr,BGErr);
  323. scrwrite(amsg,(80-length(amsg)) div 2,17,FGErr,BGErr);
  324. scrwrite(actmsg,(80-length(actmsg)) div 2,19,FGErr,BGErr);
  325.  
  326. ErrorPrompt:=' I)gnore R)etry A)bort F)ail ? ';
  327. scrwrite(ErrorPrompt,(80-length(ErrorPrompt)) div 2,18,FGErr,BGErr);
  328.  
  329. repeat                                     { get the user response  }
  330. c:=readkey;
  331. c:=upcase(c);
  332. until c in ['A','R','I','F'];
  333. RmWin(ErrWin);
  334. case c of
  335.   'I':begin
  336.         AX:=0;
  337.         ERRORRETRY:=false;
  338.       end;
  339.   'R':begin
  340.         AX:=1;
  341.         ERRORRETRY:=true;
  342.       end;
  343.   'A':begin
  344.         Ax:=2;
  345.         ERRORRETRY:=false;
  346.         cursor(true);
  347.       end;
  348.   'F':begin
  349.         Ax:=3;
  350.         ERRORRETRY:=false;
  351.         cursor(true);
  352.       end;
  353. end;
  354.  
  355. end;{procedure CritError}
  356.  
  357. (**************************************************************************)
  358. procedure DisplayError(ErrNo:integer);
  359. var
  360. msg,
  361. exitmsg:string;
  362. begin
  363.     case ErrNo of
  364.     2:exitmsg:='File not found';
  365.     3:exitmsg:='Path not found';
  366.     4:exitmsg:='Too many open files';
  367.     5:exitmsg:='Access denied';
  368.     6:exitmsg:='Invalid file handle';
  369.     12:exitmsg:='Invalid file access code';
  370.     15:exitmsg:='Invalid drive';
  371.     16:exitmsg:='Cannot remove current directory';
  372.     17:exitmsg:='Cannot rename across drives';
  373.     100:exitmsg:='Disk read error';
  374.     101:exitmsg:='Disk write error - Disk Full ?';
  375.     102:exitmsg:='File not assigned';
  376.     103:exitmsg:='File not opened';
  377.     104:exitmsg:='File not open for input';
  378.     105:exitmsg:='File not open for output';
  379.     106:exitmsg:='Invalid numeric format';
  380.     150:exitmsg:='Disk is write protected';
  381.     151:exitmsg:='Unknown unit';
  382.     152:exitmsg:='Drive not ready';
  383.     153:exitmsg:='Unkown command';
  384.     154:exitmsg:='CRC error in data';
  385.     155:exitmsg:='Bad drive request structure length';
  386.     156:exitmsg:='Disk seek error';
  387.     157:exitmsg:='Unknown media type';
  388.     158:exitmsg:='Sector not found';
  389.     159:exitmsg:='Printer out of paper';
  390.     160:exitmsg:='Device write fault';
  391.     161:exitmsg:='Device read fault';
  392.     162:exitmsg:='Hardware failure';
  393.     200:exitmsg:='Division by zero';
  394.     201:exitmsg:='Range check error';
  395.     202:exitmsg:='Stack overflow';
  396.     203:exitmsg:='Heap overflow';
  397.     204:exitmsg:='Invalid pointer operation';
  398.     205:exitmsg:='Floating point overflow';
  399.     206:exitmsg:='Floating point underflow';
  400.     207:exitmsg:='Invalid floating point operation'
  401.     else exitmsg:='Unknown Error # ';
  402.     end;
  403.  
  404.   msg:=exitmsg;
  405.   scrwrite(msg,(80-length(msg)) div 2,16,FGErr,BGErr);
  406.  
  407. end;
  408.  
  409. procedure ErrTrap(ErrNo:integer);
  410.  
  411. var
  412.   ErrWin:WindowPTR;
  413.   c         :char;
  414.   ErrorPrompt,
  415.   msg:string;
  416.  
  417. begin
  418.  
  419.   MkWin(ErrWin,15,20,15,65,FGErr,BGErr);
  420.  
  421.   ErrorRetry:=true;
  422.   DisplayError(ErrNo);
  423.  
  424.                                           { display it              }
  425.  
  426. ErrorPrompt:=' I)gnore R)etry A)bort F)ail ? ';
  427. scrwrite(ErrorPrompt,(80-length(ErrorPrompt))div 2,18,FGErr,BGErr);
  428.  
  429. repeat                                     { get the user response  }
  430. c:=readkey;
  431. c:=upcase(c);
  432. until c in ['A','R','I','F'];
  433. case c of
  434.   'I':ErrorRetry:=false;
  435.   'R':ErrorRetry:=true;
  436.   'A':begin
  437.         ErrorRetry:=false;
  438.         cursor(true);
  439.       end;
  440.   'F':begin
  441.         ErrorRetry:=false;
  442.         cursor(true);
  443.       end;
  444.   end;
  445.   if ErrorRetry=false then
  446.     begin
  447.       scrwrite('If you are unable to correct the error',20,17,FGErr,BGErr);
  448.       scrwrite('please report the error and      ',20,18,FGErr,BGErr);
  449.      scrwrite('exact circumstances when it occurred to us.',18,19,FGErr,BGErr);
  450.  
  451.       ErrorAddr:=nil;
  452.       gotoxy(1,1);
  453.       cursor(true);
  454.       halt;
  455.     end;
  456.  RmWin(ErrWin);
  457. end;
  458.  
  459. procedure RuntimeError;
  460.  
  461. var
  462.  
  463.   c         :char;
  464.   ErrorPrompt,
  465.   s,msg:string;
  466.   ErrWin:WindowPTR;
  467.  
  468. begin
  469.   if ErrorAddr<>nil then
  470.     begin
  471.       MkWin(ErrWin,15,23,15,65,FGErr,BGErr);
  472.       scrwrite('Fatal  Error',34,15,FGErr,BGErr);
  473.       DisplayError(ExitCode);
  474.       str(ExitCode,s);
  475.       scrwrite('Run time error '+s ,30,16,FGErr,BGErr);
  476.       scrwrite('If you are unable to correct the error',22,17,FGErr,BGErr);
  477.       scrwrite('Please report the error and exact',22,18,FGErr,BGErr);
  478.       scrwrite('circumstances when it occurred to us.',22,19,FGErr,BGErr);
  479.       scrwrite( ' Press a key to continue ',28,20,FGErr,BGErr);
  480.       ErrorAddr:=nil;
  481.       ExitProc:=ExitSave;
  482.       c:=readkey;
  483.     end;
  484.   RmWin(ErrWin);
  485.   cursor(true);
  486.   textcolor(lightgray);
  487.   textbackground(black);
  488.  
  489.   SetIntVec($24,SaveInt24);
  490. end;
  491. (**************************************************************************)
  492. begin
  493.   InitErrs;
  494.   Version:=DosVer;
  495.   cursor(false);
  496.   GetIntVec($24,SaveInt24);
  497.   SetIntVec($24,@CritError);
  498.   ExitSave:=ExitProc;
  499.   ExitProc:=@RuntimeError;
  500. end.