fpc/rtl/objpas/classes/streams.inc
fpc 50778076c3 initial import
git-svn-id: trunk@1 -
2005-05-16 18:37:41 +00:00

836 lines
18 KiB
PHP

{
$Id: streams.inc,v 1.9 2005/03/25 20:07:43 peter Exp $
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2000 by the Free Pascal development team
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{****************************************************************************}
{* TStream *}
{****************************************************************************}
{$ifdef seek64bit}
function TStream.GetPosition: Int64;
begin
Result:=Seek(0,soCurrent);
end;
procedure TStream.SetPosition(const Pos: Int64);
begin
Seek(pos,soBeginning);
end;
procedure TStream.SetSize64(const NewSize: Int64);
begin
// Required because can't use overloaded functions in properties
SetSize(NewSize);
end;
function TStream.GetSize: Int64;
var
p : int64;
begin
p:=Seek(0,soCurrent);
GetSize:=Seek(0,soEnd);
Seek(p,soBeginning);
end;
procedure TStream.SetSize(NewSize: Longint);
begin
// We do nothing. Pipe streams don't support this
// As wel as possible read-ony streams !!
end;
procedure TStream.SetSize(const NewSize: Int64);
begin
// Backwards compatibility that calls the longint SetSize
if (NewSize<Low(longint)) or
(NewSize>High(longint)) then
raise ERangeError.Create(SRangeError);
SetSize(longint(NewSize));
end;
function TStream.Seek(Offset: Longint; Origin: Word): Longint;
type
TSeek64 = function(const offset:Int64;Origin:TSeekorigin):Int64 of object;
var
CurrSeek,
TStreamSeek : TSeek64;
CurrClass : TClass;
begin
// Redirect calls to 64bit Seek, but we can't call the 64bit Seek
// from TStream, because then we end up in an infinite loop
CurrSeek:=nil;
CurrClass:=Classtype;
while (CurrClass<>nil) and
(CurrClass<>TStream) do
CurrClass:=CurrClass.Classparent;
if CurrClass<>nil then
begin
CurrSeek:=@Self.Seek;
TStreamSeek:=@TStream(@CurrClass).Seek;
if TMethod(TStreamSeek).Code=TMethod(CurrSeek).Code then
CurrSeek:=nil;
end;
if CurrSeek<>nil then
Result:=Seek(Int64(offset),TSeekOrigin(origin))
else
raise EStreamError.CreateFmt(SSeekNotImplemented,[ClassName]);
end;
function TStream.Seek(const Offset: Int64; Origin: TSeekorigin): Int64;
begin
// Backwards compatibility that calls the longint Seek
if (Offset<Low(longint)) or
(Offset>High(longint)) then
raise ERangeError.Create(SRangeError);
Result:=Seek(longint(Offset),ord(Origin));
end;
{$else seek64bit}
function TStream.GetPosition: Longint;
begin
Result:=Seek(0,soFromCurrent);
end;
procedure TStream.SetPosition(Pos: Longint);
begin
Seek(pos,soFromBeginning);
end;
function TStream.GetSize: Longint;
var
p : longint;
begin
p:=GetPosition;
GetSize:=Seek(0,soFromEnd);
Seek(p,soFromBeginning);
end;
procedure TStream.SetSize(NewSize: Longint);
begin
// We do nothing. Pipe streams don't support this
// As wel as possible read-ony streams !!
end;
{$endif seek64bit}
procedure TStream.ReadBuffer(var Buffer; Count: Longint);
begin
if Read(Buffer,Count)<Count then
Raise EReadError.Create(SReadError);
end;
procedure TStream.WriteBuffer(const Buffer; Count: Longint);
begin
if Write(Buffer,Count)<Count then
Raise EWriteError.Create(SWriteError);
end;
function TStream.CopyFrom(Source: TStream; Count: Int64): Int64;
var
i : Int64;
buffer : array[0..1023] of byte;
begin
CopyFrom:=0;
If (Count=0) then
begin
// This WILL fail for non-seekable streams...
Source.Position:=0;
Count:=Source.Size;
end;
while Count>0 do
begin
if (Count>sizeof(buffer)) then
i:=sizeof(Buffer)
else
i:=Count;
i:=Source.Read(buffer,i);
i:=Write(buffer,i);
if i=0 then break;
dec(count,i);
CopyFrom:=CopyFrom+i;
end;
end;
function TStream.ReadComponent(Instance: TComponent): TComponent;
var
Reader: TReader;
begin
Reader := TReader.Create(Self, 4096);
try
Result := Reader.ReadRootComponent(Instance);
finally
Reader.Free;
end;
end;
function TStream.ReadComponentRes(Instance: TComponent): TComponent;
begin
ReadResHeader;
Result := ReadComponent(Instance);
end;
procedure TStream.WriteComponent(Instance: TComponent);
begin
WriteDescendent(Instance, nil);
end;
procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent);
begin
WriteDescendentRes(ResName, Instance, nil);
end;
procedure TStream.WriteDescendent(Instance, Ancestor: TComponent);
var
Driver : TAbstractObjectWriter;
Writer : TWriter;
begin
Driver := TBinaryObjectWriter.Create(Self, 4096);
Try
Writer := TWriter.Create(Driver);
Try
Writer.WriteDescendent(Instance, Ancestor);
Finally
Writer.Destroy;
end;
Finally
Driver.Free;
end;
end;
procedure TStream.WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
var
FixupInfo: Integer;
begin
{ Write a resource header }
WriteResourceHeader(ResName, FixupInfo);
{ Write the instance itself }
WriteDescendent(Instance, Ancestor);
{ Insert the correct resource size into the resource header }
FixupResourceHeader(FixupInfo);
end;
procedure TStream.WriteResourceHeader(const ResName: string; {!!!: out} var FixupInfo: Integer);
begin
{ Numeric resource type }
WriteByte($ff);
{ Application defined data }
WriteWord($0a);
{ write the name as asciiz }
WriteBuffer(ResName[1],length(ResName));
WriteByte(0);
{ Movable, Pure and Discardable }
WriteWord($1030);
{ Placeholder for the resource size }
WriteDWord(0);
{ Return current stream position so that the resource size can be
inserted later }
FixupInfo := Position;
end;
procedure TStream.FixupResourceHeader(FixupInfo: Integer);
var
ResSize : Integer;
begin
ResSize := Position - FixupInfo;
{ Insert the correct resource size into the placeholder written by
WriteResourceHeader }
Position := FixupInfo - 4;
WriteDWord(ResSize);
{ Seek back to the end of the resource }
Position := FixupInfo + ResSize;
end;
procedure TStream.ReadResHeader;
begin
try
{ application specific resource ? }
if ReadByte<>$ff then
raise EInvalidImage.Create(SInvalidImage);
if ReadWord<>$000a then
raise EInvalidImage.Create(SInvalidImage);
{ read name }
while ReadByte<>0 do
;
{ check the access specifier }
if ReadWord<>$1030 then
raise EInvalidImage.Create(SInvalidImage);
{ ignore the size }
ReadDWord;
except
on EInvalidImage do
raise;
else
raise EInvalidImage.create(SInvalidImage);
end;
end;
function TStream.ReadByte : Byte;
var
b : Byte;
begin
ReadBuffer(b,1);
ReadByte:=b;
end;
function TStream.ReadWord : Word;
var
w : Word;
begin
ReadBuffer(w,2);
ReadWord:=w;
end;
function TStream.ReadDWord : Cardinal;
var
d : Cardinal;
begin
ReadBuffer(d,4);
ReadDWord:=d;
end;
Function TStream.ReadAnsiString : String;
Type
PByte = ^Byte;
Var
TheSize : Longint;
P : PByte ;
begin
ReadBuffer (TheSize,SizeOf(TheSize));
SetLength(Result,TheSize);
// Illegal typecast if no AnsiStrings defined.
if TheSize>0 then
begin
ReadBuffer (Pointer(Result)^,TheSize);
P:=Pointer(Result)+TheSize;
p^:=0;
end;
end;
Procedure TStream.WriteAnsiString (S : String);
Var L : Longint;
begin
L:=Length(S);
WriteBuffer (L,SizeOf(L));
WriteBuffer (Pointer(S)^,L);
end;
procedure TStream.WriteByte(b : Byte);
begin
WriteBuffer(b,1);
end;
procedure TStream.WriteWord(w : Word);
begin
WriteBuffer(w,2);
end;
procedure TStream.WriteDWord(d : Cardinal);
begin
WriteBuffer(d,4);
end;
{****************************************************************************}
{* THandleStream *}
{****************************************************************************}
Constructor THandleStream.Create(AHandle: Integer);
begin
FHandle:=AHandle;
end;
function THandleStream.Read(var Buffer; Count: Longint): Longint;
begin
Result:=FileRead(FHandle,Buffer,Count);
If Result=-1 then Result:=0;
end;
function THandleStream.Write(const Buffer; Count: Longint): Longint;
begin
Result:=FileWrite (FHandle,Buffer,Count);
If Result=-1 then Result:=0;
end;
{$ifdef seek64bit}
Procedure THandleStream.SetSize(NewSize: Longint);
begin
SetSize(Int64(NewSize));
end;
Procedure THandleStream.SetSize(const NewSize: Int64);
begin
FileTruncate(FHandle,NewSize);
end;
function THandleStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result:=FileSeek(FHandle,Offset,ord(Origin));
end;
{$else seek64bit}
Procedure THandleStream.SetSize(NewSize: Longint);
begin
FileTruncate(FHandle,NewSize);
end;
function THandleStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
Result:=FileSeek(FHandle,Offset,Origin);
end;
{$endif seek64bit}
{****************************************************************************}
{* TFileStream *}
{****************************************************************************}
constructor TFileStream.Create(const AFileName: string; Mode: Word);
begin
FFileName:=AFileName;
If Mode=fmcreate then
FHandle:=FileCreate(AFileName)
else
FHAndle:=FileOpen(AFileName,Mode);
If FHandle<0 then
If Mode=fmcreate then
raise EFCreateError.createfmt(SFCreateError,[AFileName])
else
raise EFOpenError.Createfmt(SFOpenError,[AFilename]);
end;
constructor TFileStream.Create(const AFileName: string; Mode: Word; Rights: Cardinal);
begin
FFileName:=AFileName;
If Mode=fmcreate then
FHandle:=FileCreate(AFileName)
else
FHAndle:=FileOpen(AFileName,Mode);
If FHandle<0 then
If Mode=fmcreate then
raise EFCreateError.createfmt(SFCreateError,[AFileName])
else
raise EFOpenError.Createfmt(SFOpenError,[AFilename]);
end;
destructor TFileStream.Destroy;
begin
FileClose(FHandle);
end;
{****************************************************************************}
{* TCustomMemoryStream *}
{****************************************************************************}
procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; ASize: Longint);
begin
FMemory:=Ptr;
FSize:=ASize;
end;
{$ifdef seek64bit}
function TCustomMemoryStream.GetSize: Int64;
begin
Result:=FSize;
end;
{$endif seek64bit}
function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
begin
Result:=0;
If (FSize>0) and (FPosition<Fsize) then
begin
Result:=FSize-FPosition;
If Result>Count then Result:=Count;
Move ((FMemory+FPosition)^,Buffer,Result);
FPosition:=Fposition+Result;
end;
end;
function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
Case Origin of
soFromBeginning : FPosition:=Offset;
soFromEnd : FPosition:=FSize+Offset;
soFromCurrent : FpoSition:=FPosition+Offset;
end;
Result:=FPosition;
end;
procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
begin
if FSize>0 then Stream.WriteBuffer (FMemory^,FSize);
end;
procedure TCustomMemoryStream.SaveToFile(const FileName: string);
Var S : TFileStream;
begin
S:=TFileStream.Create (FileName,fmCreate);
Try
SaveToStream(S);
finally
S.free;
end;
end;
{****************************************************************************}
{* TMemoryStream *}
{****************************************************************************}
Const TMSGrow = 4096; { Use 4k blocks. }
procedure TMemoryStream.SetCapacity(NewCapacity: Longint);
begin
SetPointer (Realloc(NewCapacity),Fsize);
FCapacity:=NewCapacity;
end;
function TMemoryStream.Realloc(var NewCapacity: Longint): Pointer;
Var MoveSize : Longint;
begin
If NewCapacity>0 Then // round off to block size.
NewCapacity := (NewCapacity + (TMSGrow-1)) and not (TMSGROW-1);
// Only now check !
If NewCapacity=FCapacity then
Result:=FMemory
else
If NewCapacity=0 then
FreeMem (FMemory,Fcapacity)
else
begin
GetMem (Result,NewCapacity);
If Result=Nil then
Raise EStreamError.Create(SMemoryStreamError);
If FCapacity>0 then
begin
MoveSize:=FSize;
If MoveSize>NewCapacity then MoveSize:=NewCapacity;
Move (Fmemory^,Result^,MoveSize);
FreeMem (FMemory,FCapacity);
end;
end;
end;
destructor TMemoryStream.Destroy;
begin
Clear;
Inherited Destroy;
end;
procedure TMemoryStream.Clear;
begin
FSize:=0;
FPosition:=0;
SetCapacity (0);
end;
procedure TMemoryStream.LoadFromStream(Stream: TStream);
begin
Stream.Position:=0;
SetSize(Stream.Size);
If FSize>0 then Stream.ReadBuffer(FMemory^,FSize);
end;
procedure TMemoryStream.LoadFromFile(const FileName: string);
Var S : TFileStream;
begin
S:=TFileStream.Create (FileName,fmOpenRead);
Try
LoadFromStream(S);
finally
S.free;
end;
end;
procedure TMemoryStream.SetSize(NewSize: Longint);
begin
SetCapacity (NewSize);
FSize:=NewSize;
IF FPosition>FSize then
FPosition:=FSize;
end;
function TMemoryStream.Write(const Buffer; Count: Longint): Longint;
Var NewPos : Longint;
begin
If Count=0 then
exit(0);
NewPos:=FPosition+Count;
If NewPos>Fsize then
begin
IF NewPos>FCapacity then
SetCapacity (NewPos);
FSize:=Newpos;
end;
System.Move (Buffer,(FMemory+FPosition)^,Count);
FPosition:=NewPos;
Result:=Count;
end;
{****************************************************************************}
{* TStringStream *}
{****************************************************************************}
procedure TStringStream.SetSize(NewSize: Longint);
begin
Setlength(FDataString,NewSize);
If FPosition>NewSize then FPosition:=NewSize;
end;
constructor TStringStream.Create(const AString: string);
begin
Inherited create;
FDataString:=AString;
end;
function TStringStream.Read(var Buffer; Count: Longint): Longint;
begin
Result:=Length(FDataString)-FPosition;
If Result>Count then Result:=Count;
// This supposes FDataString to be of type AnsiString !
Move (Pchar(FDataString)[FPosition],Buffer,Result);
FPosition:=FPosition+Result;
end;
function TStringStream.ReadString(Count: Longint): string;
Var NewLen : Longint;
begin
NewLen:=Length(FDataString)-FPosition;
If NewLen>Count then NewLen:=Count;
SetLength(Result,NewLen);
Read (Pointer(Result)^,NewLen);
end;
function TStringStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
Case Origin of
soFromBeginning : FPosition:=Offset;
soFromEnd : FPosition:=Length(FDataString)+Offset;
soFromCurrent : FpoSition:=FPosition+Offset;
end;
If FPosition>Length(FDataString) then FPosition:=Length(FDataString);
If FPosition<0 then FPosition:=0;
Result:=FPosition;
end;
function TStringStream.Write(const Buffer; Count: Longint): Longint;
begin
Result:=Count;
SetSize(FPosition+Count);
// This supposes that FDataString is of type AnsiString)
Move (Buffer,PCHar(FDataString)[Fposition],Count);
FPosition:=FPosition+Count;
end;
procedure TStringStream.WriteString(const AString: string);
begin
Write (PChar(Astring)[0],Length(AString));
end;
{****************************************************************************}
{* TResourceStream *}
{****************************************************************************}
procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
begin
end;
constructor TResourceStream.Create(Instance: THandle; const ResName: string; ResType: PChar);
begin
end;
constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
begin
end;
destructor TResourceStream.Destroy;
begin
end;
function TResourceStream.Write(const Buffer; Count: Longint): Longint;
begin
Write:=0;
end;
{****************************************************************************}
{* TOwnerStream *}
{****************************************************************************}
constructor TOwnerStream.Create(ASource: TStream);
begin
FSource:=ASource;
end;
destructor TOwnerStream.Destroy;
begin
If FOwner then
FreeAndNil(FSource);
inherited Destroy;
end;
{
$Log: streams.inc,v $
Revision 1.9 2005/03/25 20:07:43 peter
* add const to 64bit seeks
Revision 1.8 2005/02/14 17:13:31 peter
* truncate log
Revision 1.7 2005/01/20 16:37:57 peter
* 1.0.x fix
Revision 1.6 2005/01/19 19:57:57 michael
+ CustomMemoryStream.getsize overridden
Revision 1.5 2005/01/19 09:09:50 michael
* Patch from Peter to fix 64bit issue in tstream.seek()
Revision 1.4 2005/01/18 22:31:44 michael
+ Patch from Mattias Gaertner to fix CopyFrom
Revision 1.3 2005/01/09 13:15:37 michael
+ Added TOwnerStream
}