Sordie.co.uk

libsassy/libSassy.Streams.pas

Raw

{(
 )) libSassy.Streams
((    Generic data streaming library
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.Streams;

interface

uses
  Winapi.Windows,

  libSassy.Interfaces;

const
  CipherTableSize = 1023;

{$REGION 'IStream'}
const
  STGTY_STORAGE   = 1;
  STGTY_STREAM    = 2;
  STGTY_LOCKBYTES = 3;
  STGTY_PROPERTY  = 4;

  STREAM_SEEK_SET = 0;
  STREAM_SEEK_CUR = 1;
  STREAM_SEEK_END = 2;

  LOCK_WRITE     = 1;
  LOCK_EXCLUSIVE = 2;
  LOCK_ONLYONCE  = 4;

type
  PStatStg = ^TStatStg;
  TStatStg = record
    pwcsName:          PWideChar;
    dwType:            LongInt;
    cbSize:            Int64;
    mtime:             TFileTime;
    ctime:             TFileTime;
    atime:             TFileTime;
    grfMode:           LongInt;
    grfLocksSupported: LongInt;
    clsid:             TGUID;
    grfStateBits:      LongInt;
    reserved:          LongInt;
  end;

  ISequentialStream = interface(IUnknown)
    ['{0c733a30-2a1c-11ce-ade5-00aa0044773d}']

    function Read (pv: Pointer; cb: LongInt; pcbRead:    PLongInt): HRESULT; stdcall;
    function Write(pv: Pointer; cb: LongInt; pcbWritten: PLongInt): HRESULT; stdcall;
  end;

  IStream = interface(ISequentialStream)
    ['{0000000C-0000-0000-C000-000000000046}']

    function Seek(dlibMove: Int64; dwOrigin: LongInt; out libNewPosition: Int64): HRESULT; stdcall;

    function SetSize(libNewSize: Int64): HRESULT; stdcall;

    function CopyTo(stm: IStream; cb: Int64; out cbRead: Int64; out cbWritten: Int64): HRESULT; stdcall;

    function Commit(grfCommitFlags: LongInt): HRESULT; stdcall;
    function Revert: HRESULT; stdcall;

    function LockRegion  (libOffset: Int64; cb: Int64; dwLockType: LongInt): HRESULT; stdcall;
    function UnlockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HRESULT; stdcall;

    function Stat(out statstg: TStatStg; grfStatFlag: LongInt): HRESULT; stdcall;

    function Clone(out stm: IStream): HRESULT; stdcall;
  end;
{$ENDREGION}

  TStreamIOEvent = procedure(const Size: Int64) of object;

{$REGION 'TStream'}
  TStream = class(TInterface, IStream)
  private
    fBytesRead:    Int64;
    fBytesWritten: Int64;

    fOnRead:  TStreamIOEvent;
    fOnWrite: TStreamIOEvent;

    fCipherKey: Integer;
    fCipherTable: array[0..CipherTableSize] of Byte;

    procedure SetCipherKey(Value: Integer);

    procedure BlockCipher(var Data; const Size, Index: Int64);
  protected
{$REGION 'TStream->IStream mapping'}
    function IStream.Read         = IStream_Read;
    function IStream.Write        = IStream_Write;
    function IStream.Seek         = IStream_Seek;
    function IStream.SetSize      = IStream_SetSize;
    function IStream.CopyTo       = IStream_CopyTo;
    function IStream.Commit       = IStream_Commit;
    function IStream.Revert       = IStream_Revert;
    function IStream.LockRegion   = IStream_LockRegion;
    function IStream.UnlockRegion = IStream_UnlockRegion;
    function IStream.Stat         = IStream_Stat;
    function IStream.Clone        = IStream_Clone;

    function IStream_Read (pv: Pointer; cb: LongInt; pcbRead:    PLongInt): HRESULT; stdcall;
    function IStream_Write(pv: Pointer; cb: LongInt; pcbWritten: PLongInt): HRESULT; stdcall;

    function IStream_Seek(dlibMove: Int64; dwOrigin: Longint; out libNewPosition: Int64): HRESULT; stdcall;

    function IStream_SetSize(libNewSize: Int64): HRESULT; stdcall;

    function IStream_CopyTo(stm: IStream; cb: Int64; out cbRead: Int64; out cbWritten: Int64): HRESULT; stdcall;

    function IStream_Commit(grfCommitFlags: LongInt): HRESULT; stdcall;
    function IStream_Revert: HRESULT; stdcall;

    function IStream_LockRegion  (libOffset: Int64; cb: Int64; dwLockType: LongInt): HRESULT; stdcall;
    function IStream_UnlockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HRESULT; stdcall;

    function IStream_Stat(out statstg: TStatStg; grfStatFlag: LongInt): HRESULT; stdcall;

    function IStream_Clone(out stm: IStream): HRESULT; stdcall;
{$ENDREGION}
  public
    var FreeAfterOp: Boolean;

    constructor Create;

    function InternalRead (var   Data; const Size: Int64): Int64; virtual;
    function InternalWrite(const Data; const Size: Int64): Int64; virtual;

    function  GetSize: Int64;        virtual;
    procedure SetSize(Value: Int64); virtual;

    function  GetPos: Int64;        virtual;
    procedure SetPos(Value: Int64); virtual;

    function Read (var   Data; const Size: Int64): Int64;
    function Write(const Data; const Size: Int64): Int64;

    procedure WriteLn(Any: array of const; const CRLF: Boolean = True);

    function StreamTo  (AStream: TStream): Int64;
    function StreamFrom(AStream: TStream): Int64;

    function Seek(const NewPos: Int64; const Origin: Integer): Int64; virtual;

    property Size:     Int64 read GetSize write SetSize;
    property Position: Int64 read GetPos  write SetPos;

    property BytesRead:    Int64 read fBytesRead;
    property BytesWritten: Int64 read fBytesWritten;

    property OnRead:  TStreamIOEvent read fOnRead  write fOnRead;
    property OnWrite: TStreamIOEvent read fOnWrite write fOnWrite;

    property CipherKey: Integer read fCipherKey write SetCipherKey;
  end;
{$ENDREGION}

{$REGION 'THandleStream'}
  THandleStream = class(TStream)
  public
    var Handle:      THandle;
    var CloseOnFree: Boolean;

    function GetSize: Int64; override;

    function InternalRead (var   Data; const Size: Int64): Int64; override;
    function InternalWrite(const Data; const Size: Int64): Int64; override;

    constructor Create(const AHandle: THandle);
    destructor  Destroy; override;

    function Seek(const NewPos: Int64; const Origin: Integer): Int64; override;
  end;
{$ENDREGION}

{$REGION 'TMemoryStream'}
  TMemoryStream = class(TStream)
  private
    fData: Pointer;
    fSize: Int64;

    fPosition: Int64;

    fAutoExpand: Boolean;

    function GetData(Index: Int64): Pointer;
  public
    constructor Create(const ASize: Int64 = 0);
    destructor  Destroy; override;

    function InternalRead (var   Data; const Size: Int64): Int64; override;
    function InternalWrite(const Data; const Size: Int64): Int64; override;

    function  GetSize: Int64;        override;
    procedure SetSize(Value: Int64); override;

    function Seek(const NewPos: Int64; const Origin: Integer): Int64; override;

    property AutoExpand: Boolean read fAutoExpand write fAutoExpand;

    property Data[Index: Int64]: Pointer read GetData; default;
  end;
{$ENDREGION}

implementation

uses
  libSassy.Strings,
  libSassy.Random;

{$REGION 'TStream->IStream mapping'}
function TStream.IStream_Read;
var
  i: Longint;
begin
  if pv = nil then exit(STG_E_INVALIDPOINTER);

  try
    i := Read(pv^, cb);
    if pcbRead <> nil then pcbRead^ := i;

    Result := S_OK;
  except
    Result := S_FALSE;
  end;
end;

function TStream.IStream_Write;
var
  i: Longint;
begin
  if pv = nil then exit(STG_E_INVALIDPOINTER);

  try
    i := Write(pv^, cb);
    if pcbWritten <> nil then pcbWritten^ := i;

    Result := S_OK;
  except
    Result := STG_E_CANTSAVE;
  end;
end;

function TStream.IStream_Seek;
var
  i: Int64;
begin
  if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then exit(STG_E_INVALIDFUNCTION);

  try
    i := Seek(dlibMove, dwOrigin);
    if @libNewPosition <> nil then libNewPosition := i;

    Result := S_OK;
  except
    Result := STG_E_INVALIDPOINTER;
  end;
end;

function TStream.IStream_SetSize;
begin
  try
    SetSize(libNewSize);

    if libNewSize <> Size then Result := E_FAIL else Result := S_OK;
  except
    Result := E_UNEXPECTED;
  end;
end;

function TStream.IStream_CopyTo;
const
  MaxBufSize = 1024 * 1024;
var
  Buf:       Pointer;
  BufSize:   Integer;
  i, n, r:   Integer;
  br, bw, w: Int64;
begin
  Result := S_OK;

  br := 0; bw := 0;

  try
    if cb > MaxBufSize then BufSize := MaxBufSize else BufSize := Integer(cb);

    GetMem(Buf, 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(Buf^, n);
          if r = 0 then exit;
          inc(br, r);

          w := 0;
          Result := stm.Write(Buf, r, @w);
          inc(bw, w);

          if (Result = S_OK) and (Integer(w) <> r) then Result := E_FAIL;
          if Result <> S_OK then exit;

          dec(i, r);
          dec(cb, r);
        end;
      end;
    finally
      FreeMem(Buf);

      if (@cbWritten <> nil) then cbWritten := bw;
      if (@cbRead    <> nil) then cbRead    := br;
    end;
  except
    Result := E_UNEXPECTED;
  end;
end;

function TStream.IStream_Commit;
begin
  Result := S_OK;
end;

function TStream.IStream_Revert;
begin
  Result := STG_E_REVERTED;
end;

function TStream.IStream_LockRegion;
begin
  Result := S_OK;//STG_E_INVALIDFUNCTION;
end;

function TStream.IStream_UnlockRegion;
begin
  Result := S_OK;//STG_E_INVALIDFUNCTION;
end;

function TStream.IStream_Stat;
begin
  Result := S_OK;

  try
    if (@statstg <> nil) then
    begin
      //FillChar(statstg, sizeof(statstg), 0);

      with statstg do
      begin
        dwType := STGTY_STREAM;
        cbSize := GetSize;
        mTime.dwLowDateTime  := 0;
        mTime.dwHighDateTime := 0;
        cTime.dwLowDateTime  := 0;
        cTime.dwHighDateTime := 0;
        aTime.dwLowDateTime  := 0;
        aTime.dwHighDateTime := 0;
        grfLocksSupported := LOCK_WRITE;
      end;
    end;
  except
    Result := E_UNEXPECTED;
  end;
end;

function TStream.IStream_Clone;
begin
  Result := S_OK;//E_NOTIMPL;
  stm := Self as IStream;
end;
{$ENDREGION}

{$REGION 'TStream'}
procedure TStream.SetCipherKey;
var
  i: Integer;
  r: TRandom;
begin
  fCipherKey := Value;
  r.Seed := fCipherKey;

  for i := 0 to CipherTableSize do
    fCipherTable[i] := round($FF * r.Next);
end;

procedure TStream.BlockCipher;
var
  i: Int64;
  p: PByte;
begin
  p := @Data;

  for i := 0 to Size do
  begin
    p^ := p^ xor fCipherTable[(Index + i) mod CipherTableSize];
    inc(p);
  end;
end;

constructor TStream.Create;
begin
  inherited;

  fBytesRead    := 0;
  fBytesWRitten := 0;

  fOnRead  := nil;
  fOnWrite := nil;

  fCipherKey := 0;

  FreeAfterOp := False;
end;

function TStream.InternalRead;
begin
  Result := 0;
end;

function TStream.InternalWrite;
begin
  Result := 0;
end;

function TStream.GetSize;
var
  SavedPos: Int64;
begin
  SavedPos := Position;

  try
    Seek(0, STREAM_SEEK_END);

    Result := Position;
  finally
    Position := SavedPos;
  end;
end;

procedure TStream.SetSize;
begin
  {}
end;

function TStream.GetPos;
begin
  Result := Seek(0, STREAM_SEEK_CUR);
end;

procedure TStream.SetPos;
begin
  Seek(Value, STREAM_SEEK_SET);
end;

function TStream.Read;
var
  CipherIndex: Int64;
begin
  CipherIndex := Position;

  Result := InternalRead(Data, Size);

  if fCipherKey <> 0 then
    BlockCipher(Data, Size, CipherIndex);

  if Result > 0 then
    InterlockedCompareExchange64(fBytesRead, fBytesRead + Result, fBytesRead);

  if Assigned(fOnRead) then fOnRead(Result);
end;

function TStream.Write;
var
  Buffer: array of Byte;
begin
  if fCipherKey <> 0 then
  begin
    SetLength(Buffer, Size);
    move(Data, Buffer[0], Size);

    BlockCipher(Buffer[0], Size, Position);

    Result := InternalWrite(Buffer[0], Size);
  end
  else
    Result := InternalWrite(Data, Size);

  if Result > 0 then
    InterlockedCompareExchange64(fBytesWritten, fBytesWritten + Result, fBytesWritten);

  if Assigned(fOnWrite) then fOnWrite(Result);
end;

procedure TStream.WriteLn;
var
  s: String;
begin
  s := s.From(Any);

  if CRLF then s := s + #13#10;

  Write(s[1], s.Size);
end;

function TStream.StreamTo;
const
  BufSize = 1024;
var
  Buffer:   array[0..BufSize] of Byte;
  BufRead:  Int64;
  BufWrite: Int64;
begin
  Result   := 0;
  BufWrite := 0;

  repeat
    BufRead := Read(Buffer[0], BufSize);
    if BufRead = 0 then break;

    BufWrite := AStream.Write(Buffer[0], BufRead);
    inc(Result, BufWrite);
  until BufRead <> BufWrite;

  if AStream.FreeAfterOp then
    AStream.Free;
end;

function TStream.StreamFrom;
var
  SavedOp: Boolean;
begin
  SavedOp     := FreeAfterOp;
  FreeAfterOp := False;

  try
    Result := AStream.StreamTo(Self);
  finally
    FreeAfterOp := SavedOp;
  end;

  if AStream.FreeAfterOp then
    AStream.Free;
end;

function TStream.Seek;
begin
  Result := 0;
end;
{$ENDREGION}

{$REGION 'THandleStream'}
function THandleStream.GetSize;
var
  Size: LongWord;
begin
  Result := GetFileSize(Handle, @Size);
  Result := Result or (Size shl 32);
end;

constructor THandleStream.Create;
begin
  inherited Create;

  Handle      := AHandle;
  CloseOnFree := True;
end;

destructor THandleStream.Destroy;
begin
  if CloseOnFree then
    CloseHandle(Handle);

  inherited;
end;

function THandleStream.InternalRead;
var
  i: Cardinal;
begin
  ReadFile(Handle, Data, Size, i, nil);
  Result := i;
end;

function THandleStream.InternalWrite;
var
  i: Cardinal;
begin
  WriteFile(Handle, Data, Size, i, nil);;
  Result := i;
end;

function THandleStream.Seek;
var
  PosLow:  Cardinal;
  PosHigh: Cardinal;
begin
  PosLow  :=  NewPos         and $FFFFFFFF;
  PosHigh := (NewPos shr 32) and $FFFFFFFF;

  Result := SetFilePointer(Handle, PosLow, @PosHigh, Origin);
  Result := Result or (PosHigh shl 32);
end;
{$ENDREGION}

{$REGION 'TMemoryStream'}
function TMemoryStream.GetData;
begin
  if fSize = 0 then Exit(nil);

  Result := Pointer(Cardinal(fData) + Index);
end;

constructor TMemoryStream.Create(const ASize: Int64 = 0);
begin
  inherited Create;

  fData       := nil;
  fPosition   := 0;
  fAutoExpand := True;

  SetSize(ASize);
end;

destructor TMemoryStream.Destroy;
begin
  SetSize(0);

  inherited;
end;

function TMemoryStream.InternalRead;
var
  p: Pointer;
begin
  if (fPosition + Size) > fSize then
    Result := fSize - fPosition
  else
    Result := Size;

  p := Pointer(Cardinal(fData) + fPosition);
  Move(p^, Data, Result);

  fPosition := fPosition + Result;
  if fPosition > fSize then fPosition := fSize;
end;

function TMemoryStream.InternalWrite;
var
  p: Pointer;
begin
  if (fPosition + Size) > fSize then
  begin
    if fAutoExpand then
    begin
      Self.Size := fPosition + Size;
      Result := Size;
    end
    else
      Result := fSize - fPosition;
  end
  else
    Result := Size;

  p := Pointer(Cardinal(fData) + fPosition);
  Move(Data, p^, Result);

  fPosition := fPosition + Result;
  if fPosition > fSize then fPosition := fSize;
end;

function TMemoryStream.GetSize;
begin
  Result := fSize;
end;

procedure TMemoryStream.SetSize;
begin
  if Value = 0 then
  begin
    if fData <> nil then FreeMem(fData);

    fData := nil;
    fSize := 0;
  end
  else
  begin
    if fData = nil then
      GetMem(fData, Value)
    else
      ReallocMem(fData, Value);

    fSize := Value;
  end;

  Seek(0, STREAM_SEEK_CUR);
end;

function TMemoryStream.Seek;
begin
  case Origin of
    STREAM_SEEK_SET: fPosition := NewPos;
    STREAM_SEEK_CUR: fPosition := fPosition + NewPos;
    STREAM_SEEK_END: fPosition := fSize - NewPos;
  else
    exit(STG_E_INVALIDFUNCTION);
  end;

  if fPosition < 0 then
    fPosition := 0
  else if fPosition > fSize then
    fPosition := fSize;

  Result := fPosition;
end;
{$ENDREGION}

end.