utils/uutlStreamHelper.pas

unit uutlStreamHelper;

{ Package:      Utils
  Prefix:       utl - UTiLs
  Beschreibung: diese Unit enthält Klassen zum lesen und schreiben von Werten in einen Stream
                TutlStreamReader - Wrapper für beliebige Streams, handelt Datentypen
                TutlStreamWriter - Wrapper für beliebige Streams, handelt Datentypen }

{$mode objfpc}{$H+}

interface

uses
  Classes, Contnrs, syncobjs;

type
  TutlFourCC = string[4];

  { TutlStreamUtility }

  TutlStreamUtility = class
  private
    FStream: TStream;
    FOwnsStream: boolean;
    FPositions: TStack;
  protected
  public
    constructor Create(BaseStream: TStream; OwnsStream: Boolean=false);
    destructor Destroy; override;
    property Stream: TStream read FStream;
    procedure Push;
    procedure Pop;
    procedure Drop;
  end;

  { TutlStreamReader }

  TutlStreamReader = class(TutlStreamUtility)
  protected
    function ReadBuffer(Var Buffer; Size: int64): int64;
  public
    function ReadFourCC: TutlFourCC;
    function CheckFourCC(Correct: TutlFourCC): boolean;
    function ReadByte: Byte;
    function ReadWord: Word;
    function ReadCardinal: Cardinal;
    function ReadInteger: Integer;
    function ReadInt64: Int64;
    function ReadSingle: Single;
    function ReadDouble: Double;
    function ReadAnsiString: AnsiString;
    function ReadLine: AnsiString;
    function IsEOF: boolean;
  end;

  { TutlStreamWriter }

  TutlStreamWriter = class(TutlStreamUtility)
  protected
    procedure WriteBuffer(var Data; Size: int64);
  public
    procedure WriteFourCC(FCC: TutlFourCC);
    procedure WriteByte(A: Byte);
    procedure WriteWord(A: Word);
    procedure WriteCardinal(A: Cardinal);
    procedure WriteInteger(A: Integer);
    procedure WriteInt64(A: Int64);
    procedure WriteSingle(A: Single);
    procedure WriteDouble(A: Double);
    procedure WriteAnsiString(A: AnsiString);
    procedure WriteAnsiBytes(A: AnsiString);
    procedure WriteLine(A: AnsiString);
  end;

  { TutlReadBufferStream }

  TutlReadBufferStream = class(TStream)
  private
    FBaseStream: TStream;
    FBuffer: Pointer;
    FBufferValid: boolean;
    FBufferStart, FBufferLen, FBufferAvail: Int64;
    FPosition: int64;
    FOwnsStream: Boolean;
  protected
    function GetSize: Int64; override;
    procedure SetSize(const NewSize: Int64); override;
  public
    constructor Create(const BaseStream: TStream; const BufferSize: Cardinal; const aOwnsStream: Boolean = false);
    destructor Destroy; override;
    function Read(var Buffer; Count: Integer): Integer; override;
    function Write(const Buffer; Count: Integer): Integer; override;
    function Seek(Offset: Integer; Origin: Word): Integer; override;
  end;

  { TutlFIFOStream }

  TutlFIFOStream = class(TStream)
  private const MAX_PAGE_SIZE = 4096;
  private type
    PPage = ^TPage;
    TPage = record
      Next: PPage;
      Data: packed array[0..MAX_PAGE_SIZE-1] of byte;
    end;
  private
    fLockFree: boolean;
    fPageFirst, fPageLast: PPage;
    fReadPtr, fWritePtr: Cardinal;
    fTotalSize: Int64;
    fDataLock: TCriticalSection;
  protected
    function GetSize: Int64; override;
  public
    constructor Create(const aLockFree: boolean = false);
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Reserve(var Buffer; Count: Longint): Longint;
    function Discard(Count: Longint): Longint;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(const {%H-}Offset: Int64; {%H-}Origin: TSeekOrigin): Int64; override; overload;
    procedure BeginOperation;
    procedure EndOperation;
    procedure Clear;
    property LockFree: boolean read fLockFree;
  end;

  TutlBase64Decoder = class(TStringStream)
  public const
    CODE64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
    PADDING_CHARACTER = '=';
  protected
  public
    function Read(var Buffer; Count: Longint): Longint; override;
    function Decode(const aOutput: TStream): boolean;
    constructor Create;
  end;

implementation

uses SysUtils,RtlConsts, uutlExceptions;

type
  TPositionData = class
    Position: Int64;
  constructor Create(Pos: Int64);
  end;

