unit untMyStreams;

interface

uses Windows, Classes, SysUtils, ActiveX, SyncObjs;

type
  TInterfacedStream = class (TStream, IStream)
  protected
    FRefCount: Integer;
    CriticalSection: TCriticalSection;

    //<IUnknown implementations>
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function NewInstance: TObject; override;
    property RefCount: Integer read FRefCount;

    //<ISequentialStream implementations>
    function IStream.Read = IRead;
    function IStream.Write = IWrite;
    function IRead(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult; stdcall;
    function IWrite(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult; stdcall;

    //<IStream implementations>
    function IStream.SetSize = ISetSize;
    function IStream.Seek = ISeek;
    function ISeek(dlibMove: Largeint; dwOrigin: Longint; out libNewPosition: Largeint): HResult; stdcall;
    function ISetSize(libNewSize: Largeint): HResult; stdcall;
    function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; out cbWritten: Largeint): HResult; stdcall;
    function Commit(grfCommitFlags: Longint): HResult; stdcall;
    function Revert: HResult; stdcall;
    function LockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; stdcall;
    function UnlockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; stdcall;
    function Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult; stdcall;
    function Clone(out stm: IStream): HResult; stdcall;

    function CreateClone: TInterfacedStream; virtual; abstract;
  end;

  TIMemoryStream = class (TInterfacedStream)
  private
    FpMemory  : PPointer;
    FPosition : Longint;
    FpSize    : PLongint;
    FpCapacity: PLongint;

    FpCloneCount: PInteger;
    procedure SetCapacity(NewCapacity: Longint);
    function GetCapacity: Longint;
  protected
    procedure SetPointer(Ptr: Pointer; Size: Longint);
    function Realloc(var NewCapacity: Longint): Pointer; virtual;
    property Capacity: Longint read GetCapacity write SetCapacity;

    constructor CreateCloned;
  public
    function Read(var Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    procedure SaveToStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
    function Memory: Pointer;

    procedure Clear;
    procedure LoadFromStream(Stream: TStream);
    procedure LoadFromFile(const FileName: string);
    procedure SetSize(NewSize: Longint); override;
    function Write(const Buffer; Count: Longint): Longint; override;

    function CreateClone: TInterfacedStream; override;

    constructor Create;
    destructor Destroy; override;
  end;


implementation

uses RTLConsts, Math;

const
  MemoryDelta = $2000; { Must be a power of 2 }

{ TInterfacedStream }

procedure TInterfacedStream.AfterConstruction;
begin
  inherited;
// Release the constructor's implicit refcount
  CriticalSection:=TCriticalSection.Create;
  InterlockedDecrement(FRefCount);
end;

procedure TInterfacedStream.BeforeDestruction;
begin
  if RefCount <> 0 then
    System.Error(reInvalidPtr);
end;

function TInterfacedStream.Clone(out stm: IStream): HResult;
begin
  CriticalSection.Acquire;
  Result := E_NOTIMPL;
  stm:=CreateClone;
  if assigned(stm) then
    Result:=S_OK;
  CriticalSection.Release;
end;

function TInterfacedStream.Commit(grfCommitFlags: Integer): HResult;
begin
  Result := S_OK;
end;

function TInterfacedStream.CopyTo(stm: IStream; cb: Largeint; out cbRead,
  cbWritten: Largeint): HResult;
const
  MaxBufSize = 1024 * 1024;  // 1mb
var
  Buffer: Pointer;
  BufSize, N, I, R: Integer;
  BytesRead, BytesWritten, W: LargeInt;
begin
  CriticalSection.Acquire;
  Result := S_OK;
  BytesRead := 0;
  BytesWritten := 0;
  try
    if cb > MaxBufSize then
      BufSize := MaxBufSize
    else
      BufSize := Integer(cb);
    GetMem(Buffer, BufSize);
    try
      while cb > 0 do
      begin
        if cb > MaxInt then
          I := MaxInt
        else
          I := cb;
        while I > 0 do
        begin
          if I > BufSize then N := BufSize else N := I;
          R := Read(Buffer^, N);
          if R = 0 then
          begin
            CriticalSection.Release;
            Exit; // The end of the stream was hit.
          end;
          Inc(BytesRead, R);
          W := 0;
          Result := stm.Write(Buffer, R, @W);
          Inc(BytesWritten, W);
          if (Result = S_OK) and (Integer(W) <> R) then Result := E_FAIL;
          if Result <> S_OK then
          begin
            CriticalSection.Release;
            Exit;
          end;
          Dec(I, R);
          Dec(cb, R);
        end;
      end;
    finally
      FreeMem(Buffer);
      if (@cbWritten <> nil) then cbWritten := BytesWritten;
      if (@cbRead <> nil) then cbRead := BytesRead;
    end;
  except
    Result := E_UNEXPECTED;
  end;
  CriticalSection.Release;
end;

function TInterfacedStream.LockRegion(libOffset, cb: Largeint;
  dwLockType: Integer): HResult;
begin
  Result := STG_E_INVALIDFUNCTION;
end;

class function TInterfacedStream.NewInstance: TObject;
begin
  Result := inherited NewInstance;
  TInterfacedStream(Result).FRefCount := 1;
end;

function TInterfacedStream.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

function TInterfacedStream.IRead(pv: Pointer; cb: Integer;
  pcbRead: PLongint): HResult;
var
  NumRead: Longint;
begin
  CriticalSection.Acquire;
  try
    if pv = Nil then
    begin
      Result := STG_E_INVALIDPOINTER;
      CriticalSection.Release;
      Exit;
    end;
    NumRead := Read(pv^, cb);
    if pcbRead <> Nil then pcbRead^ := NumRead;
    Result := S_OK;
  except
    Result := S_FALSE;
  end;
  CriticalSection.Release;
end;

function TInterfacedStream.Revert: HResult;
begin
  Result := STG_E_REVERTED;
end;

function TInterfacedStream.ISeek(dlibMove: Largeint; dwOrigin: Integer;
  out libNewPosition: Largeint): HResult;
var
  NewPos: LargeInt;
begin
  CriticalSection.Acquire;
  try
    if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then
    begin
      Result := STG_E_INVALIDFUNCTION;
      CriticalSection.Release;
      Exit;
    end;
    NewPos := Seek(dlibMove, dwOrigin);
    if @libNewPosition <> nil then libNewPosition := NewPos;
    Result := S_OK;
  except
    Result := STG_E_INVALIDPOINTER;
  end;
  CriticalSection.Release;
end;

function TInterfacedStream.ISetSize(libNewSize: Largeint): HResult;
begin
  CriticalSection.Acquire;
  try
    Size := libNewSize;
    if libNewSize <> Size then
      Result := E_FAIL
    else
      Result := S_OK;
  except
    Result := E_UNEXPECTED;
  end;
  CriticalSection.Release;
end;

function TInterfacedStream.Stat(out statstg: TStatStg;
  grfStatFlag: Integer): HResult;
begin
  CriticalSection.Acquire;
  Result := S_OK;
  try
    if (@statstg <> nil) then
      with statstg do
      begin
        dwType := STGTY_STREAM;
        cbSize := Size;
        mTime.dwLowDateTime := 0;
        mTime.dwHighDateTime := 0;
        cTime.dwLowDateTime := 0;
        cTime.dwHighDateTime := 0;
        aTime.dwLowDateTime := 0;
        aTime.dwHighDateTime := 0;
        grfLocksSupported := LOCK_WRITE;
      end;
  except
    Result := E_UNEXPECTED;
  end;
  CriticalSection.Release;
end;

function TInterfacedStream.UnlockRegion(libOffset, cb: Largeint;
  dwLockType: Integer): HResult;
begin
  Result := STG_E_INVALIDFUNCTION;
end;

function TInterfacedStream.IWrite(pv: Pointer; cb: Integer;
  pcbWritten: PLongint): HResult;
var
  NumWritten: Longint;
begin
  CriticalSection.Acquire;
  try
    if pv = Nil then
    begin
      Result := STG_E_INVALIDPOINTER;
      CriticalSection.Release;
      Exit;
    end;
    NumWritten := Write(pv^, cb);
    if pcbWritten <> Nil then pcbWritten^ := NumWritten;
    Result := S_OK;
  except
    Result := STG_E_CANTSAVE;
  end;
  CriticalSection.Release;
end;

function TInterfacedStream._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TInterfacedStream._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then
    Destroy;
end;

{ TIMemoryStream }

procedure TIMemoryStream.Clear;
begin
  CriticalSection.Acquire;
  SetCapacity(0);
  FpSize^ := 0;
  FPosition := 0;
  CriticalSection.Release;
end;

constructor TIMemoryStream.Create;
begin
  GetMem(FpMemory, SizeOf(Pointer));
  GetMem(FpCloneCount, SizeOf(integer));
  GetMem(FpSize, SizeOf(Longint));
  GetMem(FpCapacity, SizeOf(Longint));
  FpCloneCount^:=0;
  FpSize^:=0;
  FpCapacity^:=0;
end;

function TIMemoryStream.CreateClone: TInterfacedStream;
begin
  CriticalSection.Acquire;
  Result:=TIMemoryStream.CreateCloned;
  TIMemoryStream(Result).FpMemory:=FpMemory;
  TIMemoryStream(Result).FpCloneCount:=FpCloneCount;
  TIMemoryStream(Result).FpSize:=FpSize;
  TIMemoryStream(Result).FpCapacity:=FpCapacity;
  TIMemoryStream(Result).Position:=Position;
  InterlockedIncrement(FpCloneCount^);
  CriticalSection.Release;
end;

constructor TIMemoryStream.CreateCloned;
begin

end;

destructor TIMemoryStream.Destroy;
begin
  if FpCloneCount^=0 then
  begin
    Clear;
    FreeMem(FpCloneCount, SizeOf(Integer));
    FreeMem(FpMemory, SizeOf(Pointer));
    FreeMem(FpSize, SizeOf(Longint));
    FreeMem(FpCapacity, SizeOf(Longint));
  end
  else
    InterlockedDecrement(FpCloneCount^);
  inherited;
end;

function TIMemoryStream.GetCapacity: Longint;
begin
  Result:=FpCapacity^;
end;

procedure TIMemoryStream.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  CriticalSection.Acquire;
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
  CriticalSection.Release;
end;

procedure TIMemoryStream.LoadFromStream(Stream: TStream);
var
  Count: Longint;
begin
  CriticalSection.Acquire;
  Stream.Position := 0;
  Count := Stream.Size;
  SetSize(Count);
  if Count <> 0 then Stream.ReadBuffer(FpMemory^^, Count);
  CriticalSection.Release;
end;

function TIMemoryStream.Memory: Pointer;
begin
  Result:=FpMemory^;
end;

function TIMemoryStream.Read(var Buffer; Count: Integer): Longint;
begin
  CriticalSection.Acquire;
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Result := FpSize^ - FPosition;
    if Result > 0 then
    begin
      if Result > Count then Result := Count;
      Move(Pointer(Longint(FpMemory^) + FPosition)^, Buffer, Result);
      Inc(FPosition, Result);
      CriticalSection.Release;
      Exit;
    end;
  end;
  Result := 0;
  CriticalSection.Release;
end;

function TIMemoryStream.Realloc(var NewCapacity: Integer): Pointer;
begin
  if (NewCapacity > 0) and (NewCapacity <> FpSize^) then
    NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  Result := Memory;
  if NewCapacity <> FpCapacity^ then
  begin
    if NewCapacity = 0 then
    begin
      FreeMem(Memory);
      Result := nil;
    end else
    begin
      if Capacity = 0 then
        GetMem(Result, NewCapacity)
      else
        ReallocMem(Result, NewCapacity);
      if Result = nil then raise EStreamError.CreateRes(@SMemoryStreamError);
    end;
  end;
end;

procedure TIMemoryStream.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  CriticalSection.Acquire; //let's synchronize even here
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
  CriticalSection.Release;
end;

procedure TIMemoryStream.SaveToStream(Stream: TStream);
begin
  CriticalSection.Acquire;
  if FpSize^ <> 0 then Stream.WriteBuffer(FpMemory^^, FpSize^);
  CriticalSection.Release;
end;

function TIMemoryStream.Seek(Offset: Integer; Origin: Word): Longint;
begin
  CriticalSection.Acquire;
  case Origin of
    soFromBeginning: FPosition := Offset;
    soFromCurrent: Inc(FPosition, Offset);
    soFromEnd: FPosition := FpSize^ + Offset;
  end;
  Result := FPosition;
  CriticalSection.Release;
end;

procedure TIMemoryStream.SetCapacity(NewCapacity: Integer);
begin
  SetPointer(Realloc(NewCapacity), FpSize^);
  FpCapacity^ := NewCapacity;
end;

procedure TIMemoryStream.SetPointer(Ptr: Pointer; Size: Integer);
begin
  FpMemory^ := Ptr;
  FpSize^ := Size;
end;

procedure TIMemoryStream.SetSize(NewSize: Integer);
var
  OldPosition: Longint;
begin
  CriticalSection.Acquire;
  OldPosition := FPosition;
  SetCapacity(NewSize);
  FpSize^ := NewSize;
  if OldPosition > NewSize then Seek(0, soFromEnd);
  CriticalSection.Release;
end;

function TIMemoryStream.Write(const Buffer; Count: Integer): Longint;
var
  Pos: Longint;
begin
  CriticalSection.Acquire;
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Pos := FPosition + Count;
    if Pos > 0 then
    begin
      if Pos > FpSize^ then
      begin
        if Pos > FpCapacity^ then
          SetCapacity(Pos);
        FpSize^ := Pos;
      end;
      System.Move(Buffer, Pointer(Longint(FpMemory^) + FPosition)^, Count);
      FPosition := Pos;
      Result := Count;
      CriticalSection.Release;
      Exit;
    end;
  end;
  Result := 0;
  CriticalSection.Release;
end;

end.
