Friday, October 11, 2013

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
.

2 comments:

  1. You should add this to the QC ticket.

    ReplyDelete
  2. in XE4u1 there EMBT fixed it by introducing a third function as TStream.Seek

    function Seek(Offset: Longint; Origin: Word): Longint; overload; virtual;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; virtual;
    function Seek(const Offset: Int64; Origin: Word): Int64; overload; deprecated; inline;

    function TStream.Seek(const Offset: Int64; Origin: Word): Int64;
    begin
    Result := Seek(Offset, TSeekOrigin(Origin));
    end;

    So, EMBT fixed the bug by introducing and relying upon the functio nthey do call deprecated themselves!

    ReplyDelete