Black Box 4/BlackBox.cdr/w3_prog/stream11.arj/STREAMS.PAS

Pascal/Delphi Source File | 1992-03-31 | 39.8 KB | 1,443 lines

unit Streams;

{ Unit to provide enhancements to TV Objects unit streams in the form
  of several filters, i.e. stream clients, and other streams. }

{$O-}
  { Don't overlay this unit; it contains code that needs to participate
         in overlay management. }

{  Hierarchy:

   TStream                  (from Objects)
     TFilter                Base type for filters
       TEncryptFilter       Encrypts as it writes; decrypts as it reads
       TLZWFilter           Compresses as it writes; expands as it reads
       TTextFilter          Provides text file interface to stream
       TLogFilter           Provides logging of text file activity
     TRAMStream             Stream in memory
     TDOSStream             (from Objects)
       TBufStream           (from Objects)
         TNamedBufStream    Buffered file stream that knows its name
           TTempBufStream   Buffered file stream that erases itself when done

   Procedures & functions:

   TempStream      allocates a temporary stream
   OvrInitStream   like OvrInitEMS, but buffers overlays on a stream
                   May be called several times to buffer different
                   segments on different streams.
   OvrDetachStream detaches stream from overlay system
   OvrDisposeStreams detaches all streams from overlay system and disposes of
                   them
   OvrSizeNeeded   Calculates the size needed to load the rest of the segments
                   to a stream
   OvrLoadAll      immediately copies as many overlay segments to the stream
                   as will fit

}

interface

{$ifdef windows}
uses strings,windos,winprocs,wobjects;
{$else}
uses DOS, Overlay, Objects;
{$endif}

const
  stBadMode = 1;                  { Bad mode for stream - operation not supported }
  stStreamFail = 2;               { Stream init failed }
  stBaseError = 3;                { Error in base stream }
  stMemError = 4;                 { Not enough memory for operation }
  stSigError = 5;                 { Problem with LZ file signature }

type
  TOpenMode = $3C00..$3DFF;       { Allowable DOS stream open modes }
  {$ifdef windows}
  FNameStr = PChar;            { To make streams take names as in the manual }
  {$endif}

  PFilter = ^TFilter;
  TFilter =
    object(TStream)
    { Generic object to filter another stream.  TFilter just passes everything
      through, and mirrors the status of the base stream }

      Base : PStream;
      { Pointer to the base stream. }

      Startofs : LongInt;
      { The offset of the start of the filter in the base stream. }

      constructor Init(ABase : PStream);
        { Initialize the filter with the given base. }

      destructor Done; virtual;
        { Dispose of base. }

      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Truncate; virtual;
      procedure Write(var Buf; Count : Word); virtual;

      function CheckStatus : Boolean; virtual;
    { Return true if status is stOK.
      If status is stOK, but base is not, then reset the base.  This is a poor
      substitute for a virtual Reset method. }

      procedure CheckBase;
        { Check base stream for error, and copy status using own Error method. }
    end;

  PEncryptFilter = ^TEncryptFilter;
  TEncryptFilter =
    object(TFilter)
  { Filter which encrypts text going in or out; encrypting twice with the same
    key decrypts. Not very sophisticated encryption. }

      Key : LongInt;
      { Key is used as a Randseed replacement }

      constructor Init(Akey : LongInt; ABase : PStream);
        { Init with a given key }

      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

const
  MaxStack = 4096;                { must match lzwstream.asm declaration! }

