home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / share / txtshare.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1988-01-09  |  10.6 KB  |  238 lines
  1. Unit TxtShare;
  2.  
  3. {$F+}
  4.  
  5. { This UNIT implements a TEXT file device driver to access TEXT files with a   }
  6. { user specified access mode (see DOS Technical Reference for DOS function     }
  7. { 3Dh).  This can be accomplished for non-TEXT files by setting the standard   }
  8. { global variable "FileMode" (part of the System unit) to the desired mode     }
  9. { value, and then calling the appropriate open function. This is not supported }
  10. { for TEXT files in Turbo Pascal v4.0.                                         }
  11.  
  12. { To open a Text file with a user specified access mode, place a call to the   }
  13. { procedure AssignText to associate a filename with the text file variable.    }
  14. { Next, set the standard global variable FileMode with the desired DOS access  }
  15. { mode.  RESET, REWRITE, and APPEND will now use the access mode assinged to   }
  16. { the FileMode variable when opening the file.                                 }
  17.  
  18. Interface
  19.  
  20. Uses Dos;
  21.  
  22. Var
  23.    WriteTextEofChar : Boolean;
  24.  
  25. Procedure AssignText(Var F : Text; FileName : String);
  26.  
  27. Implementation
  28.  
  29. {$R-,S-}
  30.  
  31. Function ReadText(Var F : TextRec) : Word;
  32. Var
  33.    Regs    : Registers;
  34. Label
  35.    Quit;
  36. Begin
  37.    With F, Regs do begin
  38.       AH := $3F;                     { DOS read from file or device function  }
  39.       BX := Handle;                  { BX = file handle                       }
  40.       DS := Seg(BufPtr^);            { DS:DX = buffer address                 }
  41.       DX := Ofs(BufPtr^);
  42.       CX := BufSize;                 { CX = number of bytes to be read        }
  43.       MsDos(Regs);                   { Read the file                          }
  44.       If Flags AND fCarry <> 0 then  { Any errors?                            }
  45.          Goto Quit;                  { Yes.  Return Error Code (in AX)        }
  46.       BufPos := 0;                   { Reset buffer ptr to 1st char.          }
  47.       BufEnd := AX;                  { AX = number of bytes actually read     }
  48.       AX     := 0;                   { Success - Return 0 as function result  }
  49.    end {with};
  50. Quit:
  51.    ReadText := Regs.AX;              { AX contains function result            }
  52. End {ReadText};
  53.  
  54. Function WriteText(Var F : TextRec) : Word;
  55. Var
  56.    Regs    : Registers;
  57. Label
  58.    Quit;
  59. Begin
  60.    With F, Regs do begin
  61.       AH := $40;                     { DOS write to file or device function   }
  62.       BX := Handle;                  { BX = file handle                       }
  63.       DS := Seg(BufPtr^);            { DS:DX = address of characters to be    }
  64.       DX := Ofs(BufPtr^);            {    written.                            }
  65.       CX := BufPos;                  { CX = number of characters to write     }
  66.       MsDos(Regs);                   { Write bufPos characters to the file    }
  67.       If Flags AND fCarry <> 0 then  { Any errors?                            }
  68.          Goto Quit;                  { Yes.  Return Error Code (in AX)        }
  69.       BufPos := 0;                   { Reset buffer ptr to 1st char.          }
  70.       BufEnd := 0;                   { Buffer is now empty                    }
  71.       AX := 0;                       { Success - Return 0 as function result  }
  72.    end {with};
  73. Quit:
  74.    WriteText := Regs.AX;             { AX contains function result            }
  75. End {WriteText};
  76.  
  77. Function DoNothing(Var F : TextRec) : Word;
  78. Begin
  79.    DoNothing := 0;                   { Do nothing.  Always return success (0) }
  80. End {DoNothing};
  81.  
  82. Function SeekEofText(Var F : TextRec) : Word;
  83. Var
  84.    Regs    : Registers;
  85.    FilePos : LongInt;
  86. Label
  87.    Quit;
  88. Begin
  89.    With F, Regs do begin
  90.       AH := $42;                     { DOS LSEEK function                     }
  91.       AL := $02;                     { AL = method (EOF + offset)             }
  92.       BX := Handle;                  { BX = file handle                       }
  93.       CX := $00;                     { CX:DX = offset                         }
  94.       DX := $00;
  95.       MsDos(Regs);                   { Move file ptr - DX:AX = new file pos.  }
  96.       If Flags AND fCarry <> 0 then  { Any errors?                            }
  97.          Goto Quit;                  { Yes.  Return Error Code (in AX)        }
  98.  
  99.       FilePos := (DX shl 16) + AX;   { Calculate absolute file ptr position   }
  100.       If FilePos >= 128 then         { Recalculate position to be able to     }
  101.          Dec(FilePos, 128)           { read the last 128 bytes of the file ...}
  102.       else                           { ... or, if file has fewer bytes, read  }
  103.          FilePos := 0;               { the whole thing                        }
  104.       AH := $42;                     { DOS LSEEK function                     }
  105.       AL := $00;                     { AL = method (absolute)                 }
  106.       BX := Handle;                  { BX = file handle                       }
  107.       CX := FilePos shr 16;          { CX:DX = offset                         }
  108.       DX := (FilePos shl 16) shr 16;
  109.       MsDos(Regs);                   { Move file ptr                          }
  110.       If Flags AND fCarry <> 0 then  { Any errors?                            }
  111.          Goto Quit;                  { Yes.  Return Error Code (in AX)        }
  112.  
  113.       AX := ReadText(F);             { Read last 128 bytes of the file        }
  114.       If AX <> 0 then                { Any errors?                            }
  115.          Goto Quit;                  { Yes.  Return Error Code (in AX)        }
  116.  
  117.       While (BufPos < BufEnd) and (Buffer[BufPos] <> #26) do
  118.          BufPos := Succ(BufPos);     { Look for an EOF character (ascii 26)   }
  119.  
  120.       If BufPos < Bufend then begin  { If found, truncate file at that point  }
  121.          FilePos := FilePos + BufPos;
  122.          AH := $42;                  { Move file pointer to the EOF character }
  123.          AL := $00;
  124.          BX := Handle;
  125.          CX := FilePos shr 16;
  126.          DX := (FilePos shl 16) shr 16;
  127.          MsDos(Regs);
  128.          If Flags AND fCarry <> 0 then
  129.             Goto Quit;
  130.  
  131.          BufPos := 0;
  132.          AX := WriteText(F);         { Write 0 bytes (ie. truncate the file)  }
  133.          If AX <> 0 then
  134.             Goto Quit;
  135.       end {if};
  136.  
  137.       AX := 0;                       { No errors, so return result = 0       }
  138.  
  139.    end {with};
  140. Quit:
  141.    SeekEofText := Regs.AX;
  142. End {SeekEofText};                   { AX contains function result            }
  143.  
  144. Function CloseText(Var F : TextRec) : Word;
  145. Var
  146.    Regs : Registers;
  147. Label
  148.    Quit;
  149. Begin
  150.    With F, Regs do begin
  151.       If (Mode = fmOutput) and       { If opened with rewrite or append       }
  152.          WriteTextEofChar then begin { then write an EOF character before     }
  153.          Buffer[0] := #26;           { closing the file (but only if the var  }
  154.          BufPtr    := @Buffer;       { WriteTextEofChar is TRUE).             }
  155.          BufPos    := 1;
  156.          AX        := WriteText(F);
  157.          If AX <> 0 then
  158.             Goto Quit;
  159.       end {if};
  160.       AH := $3E;                     { DOS close a file handle function       }
  161.       BX := Handle;                  { BX = file handle                       }
  162.       MsDos(Regs);
  163.       If Flags AND fCarry = 0 then   { No errors, so function result = 0      }
  164.          AX := 0;
  165.       BufPos := 0;
  166.       BufEnd := 0;
  167.    end {with};
  168. Quit:
  169.    CloseText := Regs.AX;             { AX contains function result            }
  170. End {CloseText};
  171.  
  172. Function OpenText(Var F : TextRec) : Word;
  173. Var
  174.    Regs : Registers;
  175. Label
  176.    Quit;
  177. Begin
  178.    With F, Regs do begin
  179.       If Mode = fmOutput then        { If REWRITE, Create or Truncate to 0    }
  180.          AH := $3C                   { DOS CREAT function                     }
  181.       else                           { If RESET or APPEND, just open existing }
  182.          AH := $3D;                  { DOS open a file function               }
  183.       AL := FileMode;                { File access mode to use                }
  184.       CX := 0;                       { File Attribute (for CREAT func only)   }
  185.       DS := Seg(Name);               { DS:DX = address of asciiz filename     }
  186.       DX := Ofs(Name);
  187.       MsDos(Regs);
  188.       If Flags AND fCarry <> 0 then  { Any errors?                            }
  189.          Goto Quit;                  { Yes.  Return Error Code (in AX)        }
  190.       Handle := AX;                  { Set file handle                        }
  191.       AX := 0;                       { AX will hold function result           }
  192.       CloseFunc := @CloseText;       { Set close function                     }
  193.       If Mode = fmInOut then begin   { If opened with APPEND ...              }
  194.          AX := SeekEofText(F);       { ... reposition to end of file          }
  195.          If AX = 0 then              { If no error ...                        }
  196.             Mode := fmOutput         { Set Output Only mode                   }
  197.          Else                        { Error in SeekEofText function          }
  198.             Goto Quit;               { Return with error code (in AX)         }
  199.       end {if};
  200.       If Mode = fmInput then begin   { Opened with RESET                      }
  201.          InOutFunc := @ReadText;     { Set Input Function                     }
  202.          FlushFunc := @DoNothing;    { Set Flush Function                     }
  203.       end {then}
  204.       else begin                     { Opened with REWRITE                    }
  205.          InOutFunc := @WriteText;    { Set Output Function                    }
  206.          FlushFunc := @DoNothing;    { Set Flush Function                     }
  207.       end {if};
  208.       BufPos := 0;                   { Reset buffer ptr to 1st char.          }
  209.       BufEnd := 0;                   { Buffer is now empty                    }
  210.    end {with};
  211. Quit:
  212.    OpenText := Regs.AX;              { AX contains function result            }
  213. End {OpenText};
  214.  
  215.  
  216. Procedure AssignText(Var F : Text; FileName : String);
  217. Var
  218.    I : Integer;
  219. Begin
  220.    With TextRec(F) do begin               { Initialize textrec record         }
  221.       Handle   := $FFFF;                  { Set file handle to junk           }
  222.       Mode     := fmClosed;               { Indicate the file is not yet open }
  223.       BufSize  := SizeOf(Buffer);         { Set size of default buffer (128)  }
  224.       BufPtr   := @Buffer;                { Set up pointer to default buffer  }
  225.       OpenFunc := @OpenText;              { Set up pointer to OPEN function   }
  226.       For I := 1 to Length(FileName) do   { Set up asciiz filename            }
  227.          Name[I-1] := FileName[I];
  228.       Name[Length(FileName)] := Chr(0);
  229.    End {with};
  230. End {AssignText};
  231.  
  232. Begin
  233.    { Initialize global variable to suppress writing ^Z at the end of any     }
  234.    { text file opened with Append or Rewrite.                                }
  235.    WriteTextEofChar := FALSE;
  236. End {Unit TxtShare}.
  237.  
  238.