CentrED/UStreamHelper.pas

543 lines
17 KiB
Plaintext
Raw Normal View History

(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
{@abstract(This unit contains procedures and classes to help with stream handling.
It can be used to ease copying of streams and to assist in writing and reading
specialized types to/from streams.)
@bold(Warning!!!)@br
Due to a problem with generics in FPC 2.2.0 I introduced @link(TStreamType) as
workaround to reference the actual type of stream used inside the
@link(TStreamWrapper).
@author(Andreas Schneider <aksdb@gmx.de>)
@created(2007-07-08)
@lastmod(2007-11-14)}
unit UStreamHelper;
{$mode objfpc}{$H+}
interface
uses
Classes, RtlConsts, SysUtils, UIStream;
type
{@name is the stub for the method which will handle the OnProgress callbacks.
@param(ATotal Specifies the complete size of the operation.)
@param(ACurrent Specifies the current position during the operation.)}
TOnProgressEvent = procedure(ATotal, ACurrent: Cardinal) of object;
{ TFifoStream }
{@abstract(The @name contains special handling for queuing and dequeing. It is
meant to be used as a network queue.)}
TFifoStream = class(TStream)
destructor Destroy; override;
protected
FMemory: Pointer;
FSize, FRealSize, FPosition, FLockOffset: Longint;
FCapacity: Longint;
procedure SetCapacity(ANewCapacity: Longint);
procedure SetPointer(APtr: Pointer; ASize: Longint);
function GetOptimalCapacity(ANewCapacity: Longint): Longint;
function Realloc(var NewCapacity: Longint): Pointer; virtual;
property Capacity: Longint read FCapacity write SetCapacity;
public
function GetSize: Int64; override;
function Read(var Buffer; ACount: Longint): Longint; override;
function Write(const Buffer; ACount: Longint): Longint; override;
function Seek(AOffset: Longint; AOrigin: Word): Longint; override;
procedure LoadFromStream(AStream: TStream);
procedure SaveToStream(AStream: TStream);
procedure LoadFromFile(const FileName: string);
procedure SaveToFile(const FileName: string);
procedure SetSize(ANewSize: Longint); override;
procedure Clear;
procedure Dequeue(ACount: Longint); //<Removes a specified number of bytes from the queue. @param(ACount The number of bytes to remove from the queue.)
procedure Enqueue(const Buffer; ACount: Longint); //<Adds a specified number of bytes from a given buffer to the end of the queue. @param(Buffer The buffer containing the data to enqueue.) @param(ACount The number of bytes to enqueue from the buffer.)
procedure Lock(AOffset, ASize: Longint); //<Restricts the visible area of the stream. @param(AOffset is the starting position of the area.) @param(ASize The size of the area.)
procedure Unlock; //<Removes the restrictions from the stream and resets the visible area to the original size.
property Memory: Pointer read FMemory;
end;
{ TStreamWrapper }
{The @name is just a placeholder for the type used in the
@link(TStreamWrapper). It is currently in place to work around a problem with
generics in fpc 2.2.0}
TStreamType = TFifoStream;
//generic TStreamWrapper<TStreamType> = class(TObject{, IStream})
{@abstract(@name implements @link(IStream) and offers a bunch of functions to
ease reading and writing special types (like @link(Integer)s or @link(String)s.))}
TStreamWrapper = class(TObject, IStream)
constructor Create(AStream: TStreamType; AOwnsStream: Boolean = True); //<Creates a new instance of @classname. @param(AStream The underlying stream to perform the actual operations on.) @param(AOwnsStream Defines wheather to free the stream on destruction of @classname or not. Defaults to @false.)
destructor Destroy; override; //<Is called when the current instance of @classname is destroyed. If it owns the underlying stream it is destroyed aswell.
protected
FStream: TStream;
FOwnsStream: Boolean;
function GetStream: TStreamType;
procedure SetStream(AStream: TStreamType);
public
property Raw: TStreamType read GetStream write SetStream; //<Provides raw access to the underlying stream. Useful for manipulation of the stream position and other class specific calls.
function ReadBoolean: Boolean; //<Implementation of @link(IStream.ReadBoolean).
function ReadByte: Byte; //<Implementation of @link(IStream.ReadByte).
function ReadCardinal: Cardinal; //<Implementation of @link(IStream.ReadCardinal).
function ReadInteger: Integer; //<Implementation of @link(IStream.ReadInteger).
function ReadInt64: Int64; //<Implementation of @link(IStream.ReadInt64).
function ReadSmallInt: SmallInt; //<Implementation of @link(IStream.ReadSmallInt).
function ReadWord: Word; //<Implementation of @link(IStream.ReadWord).
function ReadString: string; //<Implementation of @link(IStream.ReadString).
function ReadStringFixed(ALength: Integer): string; //<Implementation of @link(IStream.ReadStringFixed).
procedure WriteBoolean(AValue: Boolean); //<Implementation of @link(IStream.WriteBoolean).
procedure WriteByte(AValue: Byte); //<Implementation of @link(IStream.WriteByte).
procedure WriteCardinal(AValue: Cardinal); //<Implementation of @link(IStream.WriteCardinal).
procedure WriteInteger(AValue: Integer); //<Implementation of @link(IStream.WriteInteger).
procedure WriteInt64(AValue: Int64); //<Implementation of @link(IStream.WriteInt64).
procedure WriteSmallInt(AValue: SmallInt); //<Implementation of @link(IStream.WriteSmallInt).
procedure WriteWord(AValue: Word); //<Implementation of @link(IStream.WriteWord).
procedure WriteString(AValue: string); //<Implementation of @link(IStream.WriteString).
procedure WriteStringFixed(AValue: string; ALength: Integer); //<Implementation of @link(IStream.WriteStringFixed).
function Read(ABuffer: PByte; ACount: Cardinal): Cardinal; //<Implementation of @link(IStream.Read).
function Write(ABuffer: PByte; ACount: Cardinal): Cardinal; //<Implementation of @link(IStream.Write).
procedure Skip(ACount: Cardinal); //<Implementation of @link(IStream.Skip).
end;
{@name is used to have a progress (see @link(TOnProgressEvent)) for a copy
action of the content of one stream into another. This is especially useful
for writing and reading to @link(TFileStream).
@param(ASource The stream from which the content is copied.)
@param(ATarget The stream to which the content is copied.)
@param(ACount Specifies the amount to copy. 0 means, that the whole stream is processed.)
@param(AOnProgress The callback for the @link(TOnProgressEvent). Defaults to @nil.)
@returns(The amount of bytes copied.)}
function StreamCopy(ASource, ATarget: TStream; ACount: Int64; AOnProgress: TOnProgressEvent = nil): Int64;
implementation
function StreamCopy(ASource, ATarget: TStream; ACount: Int64; AOnProgress: TOnProgressEvent = nil): Int64;
var
i, targetSize: Int64;
buffer: array[0..4095] of byte;
begin
Result := 0;
if (ACount = 0) then
begin
//This WILL fail for non-seekable streams...
ASource.Position := 0;
ACount := ASource.Size;
end;
targetSize := ACount;
while ACount > 0 do
begin
if (ACount > SizeOf(buffer)) then
i := SizeOf(Buffer)
else
i := ACount;
i := ASource.Read(buffer, i);
i := ATarget.Write(buffer, i);
if i = 0 then break;
Dec(ACount, i);
Inc(Result, i);
if Assigned(AOnProgress) then
AOnProgress(targetSize, Result);
end;
end;
{ TFifoStream }
const TMSGrow = 4096; { Use 4k blocks. }
destructor TFifoStream.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TFifoStream.SetCapacity(ANewCapacity: Longint);
begin
SetPointer(Realloc(ANewCapacity), FSize);
FCapacity := ANewCapacity;
end;
procedure TFifoStream.SetPointer(APtr: Pointer; ASize: Longint);
begin
FMemory := APtr;
FSize := ASize;
end;
function TFifoStream.GetOptimalCapacity(ANewCapacity: Longint): Longint;
begin
Result := ANewCapacity;
if Result <= 0 then
Result := 0
else
begin
// if growing, grow at least a quarter
if (Result > FCapacity) and (Result < (5 * FCapacity) div 4) then
Result := (5 * FCapacity) div 4;
// round off to block size.
Result := (Result + (TMSGrow-1)) and not (TMSGROW-1);
end;
end;
function TFifoStream.Realloc(var NewCapacity: Longint): Pointer;
begin
NewCapacity := GetOptimalCapacity(NewCapacity);
// Only now check !
if NewCapacity = FCapacity then
Result := FMemory
else
begin
Result := ReAllocMem(FMemory, NewCapacity);
if (Result = nil) and (NewCapacity > 0) then
raise EStreamError.Create(SMemoryStreamError);
end;
end;
function TFifoStream.GetSize: Int64;
begin
Result := FSize;
end;
function TFifoStream.Read(var Buffer; ACount: Longint): Longint;
begin
Result := 0;
If (FSize > 0) and (FPosition - FLockOffset < FSize) then
begin
Result := FSize - (FPosition - FLockOffset);
if Result > ACount then Result := ACount;
Move((FMemory + FPosition)^, Buffer, Result);
FPosition := FPosition + Result;
end;
end;
function TFifoStream.Write(const Buffer; ACount: Longint): Longint;
var
NewPos: Longint;
begin
Unlock;
if ACount = 0 then
Exit(0);
NewPos := FPosition + ACount;
if NewPos > FSize then
begin
if NewPos > FCapacity then
SetCapacity(NewPos);
FSize := NewPos;
end;
System.Move(Buffer, (FMemory + FPosition)^, ACount);
FPosition := NewPos;
Result := ACount;
end;
function TFifoStream.Seek(AOffset: Longint; AOrigin: Word): Longint;
begin
case AOrigin of
soFromBeginning : FPosition := AOffset + FLockOffset;
soFromEnd : FPosition := FSize + AOffset + FLockOffset;
soFromCurrent : FPosition := FPosition + AOffset;
end;
Result := FPosition - FLockOffset;
end;
procedure TFifoStream.LoadFromStream(AStream: TStream);
begin
Unlock;
AStream.Position := 0;
SetSize(AStream.Size);
If FSize > 0 then AStream.ReadBuffer(FMemory^,FSize);
end;
procedure TFifoStream.SaveToStream(AStream: TStream);
begin
if FSize > 0 then AStream.WriteBuffer((FMemory + FLockOffset)^, FSize);
end;
procedure TFifoStream.LoadFromFile(const FileName: string);
var
S: TFileStream;
begin
S := TFileStream.Create(FileName, fmOpenRead);
try
LoadFromStream(S);
finally
S.free;
end;
end;
procedure TFifoStream.SaveToFile(const FileName: string);
var
S: TFileStream;
begin
S := TFileStream.Create(FileName, fmCreate);
try
SaveToStream(S);
finally
S.free;
end;
end;
procedure TFifoStream.SetSize(ANewSize: Longint);
begin
Unlock;
SetCapacity(ANewSize);
FSize := ANewSize;
if FPosition > FSize then
FPosition := FSize;
end;
procedure TFifoStream.Clear;
begin
FSize := 0;
FRealSize := 0;
FPosition := 0;
FLockOffset := 0;
SetCapacity(0);
end;
procedure TFifoStream.Dequeue(ACount: Longint);
var
newCapacity, newSize: Longint;
queue, newMemory: Pointer;
begin
Unlock;
if ACount >= FSize then
begin
Size := 0;
Exit;
end;
queue := FMemory + ACount;
newSize := FSize - ACount;
newCapacity := GetOptimalCapacity(newSize);
if newCapacity <> FCapacity then
begin
newMemory := GetMem(newCapacity);
System.Move(queue^, newMemory^, newSize);
if (newMemory = nil) and (newCapacity > 0) then
raise EStreamError.Create(SMemoryStreamError);
FreeMem(FMemory);
FMemory := newMemory;
FCapacity := newCapacity;
end else
System.Move(queue^, FMemory^, newSize);
FSize := newSize;
if FPosition > ACount then
Dec(FPosition, ACount)
else
FPosition := 0;
end;
procedure TFifoStream.Enqueue(const Buffer; ACount: Longint);
var
oldPos: Int64;
begin
Unlock;
oldPos := FPosition;
FPosition := FSize;
Write(Buffer, ACount);
FPosition := oldPos;
end;
procedure TFifoStream.Lock(AOffset, ASize: Longint);
begin
if (FLockOffset <> 0) or (FRealSize <> 0) then Exit;
FLockOffset := AOffset;
FRealSize := FSize;
FSize := ASize;
end;
procedure TFifoStream.Unlock;
begin
if (FLockOffset = 0) and (FRealSize = 0) then Exit;
FLockOffset := 0;
FSize := FRealSize;
FRealSize := 0;
end;
{ TStreamWrapper }
constructor TStreamWrapper.Create(AStream: TStreamType; AOwnsStream: Boolean);
begin
inherited Create;
FStream := TStream(AStream);
FOwnsStream := AOwnsStream;
end;
destructor TStreamWrapper.Destroy;
begin
if FOwnsStream and Assigned(FStream) then FreeAndNil(FStream);
inherited Destroy;
end;
function TStreamWrapper.GetStream: TStreamType;
begin
Result := TStreamType(FStream);
end;
procedure TStreamWrapper.SetStream(AStream: TStreamType);
begin
FStream := TStream(AStream);
end;
function TStreamWrapper.ReadBoolean: Boolean;
begin
if not Assigned(FStream) then Exit(False);
FStream.Read(Result, SizeOf(Boolean));
end;
function TStreamWrapper.ReadByte: Byte;
begin
if not Assigned(FStream) then Exit(0);
FStream.Read(Result, SizeOf(Byte));
end;
function TStreamWrapper.ReadCardinal: Cardinal;
begin
if not Assigned(FStream) then Exit(0);
FStream.Read(Result, SizeOf(Cardinal));
end;
function TStreamWrapper.ReadInteger: Integer;
begin
if not Assigned(FStream) then Exit(0);
FStream.Read(Result, SizeOf(Integer));
end;
function TStreamWrapper.ReadInt64: Int64;
begin
if not Assigned(FStream) then Exit(0);
FStream.Read(Result, SizeOf(Int64));
end;
function TStreamWrapper.ReadSmallInt: SmallInt;
begin
if not Assigned(FStream) then Exit(0);
FStream.Read(Result, SizeOf(SmallInt));
end;
function TStreamWrapper.ReadWord: Word;
begin
if not Assigned(FStream) then Exit(0);
FStream.Read(Result, SizeOf(Word));
end;
function TStreamWrapper.ReadString: string;
begin
if not Assigned(FStream) then Exit('');
Result := ReadStringFixed(ReadInteger);
end;
function TStreamWrapper.ReadStringFixed(ALength: Integer): string;
begin
if not Assigned(FStream) then Exit('');
SetLength(Result, ALength);
FStream.Read(PChar(Result)^, ALength);
end;
procedure TStreamWrapper.WriteBoolean(AValue: Boolean);
begin
if not Assigned(FStream) then Exit;
FStream.Write(AValue, SizeOf(Boolean));
end;
procedure TStreamWrapper.WriteByte(AValue: Byte);
begin
if not Assigned(FStream) then Exit;
FStream.Write(AValue, SizeOf(Byte));
end;
procedure TStreamWrapper.WriteCardinal(AValue: Cardinal);
begin
if not Assigned(FStream) then Exit;
FStream.Write(AValue, SizeOf(Cardinal));
end;
procedure TStreamWrapper.WriteInteger(AValue: Integer);
begin
if not Assigned(FStream) then Exit;
FStream.Write(AValue, SizeOf(Integer));
end;
procedure TStreamWrapper.WriteInt64(AValue: Int64);
begin
if not Assigned(FStream) then Exit;
FStream.Write(AValue, SizeOf(Int64));
end;
procedure TStreamWrapper.WriteSmallInt(AValue: SmallInt);
begin
if not Assigned(FStream) then Exit;
FStream.Write(AValue, SizeOf(SmallInt));
end;
procedure TStreamWrapper.WriteWord(AValue: Word);
begin
if not Assigned(FStream) then Exit;
FStream.Write(AValue, SizeOf(Word));
end;
procedure TStreamWrapper.WriteString(AValue: string);
var
stringLength: Integer;
begin
if not Assigned(FStream) then Exit;
stringLength := Length(AValue);
WriteInteger(stringLength);
WriteStringFixed(AValue, stringLength);
end;
procedure TStreamWrapper.WriteStringFixed(AValue: string; ALength: Integer);
begin
if not Assigned(FStream) then Exit;
FStream.Write(PChar(AValue)^, ALength);
end;
function TStreamWrapper.Read(ABuffer: PByte; ACount: Cardinal): Cardinal;
begin
Result := FStream.Read(ABuffer^, ACount);
end;
function TStreamWrapper.Write(ABuffer: PByte; ACount: Cardinal): Cardinal;
begin
Result := FStream.Write(ABuffer^, ACount);
end;
procedure TStreamWrapper.Skip(ACount: Cardinal);
begin
FStream.Seek(ACount, soFromCurrent);
end;
end.