constructor TPositionData.Create(Pos: Int64);
begin
  inherited Create;
  Position:= Pos;
end;

{ TutlStreamUtility }

constructor TutlStreamUtility.Create(BaseStream: TStream; OwnsStream: Boolean);
begin
  inherited Create;
  FStream:= BaseStream;
  FOwnsStream:= OwnsStream;
  FPositions:= TStack.Create;
end;

destructor TutlStreamUtility.Destroy;
begin
  if FOwnsStream then
    FreeAndNil(FStream)
  else
    FStream:= nil;
  while FPositions.AtLeast(1) do
    TPositionData(FPositions.Pop).Free;
  FreeAndNil(FPositions);
  inherited;
end;

procedure TutlStreamUtility.Pop;
var
  p: TPositionData;
begin
  p:= TPositionData(FPositions.Pop);
  FStream.Position:= p.Position;
  p.Free;
end;

procedure TutlStreamUtility.Drop;
var
  p: TPositionData;
begin
  p:= TPositionData(FPositions.Pop);
  if Assigned(p) then
    p.Free;
end;

procedure TutlStreamUtility.Push;
begin
  FPositions.Push(TPositionData.Create(FStream.Position));
end;

{ TutlStreamReader }

function TutlStreamReader.ReadBuffer(var Buffer; Size: int64): int64;
begin
  if (FStream.Position + Size > FStream.Size) then
    raise EInvalidOperation.Create('stream is to small');
  Result:= FStream.Read(Buffer, Size);
end;

function TutlStreamReader.ReadFourCC: TutlFourCC;
begin
  SetLength(Result, 4);
  ReadBuffer(Result[1], 4);
end;

function TutlStreamReader.CheckFourCC(Correct: TutlFourCC): boolean;
begin
  Result:= ReadFourCC=Correct;
end;

function TutlStreamReader.ReadByte: Byte;
begin
  ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadWord: Word;
begin
  ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadCardinal: Cardinal;
begin
  ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadInteger: Integer;
begin
  ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadInt64: Int64;
begin
  ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadSingle: Single;
begin
  ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadDouble: Double;
begin
  ReadBuffer(Result{%H-}, Sizeof(Result));
end;

function TutlStreamReader.ReadAnsiString: AnsiString;
begin
  SetLength(Result, ReadCardinal);
  ReadBuffer(Result[1], Length(Result));
end;

function TutlStreamReader.ReadLine: AnsiString;
const
  READ_LENGTH = 80;
var
  rp, rl: integer;
  cp: PAnsiChar;
  bpos: Int64;
  r: integer;
  EOF: Boolean;

  procedure ReadSome;
  begin
    SetLength(Result, rl + READ_LENGTH);
    r:= FStream.Read(Result[rl + 1], READ_LENGTH);
    inc(rl, r);
    EOF:= r <> READ_LENGTH;
    cp:= @Result[rp];
  end;

