Unit Classes;
{
LVCL - Very LIGHT VCL routines
------------------------------
Tiny replacement for the standard VCL Classes.pas
Just put the LVCL directory in your Project/Options/Directories/SearchPath
and your .EXE will shrink from 300KB to 30KB
Notes:
- implements TComponent+TFileStream+TList+TMemoryStream+TPersistent+TReader
+TResourceStream+TStream+TStringList
- compatible with the standard .DFM files
- only use existing properties in your DFM, otherwise you'll get error on startup
- TList and TStringList are simplier than standard ones
- TStrings is not implemented (but mapped to TStringList)
- TMemoryStream use faster Delphi heap manager, not the slow GlobalAlloc()
- TThread simple implementation (on Windows only)
- Cross-Platform: it can be used on (Cross)Kylix under Linux (tested)
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in
compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS"
basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
License for the specific language governing rights and limitations
under the License.
The Initial Developer of the Original Code is Arnaud Bouchez.
This work is Copyright (c)2008 Arnaud Bouchez - http://bouchez.info
Emulates the original Delphi/Kylix Cross-Platform Runtime Library
(c)2000,2001 Borland Software Corporation
Portions created by Paul Toth are (c)2001 Paul Toth - http://tothpaul.free.fr
All Rights Reserved.
Some modifications by Leonid Glazyrin, Feb 2012 <leonid.glazyrin@gmail.com>
* New types of DFM properties supported: List and Set
* Some (or maybe all) unsupported (sub)properties in DFM ignored without errors
}
{.$define debug} // send error messages from TReader in a Console window
{$ifdef debug} {$APPTYPE CONSOLE} {$endif}
{$WARNINGS OFF}
Interface
uses
SysUtils,
{$ifdef Win32}
Windows;
{$else}
Types,
LibC;
{$endif}
type
EClassesError = class(Exception);
TNotifyEvent = procedure(Sender:TObject) of object;
TPointerList = array of Pointer;
TList = class
protected
fList: TPointerList;
private
fCount: integer;
fSize: integer;
fOwnObjects: boolean;
function GetItem(index: integer): pointer;
procedure SetItem(index: integer; value: pointer);
procedure Grow;
procedure FreeObjects;
procedure SetCount(number: integer);
procedure Error(index: integer);
public
destructor Destroy; override;
function Add(Item: pointer): integer;
procedure Insert(index: integer; item: pointer);
procedure Remove(item: pointer);
procedure Delete(index: integer);
function IndexOf(item: pointer): integer;
procedure Clear;
property Count: integer read fCount write SetCount;
property Items[index: integer]: pointer read GetItem write SetItem; default;
// can be used in order to speed up code a little bit (but no index check)
property List: TPointerList read fList;
end;
TObjectList = class(TList)
public
constructor Create;
end;
TStringList = class;
TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
TStringList = class
private
fListStr: array of AnsiString;
// fListObj[] is allocated only if objects are used (not nil)
fListObj: array of TObject;
fCount: integer;
fSize : integer;
fCaseSensitive: boolean;
function GetItem(index: integer): string;
procedure SetItem(index: integer; const value: string);
function GetObject(index: integer): TObject;
procedure SetObject(index: integer; value: TObject);
function GetText: string;
procedure SetText(const Value: string);
protected
procedure QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
public
function Add(const s: string): integer;
function AddObject(const s: string; AObject: TObject): integer;
procedure Delete(index: integer);
function IndexOf(const s: string): integer;
function IndexOfObject(item: pointer): integer;
function IndexOfName(const Name: string; const Separator: string='='): integer;
function ValueOf(const Name: string; const Separator: string='='): string;
function NameOf(const Value: string; const Separator: string='='): string;
procedure Clear;
function TextLen: integer;
procedure LoadFromFile(const FileName: string);
procedure SaveToFile(const FileName: string);
procedure CustomSort(Compare: TStringListSortCompare);
property Count: integer read fCount;
property CaseSensitive: boolean read fCaseSensitive write fCaseSensitive;
property Strings[index: integer]: string read GetItem write SetItem; default;
property Objects[index: integer]: TObject read GetObject write SetObject;
property Text: string read GetText write SetText;
end;
TStrings = TStringList; // for easy debugging
const
fmCreate = $FFFF;
// used in TStream.Seek()
soFromBeginning = 0;
soFromCurrent = 1;
soFromEnd = 2;
type
TStream = class
protected
procedure SetPosition(value: integer); virtual;
function GetPosition: integer; virtual;
function GetSize: integer; virtual;
procedure SetSize(Value: integer); virtual;
public
function Read(var Buffer; Count: integer): integer; virtual; abstract;
procedure ReadBuffer(var Buffer; Count: integer);
function Write(const Buffer; Count: integer): integer; virtual; abstract;
function Seek(Offset: integer; Origin: Word): integer; virtual; abstract;
procedure Clear;
procedure LoadFromStream(aStream: TStream); virtual;
procedure SaveToStream(aStream: TStream); virtual;
procedure LoadFromFile(const FileName: string);
procedure SaveToFile(const FileName: string);
function CopyFrom(Source: TStream; Count: integer): integer;
property Size: integer read GetSize write SetSize;
property Position: integer read GetPosition write SetPosition;
end;
THandleStream = class(TStream)
private
fHandle: THandle;
protected
procedure SetSize(Value: integer); override;
public
constructor Create(aHandle: THandle);
function Read(var Buffer; count: integer): integer; override;
function Write(const Buffer; Count: integer): integer; override;
function Seek(Offset: integer; Origin: Word): integer; override;
property Handle: THandle read fHandle;
end;
TFileStream = class(THandleStream)
private
fFileName: string;
protected
{$ifdef Linux} // this special function use stat() instead of seek()
function GetSize: cardinal; override; {$endif}
public
constructor Create(const FileName: string; Mode: Word);
destructor Destroy; override;
end;
TCustomMemoryStream = class(TStream)
protected
fPosition, fSize: integer;
fMemory: pointer;
procedure SetPosition(value: integer); override;
function GetPosition: integer; override;
function GetSize: integer; override;
procedure SetSize(Value: integer); override;
public
function Read(var Buffer; count: integer): integer; override;
procedure SetPointer(Buffer: pointer; Count: integer);
function Seek(Offset: integer; Origin: Word): integer; override;
procedure SaveToStream(aStream: TStream); override;
property Memory: pointer read fMemory;
end;
TResourceStream = class(TCustomMemoryStream)
public
constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
end;
TMemoryStream = class(TCustomMemoryStream)
protected
fCapacity: integer;
procedure SetSize(Value: integer); override;
procedure SetCapacity(Value: integer);
public
destructor Destroy; override;
function Write(const Buffer; Count: integer): integer; override;
procedure LoadFromStream(aStream: TStream); override;
end;
{$ifdef Win32}
TFilerFlag = (ffInherited, ffChildPos, ffInline);
TFilerFlags = set of TFilerFlag;
PValueType = ^TValueType;
TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64,
vaUTF8String);
TComponent = class;
TReader = class
private
fHandle: HGlobal;
fStart: integer;
fPointer: pByte;
fSize: integer;
fPosition: integer;
fNotifyLoaded: TList;
procedure SetPosition(Value: integer);
public
constructor Create(const ResourceName: string);
destructor Destroy; override;
procedure Loading(AComponent: TComponent);
function Read(var Data; DataSize: integer): integer;
function EndOfList: boolean;
function ReadValueType: TValueType;
function BooleanProperty: boolean;
function IntegerProperty: integer;
function StringProperty: string;
function ColorProperty: integer;
function BinaryProperty(var Size: integer):pointer;
procedure IdentProperty(var aValue; aTypeInfo: pointer);
procedure SetProperty(var ASet; aTypeInfo: pointer);
function ReadByte: byte;
function ReadWord: word;
function ReadInteger: integer;
function ReadString: AnsiString;
function ReadShortString: shortstring;
function ReadUTF8String: string;
function ReadWString: string;
procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: integer);
procedure ReadList;
procedure ReadSet;
procedure ReadStrings(Strings: TStrings);
procedure AnyProperty;
property Size: integer read fSize;
property Position: integer read fPosition write SetPosition;
end;
/// in LVCL, TPersistent don't have any RTTI information compiled within
// - RTTI is not needed with LVCL and will increase code size
// - if you need RTTI, you should use {$M+} explicitely
TPersistent = class
protected
function SubProperty(const Name: string): TPersistent; virtual;
procedure ReadProperty(const Name: string; Reader: TReader); virtual;
end;
TPersistentClass = class of TPersistent;
TComponent = class(TPersistent)
private
fOwner: TComponent;
fComponents: TObjectList;
protected
fCompName: string;
/// Provides the interface for a method that changes the parent of the component
procedure SetParentComponent(Value: TComponent); virtual;
/// Returns the parent of the component
function GetParentComponent: TComponent; virtual;
public
/// Allocates memory and constructs a safely initialized instance of a component
constructor Create(AOwner: TComponent); virtual;
destructor Destroy; override;
procedure ReadProperties(Reader: TReader);
procedure Loaded; virtual;
/// Indicates the component that is responsible for streaming and freeing this component
property Owner: TComponent read fOwner;
/// Get of set the parent of the component
property ParentComponent: TComponent read GetParentComponent write SetParentComponent;
/// Indicates the number of components owned by the component
function ComponentCount: integer;
/// if not nil, lists all components owned by the component
property Components: TObjectList read fComponents;
/// the component name
property Name: string read fCompName;
end;
TComponentClass = class of TComponent;
/// minimal Threading implementation, using direct Windows API
TThread = class
private
FHandle,
FThreadID: THandle;
FFinished,
FTerminated,
FSuspended,
FCreateSuspended,
FFreeOnTerminate: Boolean;
FOnTerminate: TNotifyEvent;
procedure SetSuspended(Value: Boolean);
protected
procedure Execute; virtual; abstract;
public
constructor Create(CreateSuspended: Boolean);
procedure AfterConstruction; override;
destructor Destroy; override;
procedure Resume;
procedure Suspend;
function WaitFor: LongWord;
procedure Terminate;
property Handle: THandle read FHandle;
property ThreadID: THandle read FThreadID;
property Suspended: Boolean read FSuspended write SetSuspended;
property Terminated: Boolean read FTerminated;
property FreeOnTerminate: Boolean read FFreeOnTerminate
write FFreeOnTerminate;
property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
end;
procedure RegisterClasses(const AClasses: array of TPersistentClass);
{$endif}
// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper)
// (only exists in LVCL)
function IdemPChar(p, up: PChar): boolean;
implementation
procedure TList.FreeObjects;
var i: integer;
begin
if fOwnObjects then
for i := 0 to fCount-1 do
TObject(fList[i]).Free;
end;
destructor TList.Destroy;
begin
FreeObjects;
inherited; // will do Finalize(fList) in FinalizeRecord
end;
function TList.GetItem(index: integer): pointer;
// default VCL raise an exception in case of out of range index
// -> LVCL just return nil without any exception
{$ifdef PUREPASCAL}
begin
if (self=nil) or (cardinal(index)>=cardinal(fCount)) then
result := nil else
result := fList[Index];
end;
{$else}
asm
cmp edx,[eax].TList.fCount
mov eax,[eax].TList.fList
jae @e
mov eax,[eax+edx*4]
ret
@e: xor eax,eax
end;
{$endif}
procedure TList.SetItem(index: integer; value: pointer);
begin
if (self=nil) or (cardinal(index)>=cardinal(fCount)) then
exit;
if fOwnObjects then
TObject(fList[Index]).Free;
fList[Index] := Value;
end;
procedure TList.Grow;
begin
if fSize>64 then
inc(fSize,fSize shr 2) else
inc(fSize,16);
Setlength(fList,fSize); // will set all new entries to nil
end;
function TList.Add(Item: pointer): integer;
begin
if fCount=fSize then
Grow;
fList[fCount] := Item;
result := fCount;
inc(fCount);
end;
procedure TList.Insert(index: integer; item: pointer);
begin
if (self=nil) or (cardinal(index)>cardinal(fCount)) then
exit;
if fCount=fSize then
Grow;
if index < FCount then
Move(FList[index], FList[index+1], (FCount-index)*SizeOf(item));
fList[index] := Item;
inc(fCount);
end;
procedure TList.Remove(item: pointer);
begin
Delete(IndexOf(item));
end;
procedure TList.Delete(index: integer);
begin
if (self=nil) or (cardinal(index)>=cardinal(fCount)) then
exit;
if fOwnObjects then
TObject(fList[index]).Free;
Dec(fCount);
if index < FCount then
Move(fList[index + 1],fList[index],(fCount-index)*SizeOf(Pointer));
end;
procedure TList.SetCount(number: integer);
var i: integer;
begin
if number<0 then
number := 0;
if fOwnObjects then
for i := number to fCount-1 do
TObject(fList[i]).Free;
fSize := number;
fCount := number;
Grow;
end;
function TList.IndexOf(item: pointer): integer;
begin
if self<>nil then
for result := 0 to fCount-1 do
if fList[result]=item then exit;
result := -1;
end;
procedure TList.Clear;
begin
if fOwnObjects then
FreeObjects;
fCount := 0;
fSize := 0;
SetLength(fList,0);
end;
procedure TList.Error(index: integer);
function ReturnAddr: Pointer;
asm
MOV EAX,[EBP+4]
end;
begin
// since we use "jae ListErrorIndex" to jump here, we still have a valid
// return address for ReturnAddr (i.e. direct jump without stack)
raise EClassesError.CreateFmt('Index %d out of range',[index]) at ReturnAddr;
end;
{ TObjectList }
constructor TObjectList.Create;
begin
inherited;
fOwnObjects := true; // do all the magic :)
end;
{ TStringList }
function TStringList.GetItem(index: integer): string;
{$ifdef PUREPASCAL}
begin
if cardinal(index)>=cardinal(FCount) then
TList.Error(index);
Result := fListStr^[index];
end;
{$else}
asm // eax=self, edx=index, ecx=result
cmp edx,[eax].TStringList.fCount
mov eax,[eax].TStringList.fListStr
jae TList.Error
mov edx,[eax+edx*4]
mov eax,ecx
jmp System.@LStrLAsg
end;
{$endif}
procedure TStringList.SetItem(index: integer; const value: string);
begin
if (self<>nil) and (cardinal(index)<cardinal(fCount)) then
fListStr[index] := value;
end;
function TStringList.GetObject(index: integer): TObject;
begin
if (self=nil) or (cardinal(index)>=cardinal(fCount)) or
(index>=length(fListObj)) then
result := nil else
result := fListObj[index];
end;
procedure TStringList.SetObject(index: integer; value: TObject);
begin
if (self<>nil) and (cardinal(index)<cardinal(fCount)) and (value<>nil) then begin
if high(fListObj)<>fSize then
SetLength(fListObj,fSize+1);
fListObj[index] := value;
end;
end;
function TStringList.Add(const s: string): integer;
begin
result := AddObject(s,nil);
end;
function TStringList.AddObject(const s: string; AObject: TObject): integer;
begin
if fCount=fSize then begin
if fSize>64 then
inc(fSize,fSize shr 2) else
inc(fSize,16);
Setlength(fListStr,fSize+1);
end;
fListStr[fCount] := s;
result := fCount;
inc(fCount);
if AObject<>nil then
Objects[result] := AObject;
end;
procedure TStringList.Delete(index: integer);
var L: integer;
begin
if (self=nil) or (cardinal(index)>=cardinal(fCount)) then
exit;
fListStr[index] := ''; // avoid GPF
Dec(FCount);
if index<FCount then begin
L := (FCount-index)*4;
Move(FListStr[index + 1], FListStr[index], L);
if FListObj<>nil then
Move(FListObj[index + 1], FListObj[index], L);
end;
pointer(fListStr[FCount]) := nil; // avoid GPF
end;
function TStringList.IndexOf(const s: string): integer;
begin
if fCaseSensitive then begin
for result := 0 to fCount-1 do
if fListStr[result]=s then
exit;
end else
for result := 0 to fCount-1 do
if SameText(fListStr[result],s) then
exit;
result := -1;
end;
function TStringList.IndexOfObject(item: pointer): integer;
begin
if fListObj<>nil then
for result := 0 to fCount-1 do
if fListObj[result]=item then
exit;
result := -1;
end;
function IdemPChar(p, up: PChar): boolean;
// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper)
var c: char;
begin
result := false;
if (p=nil) or (up=nil) then
exit;
while up^<>#0 do begin
c := p^;
if up^<>c then
if c in ['a'..'z'] then begin
dec(c,32);
if up^<>c then
exit;
end else exit;
inc(up);
inc(p);
end;
result := true;
end;
function TStringList.IndexOfName(const Name: string; const Separator: string='='): integer;
var L: integer;
Tmp: string;
begin
if self<>nil then begin
Tmp := UpperCase(Name)+Separator;
L := length(Tmp);
if L>1 then
for result := 0 to fCount-1 do
if IdemPChar(pointer(fListStr[result]),pointer(Tmp)) then
exit;
end;
result := -1;
end;
function TStringList.ValueOf(const Name: string; const Separator: string='='): string;
var i: integer;
begin
i := IndexOfName(Name,Separator);
if i>=0 then
result := copy(fListStr[i],length(Name)+length(Separator)+1,maxInt) else
result := '';
end;
function TStringList.NameOf(const Value: string; const Separator: string='='): string;
var i,j,L: integer;
P: PAnsiChar;
begin
L := length(Separator)-1;
for i := 0 to fCount-1 do begin
j := pos(Separator,fListStr[i]);
if j=0 then continue;
P := PAnsiChar(pointer(fListStr[i]))+j+L;
while P^=' ' do inc(P); // trim left value
if StrIComp(P,pointer(Value))=0 then begin
result := copy(fListStr[i],1,j-1);
exit;
end;
end;
result := '';
end;
procedure TStringList.Clear;
begin
if (self=nil) or (fCount<=0) then exit;
fCount := 0;
fSize := 0;
Finalize(fListStr);
Finalize(fListObj);
end;
procedure TStringList.LoadFromFile(const FileName: string);
var F: system.text;
s: string;
buf: array[0..4095] of byte;
begin
Clear;
{$I-}
Assign(F,FileName);
SetTextBuf(F,buf);
Reset(F);
if ioresult<>0 then exit;
while not eof(F) do begin
readln(F,s);
Add(s);
end;
ioresult;
Close(F);
ioresult;
{$I+}
end;
procedure TStringList.SaveToFile(const FileName: string);
var F: system.text;
i: integer;
buf: array[0..4095] of byte;
begin
{$I-}
Assign(F,FileName);
SetTextBuf(F,buf);
rewrite(F);
if ioresult<>0 then exit;
for i := 0 to FCount-1 do
writeln(F,FListStr[i]);
ioresult;
Close(F);
ioresult; // ignore any error
{$I+}
end;
procedure TStringList.QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
var I, J, P, Tmp: Integer;
begin
repeat
I := L;
J := R;
P := (L+R) shr 1;
repeat
while SCompare(Self,I,P)<0 do Inc(I);
while SCompare(Self,J,P)>0 do Dec(J);
if I <= J then begin
Tmp := integer(fListObj[I]);
fListObj[I] := fListObj[J];
fListObj[J] := pointer(Tmp);
Tmp := integer(FListStr[I]);
integer(FListStr[I]) := integer(FListStr[J]);
integer(FListStr[J]) := Tmp;
if P=I then
P := J else
if P=J then
P := I;
Inc(I);
Dec(J);
end;
until I>J;
if L<J then QuickSort(L,J,SCompare);
L := I;
until I>=R;
end;
procedure TStringList.CustomSort(Compare: TStringListSortCompare);
begin
if (self=nil) or (FCount<=1) then
exit;
QuickSort(0,FCount-1,Compare);
end;
function TStringList.TextLen: integer;
var i: integer;
begin
result := fCount*2; // #13#10 size
for i := 0 to fCount-1 do
if integer(fListStr[i])<>0 then
inc(result,pInteger(integer(fListStr[i])-4)^); // fast add length(List[i])
end;
function TStringList.GetText: string;
var i,V,L: integer;
P: PChar;
begin
// much faster than for i := 0 to Count-1 do result := result+List[i]+#13#10;
result := '';
if fCount=0 then exit;
SetLength(result,TextLen);
P := pointer(result);
for i := 0 to fCount-1 do begin
V := integer(fListStr[i]);
if V<>0 then begin
L := pInteger(V-4)^; // L := length(List[i])
move(pointer(V)^,P^,L);
inc(P,L);
end;
PWord(P)^ := 13+10 shl 8;
inc(P,2);
end;
end;
procedure TStringList.SetText(const Value: string);
function GetNextLine(d: pChar; out next: pChar): string;
begin
next := d;
while not (d^ in [#0,#10,#13]) do inc(d);
SetString(result,next,d-next);
if d^=#13 then inc(d);
if d^=#10 then inc(d);
if d^=#0 then
next := nil else
next := d;
end;
var P: PAnsiChar;
begin
Clear;
P := pointer(Value);
while P<>nil do
Add(GetNextLine(P,P));
end;
{ TStream }
procedure TStream.Clear;
begin
Position := 0;
Size := 0;
end;
function TStream.CopyFrom(Source: TStream; Count: integer): integer;
const
MaxBufSize = $F000*4; // 240KB buffer (should be fast enough ;)
var
BufSize, N: integer;
Buffer: PChar;
begin
if Count=0 then begin // Count=0 for whole stream copy
Source.Position := 0;
Count := Source.Size;
end;
result := Count;
if Count>MaxBufSize then
BufSize := MaxBufSize else
BufSize := Count;
GetMem(Buffer, BufSize);
try
while Count<>0 do begin
if Count>BufSize then
N := BufSize else
N := Count;
if Source.Read(Buffer^, N)<>N then
break; // stop on any read error
if Write(Buffer^, N)<>N then
break; // stop on any write error
Dec(Count, N);
end;
finally
FreeMem(Buffer, BufSize);
end;
end;
function TStream.GetPosition: integer;
begin
Result := Seek(0, soFromCurrent);
end;
function TStream.GetSize: integer;
var Pos: integer;
begin
Pos := Seek(0, soFromCurrent);
Result := Seek(0, soFromEnd);
Seek(Pos, soFromBeginning);
end;
procedure TStream.SetPosition(value: integer);
begin
Seek(Value, soFromBeginning);
end;
procedure TStream.SetSize(Value: integer);
begin
// default = do nothing (read-only streams, etc)
// descendents should implement this method
end;
procedure TStream.LoadFromFile(const FileName: string);
var F: TFileStream;
begin
F := TFileStream.Create(FileName,fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(F);
finally
F.Free;
end;
end;
procedure TStream.LoadFromStream(aStream: TStream);
begin
CopyFrom(aStream,0); // Count=0 for whole stream copy
end;
procedure TStream.ReadBuffer(var Buffer; Count: integer);
begin
Read(Buffer,Count);
end;
procedure TStream.SaveToFile(const FileName: string);
var F: TFileStream;
begin
F := TFileStream.Create(FileName,fmCreate);
try
SaveToStream(F);
finally
F.Free;
end;
end;
procedure TStream.SaveToStream(aStream: TStream);
begin
aStream.CopyFrom(self,0); // Count=0 for whole stream copy
end;
{ TFileStream }
constructor TFileStream.Create(const FileName: string; Mode: Word);
begin
fFileName := FileName;
if Mode=fmCreate then
fHandle := FileCreate(FileName) else
fHandle := FileOpen(FileName,Mode);
if integer(fHandle)<0 then
raise EStreamError.Create(FileName);
end;
{$ifdef Linux}
function TFileStream.GetSize: cardinal;
var st: TStatBuf;
begin
if stat(PChar(fFileName),st)=0 then
result := st.st_size else
result := 0;
end;
{$endif}
destructor TFileStream.Destroy;
begin
FileClose(fHandle);
inherited;
end;
{$ifdef Win32}
{ TReader }
constructor TReader.Create(const ResourceName: string);
var res: THandle;
begin
res := FindResource(hInstance,pointer(ResourceName),RT_RCDATA);
if res=0 then exit;
fHandle := LoadResource(hInstance,res);
if fHandle=0 then exit;
fPointer := LockResource(fHandle);
if fPointer<>nil then
fSize := SizeOfResource(hInstance,res);
fStart := integer(fPointer);
fNotifyLoaded := TList.Create;
end;
destructor TReader.Destroy;
var i: integer;
begin
if fHandle<>0 then begin
//UnlockResource(fHandle); not necessary for Win32-based applications
//FreeResource(fHandle); also obsolete
for i := 0 to fNotifyLoaded.Count-1 do
TComponent(fNotifyLoaded.fList[i]).Loaded;
fNotifyLoaded.Free;
end;
inherited;
end;
procedure TReader.SetPosition(Value: integer);
begin
fPosition := Value;
fPointer := Pointer(fStart+Value);
end;
procedure TReader.Loading(AComponent: TComponent);
begin
fNotifyLoaded.Add(AComponent);
end;
function TReader.Read(var Data; DataSize: integer): integer;
begin
if fPosition+DataSize<fSize then
result := DataSize else
result := fSize-fPosition;
if result<=0 then exit;
move(fPointer^,Data,result);
Inc(fPosition,result);
inc(fPointer,result);
end;
function TReader.EndOfList: boolean;
begin
result := (fPosition<fSize) and (fPointer^=0);
if result then begin
inc(fPosition);
inc(fPointer);
end;
end;
function TReader.ReadValueType: TValueType;
begin
result := PValueType(fPointer)^;
inc(fPosition);
inc(fPointer);
end;
function TReader.BooleanProperty: boolean;
var ValueType: TValueType;
begin
ValueType := ReadValueType;
case ValueType of
vaFalse : result := False;
vaTrue : result := True;
else raise EClassesError.Create('boolean?');
end;
end;
function TReader.IntegerProperty: integer;
var ValueType: TValueType;
begin
ValueType := ReadValueType;
case ValueType of
vaInt8 : result := ShortInt(ReadByte);
vaInt16 : result := ReadWord;
vaInt32 : result := ReadInteger;
else raise EClassesError.Create('ordinal?');
end;
end;
function TReader.StringProperty: string;
var ValueType: TValueType;
begin
ValueType := ReadValueType;
case ValueType of
vaString,
vaIdent: result := ReadString;
vaUTF8String: result := ReadUTF8String;
vaWString: result := ReadWString;
else raise EClassesError.CreateFmt('string? %d', [Integer(ValueType)]);
end;
end;
function TReader.ColorProperty: integer;
var ValueType: TValueType;
begin
ValueType := ReadValueType;
case ValueType of
vaInt16 : result := ReadWord;
vaInt32 : result := ReadInteger;
vaIdent : result := IdentToColor(pointer(ReadString));
else raise EClassesError.Create('color?');
end;
end;
function TReader.BinaryProperty(var Size: integer): pointer;
var ValueType: TValueType;
begin
ValueType := ReadValueType;
case ValueType of
vaBinary : begin
Size := ReadInteger;
GetMem(result,Size);
Read(result^,Size);
end;
else raise EClassesError.Create('binary?');
end;
end;
function GetEnumNameValue(aTypeInfo: pointer; const aValue: shortstring): integer;
asm
movzx ecx,byte ptr [eax+1]
push ebx
push esi
push edi
mov eax,[eax+ecx+9+2] // BaseType
movzx ebx,byte ptr [edx]
mov eax,[eax]
xor edi,edi
movzx ecx,byte ptr [eax+1]
or ebx,ebx
mov esi,[eax+ecx+2+5] // esi=MaxValue
lea eax,[eax+ecx+2+9+4] // eax=NameList
jz @z // aValue='' -> return -1
@1: movzx ecx,byte ptr [eax]
cmp ecx,ebx
jz @0 // same length
@2: cmp edi,esi
lea edi,edi+1
lea eax,eax+ecx+1 // next short string
jne @1
@z: or eax,-1
@e: pop edi
pop esi
pop ebx
ret
@0: push eax
push edx
@n: inc eax
inc edx
mov ch,[eax]
xor ch,[edx]
and ch,$DF // case insensitive search
jne @d
dec cl
jnz @n
pop edx
pop edx
mov eax,edi
jmp @e
@d: pop edx
pop eax
mov ecx,ebx
jmp @2
end;
procedure TReader.IdentProperty(var aValue; aTypeInfo: pointer);
var ValueType: TValueType;
V: cardinal;
begin
ValueType := ReadValueType;
if ValueType=vaIdent then begin
V := GetEnumNameValue(aTypeInfo, ReadShortString);
if V<=255 then begin
byte(aValue) := V;
exit;
end;
end;
raise EClassesError.Create('ident?');
end;
procedure TReader.SetProperty(var ASet; aTypeInfo: pointer);
var s: ShortString;
i: integer;
begin
if ReadValueType<>vaSet then
raise EClassesError.Create('set?');
integer(ASet) := 0;
repeat
s := ReadShortString;
if s[0]=#0 then break;
i := GetEnumNameValue(aTypeInfo,s);
if i>=0 then
integer(ASet) := integer(ASet) or (1 shl i);
until false;
end;
function TReader.ReadByte:byte;
begin
result := fPointer^;
inc(fPosition);
inc(fPointer);
end;
function TReader.ReadWord:word;
begin
result := pWord(fPointer)^;
inc(fPosition,2);
inc(fPointer,2);
end;
function TReader.ReadInteger: integer;
begin
result := pInteger(fPointer)^;
inc(fPosition,4);
inc(fPointer,4);
end;
function TReader.ReadString: AnsiString;
var L: integer;
begin
L := fPointer^;
SetString(result,PAnsiChar(fPointer)+1,fPointer^);
inc(L);
inc(fPosition,L);
inc(fPointer,L);
end;
function TReader.ReadWString: string;
var L: integer;
begin
L := PInteger(fPointer)^;
inc(fPointer,4);
WideCharLenToStrVar(PWideChar(fPointer),L,result);
L := L*2;
inc(fPosition,L+4);
inc(fPointer,L);
end;
function TReader.ReadShortString: shortstring;
var L: integer;
begin
L := fPointer^+1;
move(fPointer^,result,L);
inc(fPosition,L);
inc(fPointer,L);
end;
function TReader.ReadUTF8String: string;
var L: integer;
UTF8: UTF8String;
begin
L := PInteger(fPointer)^;
inc(fPointer,4);
SetString(UTF8,PAnsiChar(fPointer),L);
{$ifdef UNICODE}
result := UTF8; // let the RTL do the conversion
{$else}
result := UTF8ToAnsi(UTF8);
{$endif}
inc(fPosition,L+4);
inc(fPointer,L);
end;
procedure TReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: integer);
begin
byte(Flags) := 0;
if (fSize>1) and (fPointer^ and $F0 = $F0) then begin
byte(Flags) := ReadByte and $0F;
if ffChildPos in Flags then
AChildPos := ReadInteger;
end;
end;
procedure TReader.AnyProperty;
var
ValueType: TValueType;
begin
ValueType := ReadValueType;
case ValueType of
vaInt8 : ReadByte;
vaInt16 : ReadWord;
vaInt32 : ReadInteger;
vaString,
vaIdent: ReadString;
vaUTF8String: ReadUTF8String;
vaWString: ReadWString;
vaFalse, vaTrue: ;
else raise EClassesError.CreateFmt('set of? %d', [Integer(ValueType)]);
end;
end;
procedure TReader.ReadList;
begin
repeat
AnyProperty;
until EndOfList;
end;
procedure TReader.ReadSet;
begin
repeat
ReadShortString;
until EndOfList;
end;
procedure TReader.ReadStrings(Strings: TStrings);
var ValueType: TValueType;
s: string;
begin
ValueType := ReadValueType;
if ValueType=vaList then
repeat
s := StringProperty;
Strings.Add(s);
until EndOfList
else raise EClassesError.Create('list?');
end;
{ TPersistent }
function TPersistent.SubProperty(const Name: string): TPersistent;
begin
result := nil;
end;
procedure TPersistent.ReadProperty(const Name: string; Reader: TReader);
// default behavior is to read the property value from Reader and ignore it
var {$ifdef debug}
Value, Oem: string;
{$endif}
ValueType: TValueType;
i: integer;
SubProp: TPersistent;
begin
if self=nil then exit;
i := pos('.',Name);
if i > 0 then
SubProp:= SubProperty(Copy(Name,1,i-1))
else SubProp := nil;
if SubProp<>nil then
SubProp.ReadProperty(copy(Name,i+1,200),Reader)
else
with Reader do begin
{$ifdef debug}
ValueType := ReadValueType;
case ValueType of
vaInt8 : Value := IntToStr(ReadByte);
vaInt16 : Value := IntToStr(ReadWord);
vaString : Value := ReadString;
vaIdent : Value := '"'+ReadString+'"';
vaWString: Value:= ReadWString;
vaUTF8String: Value:= ReadUTF8String;
vaFalse : Value := '"FALSE"';
vaTrue : Value := '"TRUE"';
vaBinary : begin
i := ReadInteger; Value := '('+IntToStr(i)+' bytes)';
inc(fPointer,i); inc(fPosition,i);
end;
vaList: ReadList;
vaSet: ReadSet;
else OutputDebugString(pointer('Bad ValueType '+IntToStr(ord(ValueType))));
end;
SetLength(Oem, Length(Value));
if Length(Value) > 0 then
CharToOem(PAnsiChar(Value), PAnsiChar(Oem));
writeln(Self.ClassName+' '+TComponent(Self).Name+'.'+Name+'='+Oem);
{$else}
ValueType:= ReadValueType;
case ValueType of // no handler -> ignore this property
vaInt8: ReadByte;
vaInt16: ReadWord;
vaIdent, vaString: ReadShortString;
vaWString: ReadWString;
vaUTF8String: ReadUTF8String;
vaFalse, vaTrue: ;
vaBinary: begin
i := ReadInteger;
inc(fPointer,i);
inc(fPosition,i);
end;
vaList: ReadList;
vaSet: ReadSet;
else
raise EClassesError.CreateFmt('%s.%s: unknown value type = %d', [TComponent(Self).Name, Name, integer(ValueType)]);
end;
{$endif}
end; // with Reader do
end;
var
RegisteredClasses: TList = nil;
function FindClass(const AClass: ShortString): TPersistentClass;
var i: integer;
begin
if RegisteredClasses=nil then
RegisteredClasses := TList.Create else
for i := 0 to RegisteredClasses.Count-1 do begin
result := RegisteredClasses.fList[i];
if PShortString(PInteger(integer(result)+vmtClassName)^)^=AClass then
exit;
end;
result := nil;
end;
procedure RegisterClasses(const AClasses: array of TPersistentClass);
var i: integer;
begin
for i := Low(AClasses) to High(AClasses) do
if FindClass(PShortString(PInteger(integer(AClasses[i])+vmtClassName)^)^)=nil then
RegisteredClasses.Add(AClasses[i]);
end;
function CreateComponent(const AClass: ShortString; AOwner: TComponent): TComponent;
var RC: TPersistentClass;
begin
RC := FindClass(AClass);
if (RC=nil) or not RC.InheritsFrom(TComponent) then
raise EClassesError.CreateFmt('%s?',[AClass]);
result := TComponent(RC.NewInstance);
result.Create(AOwner);
end;
{ TComponent }
constructor TComponent.Create(AOwner: TComponent);
begin
if AOwner=nil then exit;
if AOwner.fComponents=nil then
AOwner.fComponents := TObjectList.Create;
AOwner.fComponents.Add(self);
fOwner := AOwner;
end;
procedure TComponent.ReadProperties(Reader: TReader);
var
Flags: TFilerFlags;
position: integer;
Child: TComponent;
field: ^TComponent;
Name: shortstring;
begin
while not Reader.EndOfList do
ReadProperty(Reader.ReadString, Reader);
while not Reader.EndOfList do begin
Reader.ReadPrefix(Flags,Position);
Name := Reader.ReadShortString; // read ClassName
Child := CreateComponent(Name, Self);
Child.SetParentComponent(Self);
Reader.Loading(Child);
Name := Reader.ReadShortString;
Child.fCompName := Name;
Child.ReadProperties(Reader);
field := FieldAddress(Name);
if field<>nil then
field^ := Child;
end;
end;
procedure TComponent.Loaded;
begin
end;
procedure TComponent.SetParentComponent(Value:TComponent);
begin
end;
function TComponent.GetParentComponent:TComponent;
begin
result := fOwner;
end;
destructor TComponent.Destroy;
begin
fComponents.Free; // free all contained components
inherited;
end;
function TComponent.ComponentCount: integer;
begin
if (self=nil) or (fComponents=nil) then
result := 0 else
result := fComponents.Count;
end;
{$endif}
{ TMemoryStream }
procedure TMemoryStream.SetCapacity(Value: integer);
begin
if self=nil then
exit;
fCapacity := Value;
ReallocMem(fMemory,fCapacity);
if fPosition>=fCapacity then // adjust Position if truncated
fPosition := fCapacity-1;
if fSize>=fCapacity then // adjust Size if truncated
fSize := fCapacity-1;
end;
procedure TMemoryStream.SetSize(Value: integer);
begin
if Value>fCapacity then
SetCapacity(Value+16384); // reserve some space for inplace growing
fSize := Value;
end;
destructor TMemoryStream.Destroy;
begin
if Memory<>nil then
Freemem(Memory);
inherited;
end;
function TMemoryStream.Write(const Buffer; Count: integer): integer;
var Pos: integer;
begin
if (FPosition>=0) and (Count>0) then begin
Pos := FPosition+Count;
if Pos>FSize then begin
if Pos>FCapacity then
if Pos>65536 then // growing by 16KB chunck up to 64KB, then by 1/4 of size
SetCapacity(Pos+Pos shr 2) else
SetCapacity(Pos+16384);
FSize := Pos;
end;
Move(Buffer, (PAnsiChar(Memory)+FPosition)^, Count);
FPosition := Pos;
result := Count;
end else
result := 0;
end;
procedure TMemoryStream.LoadFromStream(aStream: TStream);
var L: integer;
begin
if aStream=nil then exit;
L := aStream.Size;
SetCapacity(L);
aStream.Position := 0;
if (L<>0) and (aStream.Read(Memory^,L)<>L) then
raise EStreamError.Create('Load');
fPosition := 0;
fSize := L;
end;
{ TResourceStream }
constructor TResourceStream.Create(Instance: THandle;
const ResName: string; ResType: PChar);
// just a copy from resource to local TMemoryStream -> shorter code
var HResInfo: THandle;
HGlobal: THandle;
begin
HResInfo := FindResource(Instance,pointer(ResName),ResType);
if HResInfo=0 then
exit;
HGlobal := LoadResource(HInstance, HResInfo);
if HGlobal=0 then
exit;
SetPointer(LockResource(HGlobal),SizeOfResource(Instance, HResInfo));
FPosition := 0;
end;
{$ifdef Win32}
{ TThread }
function ThreadProc(Thread: TThread): Integer;
var FreeThread: Boolean;
begin
if not Thread.FTerminated then
try
result := 0; // default ExitCode
try
Thread.Execute;
except
on Exception do
result := -1;
end;
finally
FreeThread := Thread.FFreeOnTerminate;
Thread.FFinished := True;
if Assigned(Thread.OnTerminate) then
Thread.OnTerminate(Thread);
if FreeThread then
Thread.Free;
EndThread(result);
end;
end;
procedure TThread.AfterConstruction;
begin
if not FCreateSuspended then
Resume;
end;
constructor TThread.Create(CreateSuspended: Boolean);
begin
IsMultiThread := true; // for FastMM4 locking, e.g.
inherited Create;
FSuspended := CreateSuspended;
FCreateSuspended := CreateSuspended;
FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), CREATE_SUSPENDED, FThreadID);
if FHandle = 0 then
raise Exception.Create(SysErrorMessage(GetLastError));
SetThreadPriority(FHandle, THREAD_PRIORITY_NORMAL);
end;
destructor TThread.Destroy;
begin
if (FThreadID<>0) and not FFinished then begin
Terminate;
if FCreateSuspended then
Resume;
WaitFor;
end;
if FHandle<>0 then
CloseHandle(FHandle);
inherited Destroy;
end;
procedure TThread.Resume;
begin
if ResumeThread(FHandle)=1 then // returns the thread's previous suspend count
FSuspended := False;
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value<>FSuspended then
if Value then
Suspend else
Resume;
end;
procedure TThread.Suspend;
var OldSuspend: Boolean;
begin
OldSuspend := FSuspended;
FSuspended := True;
if Integer(SuspendThread(FHandle))<0 then
FSuspended := OldSuspend;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: LongWord;
begin
if GetCurrentThreadID<>MainThreadID then
WaitForSingleObject(FHandle, INFINITE);
GetExitCodeThread(FHandle, result);
end;
{ TCustomMemoryStream }
function TCustomMemoryStream.GetPosition: integer;
begin
result := fPosition;
end;
function TCustomMemoryStream.GetSize: integer;
begin
result := fSize;
end;
function TCustomMemoryStream.Read(var Buffer; count: integer): integer;
begin
if (self<>nil) and (Memory<>nil) then
if (FPosition>=0) and (Count>0) then begin
result := FSize - FPosition;
if result>0 then begin
if result>Count then result := Count;
Move((PAnsiChar(Memory)+FPosition)^, Buffer, result);
Inc(FPosition, result);
Exit;
end;
end;
result := 0;
end;
procedure TCustomMemoryStream.SaveToStream(aStream: TStream);
begin
if (self<>nil) and (FSize<>0) and (aStream<>nil) and (Memory<>nil) then
aStream.Write(Memory^, FSize);
end;
function TCustomMemoryStream.Seek(Offset: integer; Origin: Word): integer;
begin
result := Offset; // default is soFromBeginning
case Origin of
soFromEnd: inc(result,fSize);
soFromCurrent: inc(result,fPosition);
end;
if result<=fSize then
fPosition := result else begin
result := fSize;
fPosition := fSize;
end;
end;
procedure TCustomMemoryStream.SetPointer(Buffer: pointer; Count: integer);
begin
fMemory := Buffer;
fSize := Count;
end;
procedure TCustomMemoryStream.SetPosition(value: integer);
begin
if value>fSize then
value := fSize;
fPosition := value;
end;
procedure TCustomMemoryStream.SetSize(Value: integer);
begin
fSize := Value;
end;
{ THandleStream }
constructor THandleStream.Create(aHandle: THandle);
begin
fHandle := aHandle;
end;
function THandleStream.Read(var Buffer; count: integer): integer;
begin
if (Integer(fHandle)<0) or (Count<=0) then
result := 0 else
result := FileRead(fHandle,Buffer,Count);
end;
function THandleStream.Seek(Offset: integer; Origin: Word): integer;
begin
if integer(fHandle)<0 then
result := 0 else
result := FileSeek(fHandle,offset,Origin);
end;
procedure THandleStream.SetSize(Value: integer);
begin
Seek(Value, soFromBeginning);
{$ifdef Win32}
if not SetEndOfFile(fHandle) then
{$else}
if ftruncate(fHandle, Value)=-1 then
{$endif}
raise EStreamError.Create('SetSize');
end;
function THandleStream.Write(const Buffer; Count: integer): integer;
begin
if (integer(fHandle)<0) or (Count<=0) then
result := 0 else
result := FileWrite(fHandle,Buffer,Count);
end;
initialization
finalization
RegisteredClasses.Free;
{$endif}
end.