home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB40.ZIP / FILES.INC < prev    next >
Encoding:
Text File  |  1986-05-18  |  8.2 KB  |  217 lines
  1. Const
  2.   INT24Err  :  Boolean = False;
  3.   INT24ErrCode  :  Byte = 0;
  4.   OldINT24: Array [1..2] Of Integer=(0,0);
  5. Var
  6.   RegisterSet: Record Case Integer Of
  7.                  1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
  8.                  2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
  9.                End;
  10. { The Interupt 24 routines are designed to trap critical errors that generate }
  11. { the ABORT, RETRY, IGNORE messages.  These were originally written by        }
  12. { Marshall Brain and were revised by Bela Lubkin, Borland International       }
  13. { Technical Support.                                                          }
  14.  
  15. Procedure INT24;
  16.   Begin
  17.     { To understand this routine, you will need to read
  18.       the description on Interrupt 24 in the DOS manual.
  19.       It also helps to examine the generated code under DEBUG. }
  20.     Inline
  21.      ($2E/$C6/$06/ INT24Err /$01/$89/$EC/$83/$C4/$08/$89/$F8/$2E/$A2/
  22.       INT24ErrCode /$58/$B0/$FF/$5B/$59/$5A/$5E/$5F/$5D/$1F/$07/$CF);
  23.     { Turbo:  PUSH BP                    (Save caller's stack frame
  24.               MOV  BP,SP                   Set up this procedure's stack frame
  25.               PUSH BP                     ?)
  26.       Inline: MOV  BYTE CS:[INT24Err],1  Set INT24Err to True
  27.               MOV  SP,BP                 Get correct SP;  ADD: Discard saved
  28.               ADD  SP,8                    BP, INT 24 return address & flags
  29.               MOV  AX,DI                 Get INT 24 error code
  30.               MOV  CS:[INT24ErrCode],AL  Save it in INT24ErrCode
  31.               POP  AX                    Pop all registers
  32.               MOV  AL,0FFH               Set FCB call error flag:
  33.               POP  BX                      will cause Turbo I/O error on file
  34.               POP  CX                      operations, no error on character
  35.               POP  DX                      operations
  36.               POP  SI
  37.               POP  DI
  38.               POP  BP
  39.               POP  DS
  40.               POP  ES
  41.               IRET                       Return to next instruction }
  42.   End;
  43.  
  44. Procedure INT24On;  { Enable INT 24 trapping }
  45.   Begin
  46.     INT24Err:=False;
  47.     With RegisterSet Do
  48.      Begin
  49.       AX:=$3524;
  50.       MsDos(RegisterSet);
  51.       If (OldINT24[1] Or OldINT24[2])=0 Then
  52.        Begin
  53.         OldINT24[1]:=ES;
  54.         OldINT24[2]:=BX;
  55.        End;
  56.       DS:=CSeg;
  57.       DX:=Ofs(INT24);
  58.       AX:=$2524;
  59.       MsDos(RegisterSet);
  60.      End;
  61.   End;
  62.  
  63. Procedure INT24Off;  { Disable INT 24 trapping.  Should be done at the end
  64.                        of the program, if you plan to run the program from
  65.                        within the Turbo compiler.  If the INT 24 handler is
  66.                        left in place, and the compiler gets a critical
  67.                        error, the system is likely to crash. }
  68.   Begin
  69.     INT24Err:=False;
  70.     If OldINT24[1]<>0 Then
  71.       With RegisterSet Do
  72.        Begin
  73.         DS:=OldINT24[1];
  74.         DX:=OldINT24[2];
  75.         AX:=$2524;
  76.         MsDos(RegisterSet);
  77.        End;
  78.     OldINT24[1]:=0;
  79.     OldINT24[2]:=0;
  80.   End;
  81.  
  82. Procedure IOCheck (Var IOErr : Integer; Var ErrTxt : Str80);
  83. { This procedure checks IOResult for an error code.  If ErrOut is true then}
  84. { an error message is returned in ErrTxt, the error number is returned in}
  85. { the variable IOErr for further processing.}
  86. Var
  87.   St   : string[3];
  88.  
  89. Begin
  90.   IOErr := IOResult;
  91.   If INT24Err Then
  92.    Begin
  93.     IOErr :=IOErr+256*INT24ErrCode;
  94.     INT24On;
  95.    End;
  96.   If IOErr <> 0 then
  97.    begin
  98.     Case IOErr of
  99.       $01  :  ErrTxt := 'File does not exist.';
  100.       $02  :  ErrTxt := 'File not open for input.';
  101.       $03  :  ErrTxt := 'File not open for output.';
  102.       $04  :  ErrTxt := 'File not open.';
  103.       $05  :  ErrTxt := 'Can''t read from this file.';
  104.       $06  :  ErrTxt := 'Can''t write to this file.';
  105.       $10  :  ErrTxt := 'Error in numeric format.';
  106.       $20  :  ErrTxt := 'Operation not allowed on a logical device.';
  107.       $21  :  ErrTxt := 'Not allowed in direct mode.';
  108.       $22  :  ErrTxt := 'Assign to standard files not allowed.';
  109.       $90  :  ErrTxt := 'Record length mismatch.';
  110.       $91  :  ErrTxt := 'Seek beyond end of file.';
  111.       $99  :  ErrTxt := 'Unexpected end of file.';
  112.       $F0  :  ErrTxt := 'Disk write error.';
  113.       $F1  :  ErrTxt := 'Directory is full.';
  114.       $F2  :  ErrTxt := 'File size overflow.';
  115.       $FF  :  ErrTxt := 'File disappeared, can''t close.';
  116.       256  :  ErrTxt := 'Attempt to write on write protected disk.';
  117.       512  :  ErrTxt := 'Drive not ready, drive door open or bad drive.';
  118.       752  :  ErrTxt := 'Drive not ready, drive door open or bad drive.';
  119.       768  :  ErrTxt := 'Unknown unit, internal dos error.';
  120.      1024  :  ErrTxt := 'Unknown command, internal dos error.';
  121.      1280  :  ErrTxt := 'Data error (CRC), bad sector or drive.';
  122.      1536  :  ErrTxt := 'Bad request structure length, internal dos error.';
  123.      1792  :  ErrTxt := 'Seek error, bad disk or drive.';
  124.      2048  :  ErrTxt := 'Unknown media type, bad disk or drive.';
  125.      2304  :  ErrTxt := 'Sector not found, bad disk or drive.';
  126.      2560  :  ErrTxt := 'Printer not ready.';
  127.      2816  :  ErrTxt := 'Write fault, character device not ready.';
  128.      3072  :  ErrTxt := 'Read fault, character device not ready';
  129.      3328  :  ErrTxt := 'General failure, (..your guess..) several meanings.';
  130.     else begin
  131.            Str (IOErr, St);
  132.            ErrTxt := 'Unknown I/O error:  ' + St;
  133.          end; {Str/ErrTxt}
  134.     end; {Case of}
  135.    end  {begin}
  136.   else
  137.    ErrTxt := '';
  138. end; {IOCheck}
  139.  
  140.  
  141. Procedure OpenFile(Var FilVar : FileType; Var FileOpenErr : Str80;
  142.                        Extension : Str4);
  143. {  This procedure opens a file and assigns it to the file type FileVar.    }
  144. {  The input variable FileOpenErr is used to define the type of file to    }
  145. {  open by assigning it to (N)ew, (O)ld, or (A)dd.                         }
  146. {      (N)ew, (O)ld and (A)dd' will create a new file, open an old file or }
  147. {  open an old file and set the pointer to the end of the data respectively}
  148. {         For example by assigning FileOpenErr := (N)ew; a new file        }
  149. {  will be created.                     If a file with the same name is    }
  150. {  found the user will be asked if the file is to be overwritten.          }
  151. {  If an error is encountered in opening the file the text description of  }
  152. {  the error will be returned in the variable FileOpenErr.                 }
  153. {      A constant extension may be passed to this routine.  The constant   }
  154. {  extension will be superceded by any extension entered from the keyboard.}
  155. {  If no extension is passes to the routine and none is entered from the   }
  156. {  keyboard then a null extension is used:  '.   '                         }
  157.  
  158. Var
  159.   Filename : Str80;
  160.   NewOldAdd : Char;
  161.   IOErr     : Integer;
  162.   Ans       : integer;
  163.  
  164. Begin
  165. {$V-}
  166.   LowToUp(FileOpenErr);
  167.   NewOldAdd := copy(FileOpenErr,1,1);
  168.   Write('Enter name of file:  ');
  169.   Readln(Filename);
  170.   If Pos('.',Filename) = 0 then
  171.     begin
  172.       If Extension[1] <> '.' then Extension[1] := '.';
  173.       Filename := Filename + Extension;
  174.     end;
  175.   {$I-}
  176.   Assign(FilVar, Filename);
  177.   Reset(FilVar);
  178.   IOCheck(IOErr, FileOpenErr);
  179.   Case NewOldAdd of
  180.     'N'  :  begin
  181.                 If IOErr = $01 then
  182.                   begin
  183.                     Rewrite(FilVar);
  184.                     IOCheck(IOErr,FileOpenErr);
  185.                   end
  186.                 else
  187.                   if IOErr = $00 then
  188.                     begin
  189.                       Write('File already exists! Overwrite? (Y/N) ');
  190.                       Answer('Yes,No',Ans,false);
  191.                       if Ans = 1 then
  192.                         begin
  193.                          FileOpenErr := '';
  194.                          Rewrite(FilVar);
  195.                          IOCheck(IOErr,FileOpenErr);
  196.                         end
  197.                       else
  198.                         FileOpenErr := 'File Already Exists!';
  199.                     end;
  200.               end;
  201.     'A'  :  If IOErr = $00 then
  202.                 Seek(FilVar, FileSize(FilVar));
  203.   end;  {case}
  204.   {$I+}
  205.   {$V+}
  206. End; {OpenFile}
  207.  
  208. Procedure CloseFile(Var FilVar: FileType; Var FileErr: Str80);
  209. Var
  210.  IOErr : integer;
  211. Begin
  212.   {I-}
  213.   Close(FilVar);
  214.   {I+}
  215.   IOCheck(IOErr,FileErr);
  216. End; {CloseFile}
  217.