begin
  Result:= '';
  rl:= 0;
  bpos:= FStream.Position;
  repeat
    rp:= rl + 1;
    ReadSome;
    while rp <= rl do begin
      if cp^ in [#10, #13] then begin
        inc(bpos, rp);
        // never a second char after #10
        if cp^ = #13 then begin
          if (rp = rl) and not EOF then begin
            ReadSome;
          end;
          if (rp <= rl) then begin
            inc(cp);
            if cp^ = #10 then
              inc(bpos);
          end;
        end;
        FStream.Position:= bpos;
        SetLength(Result, rp-1);
        Exit;
      end;
      inc(cp);
      inc(rp);
    end;
  until EOF;
  SetLength(Result, rl);
end;

function TutlStreamReader.IsEOF: boolean;
begin
  Result:= FStream.Position = FStream.Size;
end;


{ TutlStreamWriter }

procedure TutlStreamWriter.WriteBuffer(var Data; Size: int64);
begin
  FStream.Write(Data, Size);
end;

procedure TutlStreamWriter.WriteFourCC(FCC: TutlFourCC);
begin
  WriteBuffer(FCC[1], 4);
end;

procedure TutlStreamWriter.WriteByte(A: Byte);
begin
  WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteWord(A: Word);
begin
  WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteCardinal(A: Cardinal);
begin
  WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteInteger(A: Integer);
begin
  WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteInt64(A: Int64);
begin
  WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteSingle(A: Single);
begin
  WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteDouble(A: Double);
begin
  WriteBuffer(A, SizeOf(a));
end;

procedure TutlStreamWriter.WriteAnsiString(A: AnsiString);
begin
  WriteCardinal(Length(A));
  WriteBuffer(A[1], Length(a));
end;

procedure TutlStreamWriter.WriteAnsiBytes(A: AnsiString);
begin
  WriteBuffer(A[1], Length(A));
end;

procedure TutlStreamWriter.WriteLine(A: AnsiString);
begin
  WriteAnsiBytes(A + sLineBreak);
end;

{ TutlReadBufferStream }

constructor TutlReadBufferStream.Create(const BaseStream: TStream; const BufferSize: Cardinal;
  const aOwnsStream: Boolean);
begin
  inherited Create;
  FBaseStream:= BaseStream;
  FBufferLen:= BufferSize;
  FBuffer:= GetMemory(FBufferLen);
  FOwnsStream := aOwnsStream;
  FPosition:= 0;
end;

destructor TutlReadBufferStream.Destroy;
begin
  FBufferValid:= false;
  if (FOwnsStream) then
    FBaseStream.Free;
  FreeMemory(FBuffer);
  inherited;
end;

function TutlReadBufferStream.Seek(Offset: Integer; Origin: Word): Integer;
begin
  case Origin of
    soFromBeginning: FPosition := Offset;
    soFromCurrent: Inc(FPosition, Offset);
    soFromEnd: FPosition := Size + Offset;
  end;
  Result := FPosition;
end;

function TutlReadBufferStream.GetSize: Int64;
begin
  Result:= FBaseStream.Size;
end;

procedure TutlReadBufferStream.SetSize(const NewSize: Int64);
begin
  FBaseStream.Size:= NewSize;
end;

function TutlReadBufferStream.Write(const Buffer; Count: Integer): Integer;
begin
  FBufferValid:= false;
  FBaseStream.Position:= FPosition;
  Result:= FBaseStream.Write(Buffer, Count);
  FPosition:= FBaseStream.Position;
end;

function TutlReadBufferStream.Read(var Buffer; Count: Integer): Integer;
var
  rp, br, c: Int64;
  bp: Pointer;
begin
  br:= 0;
  bp:= @Buffer;
  while (br < Count) and (FPosition<Size) do begin
    // Welches Buffer-Segment wird gesucht?
    rp:= (FPosition div FBufferLen) * FBufferLen;
    // ist das das aktuelle?
    if not FBufferValid or (FBufferStart <> rp) then begin
      // Segment holen
      FBaseStream.Position:= rp;
      FBufferAvail:= FBaseStream.Read(FBuffer^, FBufferLen);
      FBufferStart:= rp;
      FBufferValid:= true;
    end;

    // Wie viel Daten daraus brauchen wir bzw. können wir kriegen?
    c:= Count - br;
    if c > FBufferAvail - (FPosition-FBufferStart) then
      c:= FBufferAvail - (FPosition-FBufferStart);

    // das rausholen und buffer weiterschieben
    {$IFDEF FPC}
    // FPC: kein Cast, direkt mit Pointer in richtiger Größe rechnen
    Move(Pointer(FBuffer + (FPosition-FBufferStart))^, bp^, c);
    Inc(Bp, c);
    {$ELSE}
    // Delphi ist eh nur i386, also fix 32bit
    Move(Pointer(Cardinal(FBuffer) + (FPosition-FBufferStart))^, bp^, c);
    Inc(Cardinal(Bp), c);
    {$ENDIF}
    Inc(br, c);
    Inc(FPosition, c);
  end;
  Result:= br;
end;

{ TutlFIFOStream }

constructor TutlFIFOStream.Create(const aLockFree: boolean);
begin
  inherited Create;
  fDataLock:= TCriticalSection.Create;
  fTotalSize:= 0;
  New(fPageFirst);
  fPageFirst^.Next:= nil;
  fPageLast:= fPageFirst;
  fReadPtr:= 0;
  fWritePtr:= 0;
  fLockFree:= aLockFree;
end;

destructor TutlFIFOStream.Destroy;
begin
  Clear;
  Dispose(fPageFirst);
  FreeAndNil(fDataLock);
  inherited Destroy;
end;

function TutlFIFOStream.GetSize: Int64;
begin
  Result:= fTotalSize;
end;

function TutlFIFOStream.Read(var Buffer; Count: Longint): Longint;
begin
  BeginOperation;
  try
    Result:= Reserve(Buffer, Count);
    Discard(Result);
  finally
    EndOperation;
  end;
end;

function TutlFIFOStream.Reserve(var Buffer; Count: Longint): Longint;
var
  pbuf: PByteArray;
  mx: LongInt;
  rp: Int64;
  p: PPage;
begin
  BeginOperation;
  try
    pbuf:= @Buffer;
    Result:= 0;
    rp:= fReadPtr;
    p:= fPageFirst;
    while Count > 0 do begin
      mx:= MAX_PAGE_SIZE - rp;
      if mx > Count then mx:= Count;
      if (p=fPageLast) and (mx > fWritePtr-rp) then mx:= fWritePtr-rp;
      if mx=0 then exit;
      Move(p^.Data[rp], pbuf^[Result], mx);
      inc(rp, mx);
      inc(Result, mx);
      Dec(Count, mx);
      if rp = MAX_PAGE_SIZE then begin
        p:= p^.Next;
        rp:= 0;
      end;
    end;
  finally
    EndOperation;
  end;
end;

function TutlFIFOStream.Discard(Count: Longint): Longint;
var
  mx: LongInt;
  n: PPage;
begin
  BeginOperation;
  try
    Result:= 0;
    while Count > 0 do begin
      mx:= MAX_PAGE_SIZE - fReadPtr;
      if mx > Count then mx:= Count;
      if (fPageFirst=fPageLast) and (mx > fWritePtr-fReadPtr) then mx:= fWritePtr-fReadPtr;
      if mx=0 then exit;
      inc(fReadPtr, mx);
      inc(Result, mx);
      dec(Count, mx);
      dec(fTotalSize, mx);
      if fReadPtr=MAX_PAGE_SIZE then begin
        n:= fPageFirst^.Next;
        if Assigned(n) then begin
          Dispose(fPageFirst);
          fPageFirst:= n;
          fReadPtr:= 0;
        end;// else kann nicht passieren, das wird mit (mx > fWritePtr-fReadPtr) und (mx=0) schon bedient
      end;
    end;
  finally
    EndOperation;
  end;
end;

function TutlFIFOStream.Write(const Buffer; Count: Longint): Longint;
var
  mx: LongInt;
  pbuf: PByteArray;
begin
  BeginOperation;
  try
    pbuf:= @Buffer;
    Result:= 0;
    while Count > 0 do begin
      mx:= MAX_PAGE_SIZE - fWritePtr;
      if mx > Count then mx:= Count;
      Move(pbuf^[Result], fPageLast^.Data[fWritePtr], mx);
      inc(fWritePtr, mx);
      inc(fTotalSize, mx);
      dec(Count, mx);
      inc(Result, mx);

      if fWritePtr = MAX_PAGE_SIZE then begin
        New(fPageLast^.Next);
        fPageLast:= fPageLast^.Next;
        fPageLast^.Next:= nil;
        fWritePtr:= 0;
      end;
    end;
  finally
    EndOperation;
  end;
end;

function TutlFIFOStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  Result:= 0;
  raise EStreamError.CreateFmt(SStreamInvalidSeek,[ClassName]);
end;

procedure TutlFIFOStream.BeginOperation;
begin
  if not fLockFree then
    fDataLock.Acquire;
end;

procedure TutlFIFOStream.EndOperation;
begin
  if not fLockFree then
    fDataLock.Release;
end;

procedure TutlFIFOStream.Clear;
var
  p: PPage;
begin
  BeginOperation;
  try
    while fPageFirst<>fPageLast do begin
      p:= fPageFirst;
      fPageFirst:= fPageFirst^.Next;
      Dispose(p);
    end;
    fTotalSize:= 0;
    fReadPtr:= 0;
    fWritePtr:= 0;
  finally
    EndOperation;
  end;
end;

{ TutlBase64Decoder }

function TutlBase64Decoder.{%H-}Read(var Buffer; Count: Longint): Longint;
begin
  ReadNotImplemented;
end;

function TutlBase64Decoder.Decode(const aOutput: TStream): boolean;
var
  a: Integer;
  x: Integer;
  b: Integer;
  c: AnsiChar;
begin
  Result:= false;
  a := 0;
  b := 0;
  Position:= 0;
  while inherited Read(c{%H-}, sizeof(c)) = sizeof(c) do begin
    x := Pos(c, CODE64) - 1;
    if (x >= 0) then begin
      b := b * 64 + x;
      a := a + 6;
      if a >= 8 then begin
        a := a - 8;
        x := b shr a;
        b := b mod (1 shl a);
        aOutput.WriteByte(x);
      end;
    end else if c = PADDING_CHARACTER then
      break
    else
      Exit;
  end;
  Result:= true;
end;

constructor TutlBase64Decoder.Create;
begin
  inherited Create('');
end;


end.