type
  Plzwtables = ^TLZWTables;
  TLZWTables =
    record
      Collision : array[0..MaxStack-1] of Byte; { Hash table entries }
      PrefixTable : array[0..MaxStack-1] of Word; { Code for preceding stringf }
      SuffixTable : array[0..MaxStack-1] of Byte; { Code for current character }
      ChildTable : array[0..MaxStack-1] of Word; { Next duplicate in collision
                                                 list }
      CharStack : array[0..MaxStack-1] of Byte; { Decompression stack }
      StackPtr : Word;            { Decompression stack depth }
      Prefix : Word;              { Previous code string }
      TableUsed : Word;           { # string table entries used }
      InputPos : Word;            { Index in input buffer }
      OutputPos : Word;           { Index in output buffer }
      LastHit : Word;             { Last empty slot in collision
                                                 table }
      CodeBuf : Word;
      SaveIP : Word;
      SaveAX : Word;
      SaveCX : Word;
      SaveDX : Word;

      NotFound : Byte;            { Character combination found
                                                 flag }
    end;

  PLZWFilter = ^TLZWFilter;
  TLZWFilter =
    object(TFilter)
      Mode : Word;                { Either stOpenRead or stOpenWrite. }
      Size,                       { The size of the expanded stream. }
      Position : LongInt;         { The current position in the expanded stream }
      Tables : Plzwtables;        { Tables holding the compressor state. }

      constructor Init(ABase : PStream; AMode : TOpenMode);
    {  Create new compressor stream, to use ABase as the source/destination
       for data.  Mode must be stOpenRead or stOpenWrite. }

      destructor Done; virtual;
    {  Flushes all data to the stream, and writes the uncompressed
       filesize to the head of it before calling TFilter.done. }

      procedure Flush; virtual;
      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;

      procedure Seek(Pos : LongInt); virtual;
    {  Seek is not supported at all in Write mode.  In Read mode, it is
       slow for seeking forwards, and very slow for seeking backwards:
       it rewinds the file to the start and seeks forward from there. }

      procedure Truncate; virtual;
    {  Truncate is not supported in either mode, and always causes a
       call to Error. }

      procedure Write(var Buf; Count : Word); virtual;
    end;

type
  PTextFilter = ^TTextFilter;
  TTextFilter =
    object(TFilter)
  { A filter to provide ReadLn/WriteLn interface to a stream.  First
    open the stream and position it, then pass it to this filter;
    then Reset, Rewrite, or Append the Textfile variable, and do all
    reads and writes to it; they'll go to the stream through a TFDD. }

      Textfile : Text;
      { The fake text file to use with Read(ln)/Write(ln) }

      constructor Init(ABase : PStream; AName : String);
    { Initialize the interface to ABase; stores AName in the name field of
      Textfile. }

      destructor Done; virtual;
        { Flushes the Textfile, then closes and disposes of the base stream. }
    end;

  PLogFilter = ^TLogFilter;
  TLogFilter =
    object(TFilter)
      { A filter to log activity on a text file. }

      LogList : ^Text;            { A pointer to the first logged file }

      destructor Done; virtual;
        { Stops logging all files, and closes & disposes of the base stream }

      procedure Log(var F : Text);
    { Logs all input and output to F to the stream.  You must do the Assign to
      F first, and not do another Assign without closing F. }

      function Unlog(var F : Text) : Boolean;
    { Stops logging of F.  Called automatically if file is closed. Returns
      false and does nothing on error. }
    end;

  Pbyte_array = ^Tbyte_array;
  Tbyte_array = array[0..65520] of Byte; { Type used as a buffer. }

  PRAMStream = ^TRAMStream;
  TRAMStream =
    object(TStream)
      CP : Word;    { The current pointer for the stream. }

      Size : Word;  { The current size of the stream. }
      Alloc : Word; { The size of the allocated block of memory. }

      Buffer : Pbyte_array;
      { A pointer to the block of memory holding the stream data. }

      constructor Init(Asize : Word);
    { Attempt to initialize the stream to a block size of Asize;
       initial stream size and position are 0. }

      destructor Done; virtual;
        { Dispose of the stream. }

      function GetPos : LongInt; virtual;
      function GetSize : LongInt; virtual;
      procedure Read(var Buf; Count : Word); virtual;
      procedure Seek(Pos : LongInt); virtual;
      procedure Truncate; virtual;
      procedure Write(var Buf; Count : Word); virtual;
    end;

  PNamedBufStream = ^TNamedBufStream;
  TNamedBufStream =
    object(TBufStream)
      { A simple descendant of TBufStream which knows its own name. }

    {$ifdef windows}
    filename : PChar;
    {$else}
      Filename : PString;
    {$endif}
      { The name of the stream. }

      constructor Init(Name : FNameStr; Mode : TOpenMode; ABufSize : Word);
        { Open the file with the given name, and save the name. }

      destructor Done; virtual;
        { Close the file. }

    end;

  PTempBufStream = ^TTempBufStream;
  TTempBufStream =
    object(TNamedBufStream)
      { A temporary buffered file stream, which deletes itself when done.}

      constructor Init(ABufSize : Word);
  { Create a temporary file with a unique name, in the directory
    pointed to by the environment varable TEMP or in the current
    directory, and open it in read/write mode.   }

      destructor Done; virtual;
        { Close and delete the temporary file. }

    end;

type
  TStreamType = (NoStream, RAMStream, EMSStream, FileStream);
  { The type of stream that a tempstream might be. }

const
  NumTypes = Ord(FileStream);
  BufSize : Word = 2048;          { Buffer size if buffered stream is used. }

type
  TStreamRanking = array[1..NumTypes] of TStreamType;
  { A ranking of preference for a type of stream, from most to least preferred }

const ForSpeed : TStreamRanking = (RAMStream, EMSStream, FileStream);
  { Streams ordered for speed }

const ForSize : TStreamRanking = (FileStream, EMSStream, RAMStream);
  { Streams ordered for low impact on the heap }

const ForSizeInMem : TStreamRanking = (EMSStream, RAMStream, NoStream);
  { Streams in memory only, ordered as #ForSize#. }

const ForOverlays : TStreamRanking = (EMSStream, FileStream, NoStream);
  { Streams ordered for speed, but never in RAM. }

function TempStream(InitSize, MaxSize : LongInt;
                    Preference : TStreamRanking) : PStream;

{      This procedure returns a pointer to a temporary stream from a
       choice of 3, specified in the Preference array.  The first stream
       type listed in the Preference array which can be successfully
       created with the given sizes will be returned, or Nil if none can
       be made. }

procedure OvrInitStream(S : PStream);
{ Copies overlay segment code to S as new segments are loaded,
  and does reloads from there.  Allows multiple calls, to buffer
  different segments on different streams. }

procedure OvrDetachStream(BadS : PStream);
  { Makes sure that the overlay system makes no references to BadS. }

procedure OvrDisposeStreams;
  { Detaches and disposes of all streams being used by the overlay system }

function OvrSizeNeeded : LongInt;
{ Returns the size required to load any segments which still haven't
  been loaded to a stream. }

function OvrLoadAll : Boolean;
{ Forces all overlay segments to be copied into the stream; if successful
  (true) then no more references to the overlay file will be made. }

implementation

  constructor TFilter.Init(ABase : PStream);
  begin
    TStream.Init;
    Base := ABase;
    CheckBase;
    if Status = stOK then
      Startofs := Base^.GetPos;
  end;

  destructor TFilter.Done;
  begin
    if Base <> nil then
      Dispose(Base, Done);
    TStream.Done;
  end;

  function TFilter.GetPos : LongInt;
  begin
    if CheckStatus then
    begin
      GetPos := Base^.GetPos-Startofs;
      CheckBase;
    end;
  end;

  function TFilter.GetSize : LongInt;
  begin
    if CheckStatus then
    begin
      GetSize := Base^.GetSize-Startofs;
      CheckBase;
    end;
  end;

  procedure TFilter.Read(var Buf; Count : Word);
  begin
    if CheckStatus then
    begin
      Base^.Read(Buf, Count);
      CheckBase;
    end;
  end;

  procedure TFilter.Seek(Pos : LongInt);
  begin
    if CheckStatus then
    begin
      Base^.Seek(Pos+Startofs);
      CheckBase;
    end;
  end;

  procedure TFilter.Truncate;
  begin
    if CheckStatus then
    begin
      Base^.Truncate;
      CheckBase;
    end;
  end;

  procedure TFilter.Write(var Buf; Count : Word);
  begin
    if CheckStatus then
    begin
      Base^.Write(Buf, Count);
      CheckBase;
    end;
  end;

  function TFilter.CheckStatus : Boolean;
  begin
    if (Status = stOK) and (Base^.Status <> stOK) then
      Base^.Reset;
    CheckStatus := Status = stOK;
  end;

  procedure TFilter.CheckBase;
  begin
    if Base^.Status <> stOK then
      Error(stBaseError, Base^.Status);
  end;

  constructor TEncryptFilter.Init(Akey : LongInt; ABase : PStream);
  begin
    TFilter.Init(ABase);
    Key := Akey;
  end;

  procedure TEncryptFilter.Read(var Buf; Count : Word);
  var
    i : Word;
    SaveSeed : LongInt;
    Bytes : Tbyte_array absolute Buf;
  begin
    SaveSeed := RandSeed;
    RandSeed := Key;
    TFilter.Read(Buf, Count);
    for i := 0 to Count-1 do
      Bytes[i] := Bytes[i] xor Random(256);
    Key := RandSeed;
    RandSeed := SaveSeed;
  end;

  procedure CycleKey(Key, Cycles : LongInt);
{ For cycles > 0, mimics cycles calls to the TP random number generator.
  For cycles < 0, backs it up the given number of calls. }
  var
    i : LongInt;
    Junk : Integer;
    SaveSeed : LongInt;
  begin
    if Cycles > 0 then
    begin
      SaveSeed := RandSeed;
      RandSeed := Key;
      for i := 1 to Cycles do
        Junk := Random(0);
      Key := RandSeed;
      RandSeed := Key;
    end
    else
      for i := -1 downto Cycles do
        Key := (Key-1)*(-649090867);
  end;

  procedure TEncryptFilter.Seek(Pos : LongInt);
  var
    OldPos : LongInt;
  begin
    OldPos := GetPos;
    TFilter.Seek(Pos);
    CycleKey(Key, Pos-OldPos);
  end;

  procedure TEncryptFilter.Write(var Buf; Count : Word);
  var
    i : Word;
    SaveSeed : LongInt;
    BufPtr : ^Byte;
    BufPtrOffset : Word absolute BufPtr;
    Buffer : array[0..255] of Byte;
  begin
    SaveSeed := RandSeed;
    RandSeed := Key;
    BufPtr := @Buf;
    while Count > 256 do
    begin
      Move(BufPtr^, Buffer, 256);
      for i := 0 to 255 do
        Buffer[i] := Buffer[i] xor Random(256);
      TFilter.Write(Buffer, 256);
      Dec(Count, 256);
      Inc(BufPtrOffset, 256);
    end;
    Move(BufPtr^, Buffer, Count);
    for i := 0 to Count-1 do
      Buffer[i] := Buffer[i] xor Random(256);
    TFilter.Write(Buffer, Count);
    Key := RandSeed;
    RandSeed := SaveSeed;
  end;


  { ******* LZW code ******* }

{$L LZWSTREAM.OBJ}

  procedure Initialise(Tables : Plzwtables); External;

  function PutSignature(Tables : Plzwtables) : Boolean; External;

  function Crunch(InBufSize, OutBufSize : Word;
                  var InBuffer, OutBuffer;
  Tables : Plzwtables) : Pointer; External;

{  Crunch some more text.  Stops when Inbufsize bytes are used up, or
   output buffer is full.   Returns bytes used in segment, bytes written
   in offset of result }

  function FlushLZW(var OutBuffer;
  Tables : Plzwtables) : Word; External;
{  Flush the remaining characters to signal EOF.  Needs space for up to
   3 characters. }

  function GetSignature(var InBuffer, Dummy;
  Tables : Plzwtables) : Boolean; External;
{ Initializes for reading, and checks for 'LZ' signature in start of compressed
  code.  Inbuffer must contain at least 3 bytes.  Dummy is just there to put the
  Inbuffer in the right spot }

  function Uncrunch(InBufSize, OutBufSize : Word;
                    var InBuffer, OutBuffer;
  Tables : Plzwtables) : Pointer; External;
{  Uncrunch some text.  Will stop when it has done Outbufsize worth or has
   exhausted Inbufsize worth.  Returns bytes used in segment, bytes written
   in offset of result }

  constructor TLZWFilter.Init(ABase : PStream; AMode : TOpenMode);
    {  Create new compressor stream, to use ABase as the source/destination
       for data.  Mode must be stOpenRead or stOpenWrite. }
  var
    Out : LongInt;
    Buffer : array[1..3] of Byte;
    Info : Integer;
  begin
    Info := stBadMode;
    if (AMode = stOpenRead) or (AMode = stOpenWrite) then
    begin
      Info := stStreamFail;
      if TFilter.Init(ABase) then
      begin
        if Status = stOK then
        begin
          Info := stMemError;
          Startofs := Base^.GetPos;
          Position := 0;
          Mode := AMode;

          if MaxAvail >= SizeOf(TLZWTables) then
          begin
            Info := stSigError;
            GetMem(Tables, SizeOf(TLZWTables));
            Initialise(Tables);
            if Mode = stOpenRead then
            begin
              Base^.Read(Size, SizeOf(Size));
              Base^.Read(Buffer, 3);
              CheckBase;
              if GetSignature(Buffer, Buffer, Tables) then
                Exit;             { Successfully opened for reading }
            end
            else if Mode = stOpenWrite then
            begin
              Size := 0;
              Base^.Write(Size, SizeOf(Size)); { Put a place holder }
              CheckBase;
              if PutSignature(Tables) then
                Exit;             { Successful construction for writing! }
            end;
          end;
        end;
      end;
    end;
    Error(stInitError, Info);
  end;

  destructor TLZWFilter.Done;
  var
    Pos : LongInt;
  begin
    if CheckStatus and (Mode = stOpenWrite) then
      Flush;
    FreeMem(Tables, SizeOf(TLZWTables));
    TFilter.Done;
  end;

  procedure TLZWFilter.Write(var Buf; Count : Word);
  var
    Inbuf : array[0..65520] of Byte absolute Buf;
    Outbuf : array[0..255] of Byte;
    Inptr : Word;
    Sizes : record
              OutSize, UsedSize : Word;
            end;
  begin
    if CheckStatus then
    begin
      if Mode <> stOpenWrite then
        Error(stBadMode, Mode);
      Inptr := 0;
      repeat
        Pointer(Sizes) := Crunch(Count, SizeOf(Outbuf),
                                 Inbuf[Inptr], Outbuf, Tables);
        with Sizes do
        begin
          Base^.Write(Outbuf, OutSize);

          Dec(Count, UsedSize);
          Inc(Inptr, UsedSize);
          Inc(Size, UsedSize);
          Inc(Position, UsedSize);
        end;
      until Count = 0;
      CheckBase;
    end;
  end;

  procedure TLZWFilter.Flush;
  var
    Outbuf : array[0..255] of Byte;
    OutSize : Word;
    Sizes : record
              OutSize, UsedSize : Word;
            end;
    Pos   : longint;
  begin
    if CheckStatus then
    begin
      if Mode = stOpenWrite then
      begin
        Pointer(Sizes) := Crunch(1, SizeOf(Outbuf), Outbuf, Outbuf, Tables);
        { Push one more character to match JA bug }
        with Sizes do
        begin
          Base^.Write(Outbuf, OutSize);

          OutSize := FlushLZW(Outbuf, Tables); { And flush }
          Base^.Write(Outbuf, OutSize);
        end;
        Pos := Base^.GetPos;
        Base^.Seek(Startofs);
        Base^.Write(Size, SizeOf(Size));
        Base^.Seek(Pos);
      end;
      Base^.Flush;
      Mode := 0;
      CheckBase;
    end;
  end;

  procedure TLZWFilter.Read(var Buf; Count : Word);
  var
    Outbuf : array[0..65520] of Byte absolute Buf;
    Inbuf : array[0..255] of Byte;
    OutPtr : Word;
    BlockSize : Word;
    Sizes : record
              OutSize, UsedSize : Word;
            end;
    BytesLeft : LongInt;
  begin
    if CheckStatus then
    begin
      if Mode <> stOpenRead then
        Error(stBadMode, Mode);
      OutPtr := 0;
      BlockSize := SizeOf(Inbuf);
      with Base^ do
        BytesLeft := GetSize-GetPos;

      if Position+Count > Size then
      begin
        Error(stReaderror, 0);
        FillChar(Buf, Count, 0);
        Exit;
      end;

      while Count > 0 do
      begin
        if BytesLeft < BlockSize then
          BlockSize := BytesLeft;
        Base^.Read(Inbuf, BlockSize);
        Pointer(Sizes) := Uncrunch(BlockSize, Count, Inbuf,
                                   Outbuf[OutPtr], Tables);
        with Sizes do
        begin
          if OutSize = 0 then
          begin
            Error(stReaderror, 0);
            FillChar(Outbuf[OutPtr], Count, 0);
            Exit;
          end;
          Dec(BytesLeft, UsedSize);
          Inc(Position, OutSize);
          Dec(Count, OutSize);
          Inc(OutPtr, OutSize);
          if UsedSize < BlockSize then
            with Base^ do         { seek back to the first unused byte }
              Seek(GetPos-(BlockSize-UsedSize));
        end;
      end;
      CheckBase;
    end;
  end;

  procedure TLZWFilter.Seek(Pos : LongInt);
  var
    Buf : array[0..255] of Byte;
    Bytes : Word;
  begin
    if CheckStatus then
    begin
      if Mode <> stOpenRead then
      begin
        Error(stBadMode, Mode);
        Exit;
      end;
      if Pos < Position then
      begin
        Base^.Seek(Startofs);
        FreeMem(Tables, SizeOf(TLZWTables));

        TLZWFilter.Init(Base, Mode); { Re-initialize everything.  Will this cause
                                     bugs in descendents? }
      end;
      while Pos > Position do
      begin
        if Pos-Position > SizeOf(Buf) then
          Bytes := SizeOf(Buf)
        else
          Bytes := Pos-Position;
        Read(Buf, Bytes);
      end;
    end;
  end;

  procedure TLZWFilter.Truncate;
  begin
    Error(stBadMode, Mode);
  end;

  function TLZWFilter.GetPos;
  begin
    GetPos := Position;
  end;

  function TLZWFilter.GetSize;
  begin
    GetSize := Size;
  end;

  { ***** Text Filter Code ******* }

  { These declarations are used both by TTextFilter and TLogFilter }

type
  TFDDfunc = function(var F : Text) : Integer;

  PStreamTextRec = ^StreamTextRec;
  PSaveText = ^TSaveText;
  TSaveText =
    record                        { Used when logging for original data values }
      OpenFunc,
      InOutFunc,
      FlushFunc,
      CloseFunc : TFDDfunc;
      S : PLogFilter;
      SaveData : PSaveText;
      Next : PStreamTextRec;
      Data : array[13..16] of Byte;
    end;

  StreamTextRec =
    record
      Handle : Word;
      Mode : Word;
      BufSize : Word;
      private : Word;
      BufPos : Word;
      BufEnd : Word;
      BufPtr : Pbyte_array;
      OpenFunc,
      InOutFunc,
      FlushFunc,
      CloseFunc : TFDDfunc;
      S : PFilter;                { This is a TTextFilter or a TLogFilter }
      SaveData : PSaveText;
      Next : PStreamTextRec;
      OtherData : array[13..16] of Byte;
      Name : array[0..79] of Char;
      Buffer : array[0..127] of Byte;
    end;


  function TextIn(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F), S^ do
    begin
      if Status = 0 then
      begin
        if GetSize-GetPos > BufSize then
        begin
          Read(BufPtr^, BufSize);
          BufEnd := BufSize;
        end
        else
        begin
          BufEnd := GetSize-GetPos;
          if BufEnd > 0 then
            Read(BufPtr^, BufEnd);
        end;
      end;
      TextIn := Status;
    end;
  end;

  function TextOut(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F), S^ do
    begin
      if Status = 0 then
      begin
        Write(BufPtr^, BufPos);
        BufPos := 0;
      end;
      TextOut := Status;
    end;
  end;

  function TextInFlush(var F : Text) : Integer; Far;
  begin
  end;

  function TextOutFlush(var F : Text) : Integer; Far;
  begin
    TextOutFlush := TextOut(F);
  end;

  function TextClose(var F : Text) : Integer; Far;
  begin
    TextClose := StreamTextRec(F).S^.Status;
  end;

  function TextOpen(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
    begin
      case Mode of
        fmInOut : Mode := fmOutput;
        fmOutput : S^.Seek(S^.Startofs);
      end;
      case Mode of
        fmInput : begin
                    InOutFunc := TextIn;
                    FlushFunc := TextInFlush;
                  end;
        fmOutput : begin
                     InOutFunc := TextOut;
                     FlushFunc := TextOutFlush;
                   end;
      end;
      TextOpen := S^.Status;
    end;
  end;

  constructor TTextFilter.Init(ABase : PStream; AName : String);
  begin
    if not TFilter.Init(ABase) then
      Fail;
    with StreamTextRec(Textfile) do
    begin
      Mode := fmClosed;
      BufSize := SizeOf(Buffer);
      BufPtr := @Buffer;
      OpenFunc := TextOpen;
      CloseFunc := TextClose;
      AName := Copy(AName, 1, 79);
      Move(AName[1], Name, Length(AName));
      Name[Length(AName)] := #0;
      S := @Self;
    end;
  end;

  destructor TTextFilter.Done;
  begin
    if StreamTextRec(Textfile).Mode <> fmClosed then
      Close(Textfile);
    TFilter.Done;
  end;

  function DoOldCall(Func : TFDDfunc; var F : Text) : Integer;
  var
    Save : TSaveText;
  begin
    if @Func <> nil then
      with StreamTextRec(F) do
      begin
        Move(OpenFunc, Save, SizeOf(TSaveText));
        Move(SaveData^, OpenFunc, SizeOf(TSaveText)); { Now using old functions }
        DoOldCall := Func(F);
        Move(OpenFunc, Save.SaveData^, SizeOf(TSaveText)); { Save any changes }
        Move(Save, OpenFunc, SizeOf(TSaveText)); { Back to new ones }
      end;
  end;

  function LogIn(var F : Text) : Integer; Far;
  var
    Result : Integer;
  begin
    with StreamTextRec(F) do
    begin
      Result := DoOldCall(SaveData^.InOutFunc, F);
      if Result = 0 then
        S^.Write(BufPtr^, BufEnd); { Might want to record errors
                                               here }
      LogIn := Result;
    end;
  end;

  function LogOut(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
    begin
      S^.Write(BufPtr^, BufPos);
      LogOut := DoOldCall(SaveData^.InOutFunc, F);
    end;
  end;

  function LogInFlush(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
      LogInFlush := DoOldCall(SaveData^.FlushFunc, F);
  end;

  function LogOutFlush(var F : Text) : Integer; Far;
  var
    OldPos : Word;
  begin
    with StreamTextRec(F) do
    begin
      OldPos := BufPos;
      LogOutFlush := DoOldCall(SaveData^.FlushFunc, F);
      if BufPos = 0 then
        S^.Write(BufPtr^, OldPos);
    end;
  end;

  function LogClose(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
    begin
      LogClose := DoOldCall(SaveData^.CloseFunc, F);
      if not PLogFilter(S)^.Unlog(F) then
        { Bug! } ;
    end;
  end;

  function LogOpen(var F : Text) : Integer; Far;
  begin
    with StreamTextRec(F) do
    begin
      LogOpen := DoOldCall(SaveData^.OpenFunc, F);
      case Mode of
        fmInOut, fmOutput : begin
                              InOutFunc := LogOut;
                              if @FlushFunc <> nil then
                                FlushFunc := LogOutFlush;
                            end;
        fmInput : begin
                    InOutFunc := LogIn;
                    if @FlushFunc <> nil then
                      FlushFunc := LogInFlush;
                  end;
      end;
    end;
  end;

  { ******* TLogFilter methods ******** }

  destructor TLogFilter.Done;
  begin
    while (LogList <> nil) and Unlog(LogList^) do ;
    TFilter.Done;
  end;

  procedure TLogFilter.Log(var F : Text);
  var
    Save : PSaveText;
    OldOpen : TFDDfunc;
    Junk : Integer;

  begin
    New(Save);
    with StreamTextRec(F) do
    begin
      Move(OpenFunc, Save^, SizeOf(TSaveText)); { Save the original contents }
      S := @Self;
      SaveData := Save;
      Next := PStreamTextRec(LogList);
      LogList := @F;              { Insert this file into the list of logged files }
      OldOpen := SaveData^.OpenFunc;
      Pointer(@SaveData^.OpenFunc) := nil; { Call LogOpen, but don't open. }
      Junk := LogOpen(F);
      SaveData^.OpenFunc := OldOpen;
      CloseFunc := LogClose;
    end;
  end;

  function TLogFilter.Unlog(var F : Text) : Boolean;
  var
    Save : PSaveText;
    Prev : PStreamTextRec;
  begin
    Unlog := False;               { Assume failure }
    with StreamTextRec(F) do
    begin
      if S = @Self then
      begin
        { First, delete it from the list. }
        if LogList = @F then
          LogList := Pointer(Next)
        else
        begin
          Prev := PStreamTextRec(LogList);
          while (Prev^.Next <> nil) and (Prev^.Next <> @F) do
            Prev := Prev^.Next;
          if Prev^.Next <> @F then
            Exit;                 { Couldn't find it in the list!? }
          Prev^.Next := Next;
        end;
        Save := SaveData;
        Move(Save^, OpenFunc, SizeOf(TSaveText));
        Dispose(Save);
        Unlog := True;
      end;
    end;
  end;

  { ****** Overlay stream code ****** }

type
  { This is the structure at the start of each "thunk" segment }
  Povrhead = ^TOvrhead;
  TOvrhead = record
               Signature : Word;  { CD 3F  - INT 3F call used on returns }
               Ret_Ofs : Word;    { The offset to jump to when a return triggers a
                            reload }
               Offset : LongInt;  { The offset to the segment in the .OVR file }
               Code_Bytes,        { Size of the code image }
               Reloc_Bytes,       { Number of relocation fixups times 2 }
               Entry_Count,       { The number of entry points }
               NextSeg,           { Next overlay segment - add prefixseg + $10 to find
                            thunks.  List starts with System.ovrcodelist. }
               LoadSeg,           { The segment at which the overlay is loaded, or 0 }
               Reprieve,          { Set to 1 to if overlay used while on probation }
               NextLoaded : Word; { The segment of the next loaded overlay.  List starts
                            with System.ovrloadlist.  Updated *after* call to
                            ovrreadbuf. }
               case Integer of
                 1 : (EMSPage,    { The EMS page where this overlay is stored }
                      EMSOffset : Word); { The offset within the EMS page }
                 2 : (S : PStream; { The stream holding this segment's code }
                      Soffset : LongInt); { The offset within S }
             end;

var
  OldReadFunc : OvrReadFunc;
  OvrOldExitProc : Pointer;
  OvrStream : PStream;
const
  OvrStreamInstalled : Boolean = False;
  OvrExitHandler : Boolean = False;

  function OvrPtr(Seg : Word) : Povrhead;
{ Convert map style segment number, as used by overlay manager, to
  pointer }
  begin
    OvrPtr := Ptr(Seg+PrefixSeg+$10, 0);
  end;

  function StdPtr(Seg : Word) : Povrhead;
    { Convert straight segment number to a pointer }
  begin
    StdPtr := Ptr(Seg, 0);
  end;

  function NewReadFunc(OvrSeg : Word) : Integer; Far;
  var
    Result : Integer;
  begin
    with StdPtr(OvrSeg)^ do
    begin
      if S = nil then
      begin                       { Segment not yet loaded }
        Result := OldReadFunc(OvrSeg);
        if Result = 0 then
        begin
          { Now copy the loaded code to our stream }
          Soffset := OvrStream^.GetSize;
          OvrStream^.Seek(Soffset);
          OvrStream^.Write(Ptr(LoadSeg, 0)^, Code_Bytes);
          Result := OvrStream^.Status;
          if Result = stOK then
            S := OvrStream
          else
            OvrStream^.Reset;     { Something failed; hope we haven't messed
                              up the stream too much }
        end;
      end
      else
      begin                       { Segment has been loaded into the stream }
        S^.Seek(Soffset);
        S^.Read(Ptr(LoadSeg, 0)^, Code_Bytes);
        Result := S^.Status;
        if Result <> stOK then
        begin
          S^.Reset;               { Fix the stream, and try a standard load }
          Result := OldReadFunc(OvrSeg);
        end;
      end;
    end;
    NewReadFunc := Result;
  end;

  procedure OvrExitProc; Far;
{ Installed exit procedure; disposes of any streams that are still
  handling overlays. }
  begin
    ExitProc := OvrOldExitProc;
    OvrDisposeStreams;
  end;

  procedure OvrInitStream(S : PStream);
  begin
    if not OvrStreamInstalled then
    begin
      OldReadFunc := OvrReadBuf;  { Install our reader function }
      OvrReadBuf := NewReadFunc;
      OvrStreamInstalled := True;
    end;
    if not OvrExitHandler then
    begin
      OvrOldExitProc := ExitProc;
      ExitProc := @OvrExitProc;
      OvrExitHandler := True;
    end;
    OvrStream := S;               { And set stream to use }
  end;

  procedure OvrDetachStream(BadS : PStream);
  var
    OvrSeg : Word;
  begin
    if OvrStreamInstalled then
    begin
      if OvrStream = BadS then
        OvrStream := nil;         { Detach default stream }
      OvrSeg := OvrCodeList;
      while OvrSeg <> 0 do        { Walk the overlay list }
        with OvrPtr(OvrSeg)^ do
        begin
          if S <> nil then
          begin
            if S <> BadS then
            begin
              if OvrStream = nil then
                OvrStream := S;   { Set default stream to first found }
            end
            else
              S := nil;           { Blank out BadS references }
          end;
          OvrSeg := NextSeg;
        end;
      if OvrStream = nil then
      begin
        OvrStreamInstalled := False; { If we don't have a stream, better
                                          uninstall. }
        OvrReadBuf := OldReadFunc;
      end;
    end;
  end;

  procedure OvrDisposeStreams;
  var
    S : PStream;
  begin
    while OvrStreamInstalled and (OvrStream <> nil) do
    begin
      S := OvrStream;
      OvrDetachStream(S);
      Dispose(S, Done);
    end;
  end;

  function OvrSizeNeeded : LongInt;
  var
    OvrSeg : Word;
    Result : LongInt;
  begin
    OvrSeg := OvrCodeList;
    Result := 0;
    while OvrSeg <> 0 do          { Walk the overlay list }
      with OvrPtr(OvrSeg)^ do
      begin
        if S = nil then
          Inc(Result, Code_Bytes);
        OvrSeg := NextSeg;
      end;
    OvrSizeNeeded := Result;
  end;

  function OvrLoadAll : Boolean;
  var
    OvrSeg : Word;
    Junk : Integer;
  begin
    if not OvrStreamInstalled then
      OvrLoadAll := False
    else
    begin
      OvrClearBuf;
      OvrSeg := OvrCodeList;
      while OvrSeg <> 0 do        { Walk the overlay list }
        with OvrPtr(OvrSeg)^ do
        begin
          if S = nil then
          begin
            LoadSeg := OvrHeapOrg; { load at start of overlay buffer }
            Junk := NewReadFunc(OvrSeg+PrefixSeg+$10);
            LoadSeg := 0;         { Don't really want it loaded yet }
          end;
          OvrSeg := NextSeg;
        end;
      OvrLoadAll := OvrStream^.Status = stOK;
    end;
  end;

  { ****** RAM stream code ****** }

  constructor TRAMStream.Init(Asize : Word);
  begin
    TStream.Init;
    CP := 0;
    Size := 0;
    Alloc := Asize;
    if MaxAvail < Alloc then
      Fail;
    GetMem(Buffer, Alloc);
    FillChar(Buffer^, Alloc, 0);
  end;

  destructor TRAMStream.Done;
  begin
    FreeMem(Buffer, Alloc);
    TStream.Done;
  end;

  function TRAMStream.GetPos;
  begin
    GetPos := CP;
  end;

  function TRAMStream.GetSize;
  begin
    GetSize := Size;
  end;

  procedure TRAMStream.Read;
  begin
    if CP+Count > Size then
    begin
      Error(stReaderror, 0);
      FillChar(Buf, Count, 0);
    end
    else
    begin
      Move(Buffer^[CP], Buf, Count);
      Inc(CP, Count);
    end;
  end;

  procedure TRAMStream.Seek;
  begin
    if Pos > Size then
      Error(stReaderror, 0)
    else
      CP := Pos;
  end;

  procedure TRAMStream.Truncate;
  begin
    Size := CP;
  end;

  procedure TRAMStream.Write;
  begin
    if CP+Count > Alloc then
      Error(stWriteError, 0)
    else
    begin
      Move(Buf, Buffer^[CP], Count);
      Inc(CP, Count);
      if CP > Size then
        Size := CP;
    end;
  end;

  { ***** Named Buffered file stream code ***** }

  constructor TNamedBufStream.Init(Name : FNameStr; Mode : TOpenMode; ABufSize : Word);
  begin
    if TBufStream.Init(Name, Mode, BufSize) then
    {$ifdef windows}
    filename := StrNew(name)
    {$else}
      Filename := NewStr(Name)
    {$endif}
    else
      Fail;
  end;

  destructor TNamedBufStream.Done;
  begin
  {$ifdef windows}
  StrDispose(filename);
  {$else}
    DisposeStr(Filename);
  {$endif}
    TBufStream.Done;
  end;

  constructor TTempBufStream.Init(ABufSize : Word);
  var
    p : Pchar;
    TempName : String;
    Okay : Boolean;
    NewHandle : Word;
  begin
    if not TStream.Init then
      Fail;
    if MaxAvail < ABufSize then
      Fail;
    BufSize := ABufSize;
    GetMem(Buffer, BufSize);

  {$ifdef windows}
  p := GetEnvVar('TEMP');
  if p <> nil then
    tempname := StrPas(p)
  else
    tempname := '';
  {$else}
    TempName := GetEnv('TEMP');
  {$endif}
    if Length(TempName) = 0 then
      TempName := '.\';
    if TempName[Length(TempName)] <> '\' then
      TempName := TempName+'\';
    FillChar(TempName[Length(TempName)+1], 255-Length(TempName), #0);
    asm
      push    ds
      push    ss
      pop     ds
      lea     dx,TempName[1]
      mov     ah, $5a
      xor     cx,cx
    {$ifdef windows}
    call dos3call
    {$else}
      int     $21                 { Create temporary file. }
    {$endif}
      pop     ds
      jc      @failed
      mov     Okay,True
      mov     NewHandle,ax
      jmp     @done
@failed:
      mov     Okay,False
@done:
    end;
    if not Okay then
      Fail;
    Handle := NewHandle;
    while TempName[Length(TempName)+1] <> #0 do
      Inc(TempName[0]);
  {$ifdef windows}
  filename := StrNew(StrPCopy(@tempname,tempname));
  {$else}
    Filename := NewStr(TempName);
  {$endif}
  end;

  destructor TTempBufStream.Done;
  var
    F : file;
  begin
  {$ifdef windows}
  assign(f,StrPas(Filename));
  {$else}
    Assign(F, Filename^);
  {$endif}
    TNamedBufStream.Done;
    Erase(F);
  end;

  { ***** Temp Stream Code ******* }

  function TempStream(InitSize, MaxSize : LongInt;
                      Preference : TStreamRanking) : PStream;
  var
    Choice : Integer;
    i : Integer;
    Result : PStream;
    StreamType : TStreamType;
  begin
    Result := nil;
    for Choice := 1 to NumTypes do
    begin
      StreamType := Preference[Choice];
      case StreamType of
        RAMStream :
          if MaxSize < $10000 then
            Result := New(PRAMStream, Init(MaxSize));
        EMSStream :
          Result := New(PEMSStream, Init(InitSize, MaxSize));
        FileStream :
          Result := New(PTempBufStream, Init(2048));
      end;
      if (Result <> nil) and (Result^.Status = stOK) then
      begin
        TempStream := Result;
        Exit;
      end;
      if Result <> nil then
        Dispose(Result, Done); { Clean up and start over } ;
      Result := nil;
    end;
  end;

end.