TStreamAdapter.Seek Test

This is simple test code which tests TStreamAdapter.Seek functionality and doesn’t require creating 4+GB files on the disk. A fix is also included.

program SeekTest;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  Windows, SysUtils, Classes, ActiveX;

type
  TTestStream = class(TStream)
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; 
      overload; override;
  end;

var
  GSeekOffset: int64;

(* quick fix
type
  TStreamAdapter = class(Classes.TStreamAdapter)
  public
    function Seek(dlibMove: Int64; dwOrigin: Integer; 
      out libNewPosition: Int64): HRESULT; override; stdcall;
  end;

function TStreamAdapter.Seek(dlibMove: Int64; dwOrigin: Integer; 
  out libNewPosition: Int64): HRESULT;
var
  NewPos: LargeInt;
begin
  try
    if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then
    begin
      Result := STG_E_INVALIDFUNCTION;
      Exit;
    end;
    NewPos := Stream.Seek(dlibMove, TSeekOrigin(dwOrigin));
    if @libNewPosition <> nil then
      libNewPosition := NewPos;
    Result := S_OK;
  except
    Result := STG_E_INVALIDPOINTER;
  end;
end;
*)

function TTestStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  GSeekOffset := Offset;
  Result := Offset;
end;

var
  ts: TTestStream;
  sa: TStreamAdapter;
  np: int64;

begin
  ts := TTestStream.Create;
  sa := TStreamAdapter.Create(ts, soOwned);
  sa.Seek($123456789, soFromBeginning, np);
  sa.Free;
  if GSeekOffset = $123456789 then
    Writeln('Seek is OK')
  else
    Writeln('Seek is broken');
  Readln;
end.