mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 11:58:24 +02:00
1974 lines
67 KiB
ObjectPascal
1974 lines
67 KiB
ObjectPascal
{
|
|
***************************************************************************
|
|
* *
|
|
* This source is free software; you can redistribute it and/or modify *
|
|
* it under the terms of the GNU General Public License as published by *
|
|
* the Free Software Foundation; either version 2 of the License, or *
|
|
* (at your option) any later version. *
|
|
* *
|
|
* This code 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. See the GNU *
|
|
* General Public License for more details. *
|
|
* *
|
|
* A copy of the GNU General Public License is available on the World *
|
|
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
|
* obtain it by writing to the Free Software Foundation, *
|
|
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
|
* *
|
|
***************************************************************************
|
|
|
|
Author: Mattias Gaertner
|
|
|
|
Abstract:
|
|
This unit defines a list of forms descendents. The forms are normal TForm
|
|
descendents with one exception: Every form has its own class. These classes
|
|
are changeable at runtime, so that IDEs can add, remove or rename methods
|
|
and such stuff. Also these forms can be loaded from streams and missing
|
|
components and methods are added just-in-time to the class definition.
|
|
Hence the name for the class: TJITForms.
|
|
}
|
|
unit JITForms;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
{$I ide.inc}
|
|
|
|
{ $DEFINE VerboseJITForms}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF IDE_MEM_CHECK}
|
|
MemCheck,
|
|
{$ENDIF}
|
|
Classes, SysUtils, AvgLvlTree, TypInfo, LCLProc, LResources, Forms, Controls,
|
|
LCLMemManager, LCLIntf, Dialogs,
|
|
PropEdits, JITForm, IDEProcs,
|
|
BasePkgManager;
|
|
|
|
type
|
|
//----------------------------------------------------------------------------
|
|
TJITFormError = (
|
|
jfeNone,
|
|
jfeUnknown,
|
|
jfeUnknownProperty,
|
|
jfeUnknownComponentClass,
|
|
jfeReaderError
|
|
);
|
|
TJITFormErrors = set of TJITFormError;
|
|
|
|
TJITReaderErrorEvent = procedure(Sender: TObject; Reader: TReader;
|
|
ErrorType: TJITFormError;
|
|
var Action: TModalResult) of object;
|
|
TJITExceptionEvent = procedure(Sender: TObject; E: Exception;
|
|
var Action: TModalResult) of object;
|
|
TJITPropertyNotFoundEvent = procedure(Sender: TObject; Reader: TReader;
|
|
Instance: TPersistent; var PropName: string; IsPath: boolean;
|
|
var Handled, Skip: Boolean) of object;
|
|
TJITFindAncestors = procedure(Sender: TObject; AClass: TClass;
|
|
var Ancestors: TFPList;// list of TComponent
|
|
var BinStreams: TFPList;// list of TExtMemoryStream;
|
|
var Abort: boolean) of object;
|
|
TJITFindClass = procedure(Sender: TObject;
|
|
const ComponentClassName: string;
|
|
var ComponentClass: TComponentClass) of object;
|
|
|
|
|
|
{ TJITComponentList }
|
|
|
|
TJITCompListFlag = (
|
|
jclAutoRenameComponents
|
|
);
|
|
TJITCompListFlags = set of TJITCompListFlag;
|
|
|
|
TJITComponentList = class(TPersistentWithTemplates)
|
|
private
|
|
FContextObject: TObject;
|
|
FCurUnknownClass: string;
|
|
FCurUnknownProperty: string;
|
|
FErrors: TLRPositionLinks;
|
|
FOnException: TJITExceptionEvent;
|
|
FOnFindAncestors: TJITFindAncestors;
|
|
FOnFindClass: TJITFindClass;
|
|
FOnPropertyNotFound: TJITPropertyNotFoundEvent;
|
|
protected
|
|
FCurReadErrorMsg: string;
|
|
FCurReadJITComponent: TComponent;
|
|
FCurReadClass: TClass;
|
|
FCurReadChild: TComponent;
|
|
FCurReadChildClass: TComponentClass;
|
|
FCurReadStreamClass: TClass;
|
|
FOnReaderError: TJITReaderErrorEvent;
|
|
FJITComponents: TList;
|
|
FFlags: TJITCompListFlags;
|
|
// jit procedures
|
|
function CreateNewJITClass(AncestorClass: TClass;
|
|
const NewClassName, NewUnitName: ShortString): TClass;
|
|
procedure FreeJITClass(var AClass: TClass);
|
|
procedure DoAddNewMethod(JITClass: TClass; const AName: ShortString;
|
|
ACode: Pointer); // Note: AddNewMethod does not check if method already exists
|
|
procedure DoRemoveMethod(JITClass: TClass; AName: ShortString;
|
|
var OldCode: Pointer); // Note: RemoveMethod does not free code memory
|
|
procedure DoRenameMethod(JITClass: TClass; OldName, NewName: ShortString);
|
|
procedure DoRenameClass(JITClass: TClass; const NewName: ShortString);
|
|
procedure DoRenameUnitNameOfClass(JITClass: TClass;
|
|
const NewUnitName: ShortString);
|
|
// TReader events
|
|
procedure ReaderFindMethod(Reader: TReader; const FindMethodName: Ansistring;
|
|
var Address: Pointer; var Error: Boolean);
|
|
procedure ReaderSetMethodProperty(Reader: TReader; Instance: TPersistent;
|
|
PropInfo: PPropInfo; const TheMethodName: string; var Handled: boolean);
|
|
procedure ReaderPropertyNotFound(Reader: TReader; Instance: TPersistent;
|
|
var PropName: string; IsPath: Boolean; var Handled, Skip: Boolean);
|
|
procedure ReaderSetName(Reader: TReader; Component: TComponent;
|
|
var NewName: Ansistring);
|
|
procedure ReaderReferenceName(Reader: TReader; var RefName: Ansistring);
|
|
procedure ReaderAncestorNotFound(Reader: TReader;
|
|
const ComponentName: Ansistring; ComponentClass: TPersistentClass;
|
|
var Component: TComponent);
|
|
procedure ReaderError(Reader: TReader; const ErrorMsg: Ansistring;
|
|
var Handled: Boolean);
|
|
procedure ReaderFindComponentClass(Reader: TReader;
|
|
const FindClassName: Ansistring; var ComponentClass: TComponentClass);
|
|
procedure ReaderCreateComponent(Reader: TReader;
|
|
ComponentClass: TComponentClass; var Component: TComponent);
|
|
procedure ReaderReadComponent(Component: TComponent);
|
|
|
|
// some useful functions
|
|
function GetItem(Index:integer):TComponent;
|
|
function OnFindGlobalComponent(const AName:AnsiString):TComponent;
|
|
procedure InitReading;
|
|
procedure CreateReader(BinStream: TStream; var Reader: TReader;
|
|
DestroyDriver: Boolean); virtual;
|
|
function DoCreateJITComponent(const NewComponentName, NewClassName,
|
|
NewUnitName: shortstring; AncestorClass: TClass;
|
|
Visible: boolean):integer;
|
|
procedure ReadInlineComponent(var Component: TComponent;
|
|
ComponentClass: TComponentClass; Owner: TComponent);
|
|
procedure DoFinishReading; virtual;
|
|
procedure HandleException(E: Exception; const Context: string;
|
|
out Action: TModalResult);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
property Items[Index: integer]: TComponent read GetItem; default;
|
|
function Count: integer;
|
|
function AddNewJITComponent(const NewUnitName: shortstring;
|
|
AncestorClass: TClass): integer;
|
|
function AddJITComponentFromStream(BinStream: TStream;
|
|
AncestorClass: TClass;
|
|
const NewUnitName: ShortString;
|
|
Interactive, Visible: Boolean;
|
|
ContextObj: TObject): integer;
|
|
procedure DestroyJITComponent(JITComponent: TComponent);
|
|
procedure DestroyJITComponent(Index: integer);
|
|
function IndexOf(JITComponent: TComponent): integer;
|
|
function Contains(JITComponent: TComponent): boolean;
|
|
function FindComponentByClassName(const AClassName: shortstring): integer;
|
|
function FindComponentByClass(AClass: TComponentClass): integer;
|
|
function FindComponentByName(const AName: shortstring): integer;
|
|
procedure GetUnusedNames(var ComponentName, ComponentClassName: shortstring);
|
|
function CreateNewMethod(JITComponent: TComponent;
|
|
const AName: ShortString): TMethod;
|
|
procedure RemoveMethod(JITComponent: TComponent; const AName: ShortString);
|
|
procedure RenameMethod(JITComponent: TComponent;
|
|
const OldName, NewName: ShortString);
|
|
procedure RenameComponentClass(JITComponent: TComponent;
|
|
const NewName: ShortString);
|
|
procedure RenameComponentUnitname(JITComponent: TComponent;
|
|
const NewUnitName: ShortString);
|
|
// child components
|
|
function AddJITChildComponentFromStream(JITOwnerComponent: TComponent;
|
|
BinStream: TStream; ComponentClass: TComponentClass;
|
|
ParentControl: TWinControl): TComponent;
|
|
procedure ReadInlineJITChildComponent(Component: TComponent);
|
|
public
|
|
property OnReaderError: TJITReaderErrorEvent
|
|
read FOnReaderError write FOnReaderError;
|
|
property OnPropertyNotFound: TJITPropertyNotFoundEvent
|
|
read FOnPropertyNotFound write FOnPropertyNotFound;
|
|
property OnException: TJITExceptionEvent read FOnException write FOnException;
|
|
property OnFindAncestors: TJITFindAncestors read FOnFindAncestors
|
|
write FOnFindAncestors;
|
|
property OnFindClass: TJITFindClass read FOnFindClass write FOnFindClass;
|
|
property CurReadJITComponent: TComponent read FCurReadJITComponent;
|
|
property CurReadClass: TClass read FCurReadClass;
|
|
property CurReadStreamClass: TClass read FCurReadStreamClass;
|
|
property CurReadChild: TComponent read FCurReadChild;
|
|
property CurReadChildClass: TComponentClass read FCurReadChildClass;
|
|
property CurReadErrorMsg: string read FCurReadErrorMsg;
|
|
property CurUnknownProperty: string read FCurUnknownProperty;
|
|
property CurUnknownClass: string read FCurUnknownClass;
|
|
property ContextObject: TObject read FContextObject;
|
|
property Errors: TLRPositionLinks read FErrors;
|
|
end;
|
|
|
|
|
|
{ TJITForms }
|
|
|
|
TJITForms = class(TJITComponentList)
|
|
private
|
|
function GetItem(Index: integer): TForm;
|
|
public
|
|
function IsJITForm(AComponent: TComponent): boolean;
|
|
property Items[Index:integer]: TForm read GetItem; default;
|
|
end;
|
|
|
|
|
|
{ TJITNonFormComponents }
|
|
|
|
TJITNonFormComponents = class(TJITComponentList)
|
|
public
|
|
function IsJITNonForm(AComponent: TComponent): boolean;
|
|
end;
|
|
|
|
|
|
TJITMethods = class;
|
|
|
|
{ TJITMethod }
|
|
|
|
TJITMethod = class
|
|
private
|
|
FMethod: TMethod;
|
|
FOwner: TJITMethods;
|
|
FTheClass: TClass;
|
|
FTheMethodName: shortstring;
|
|
public
|
|
constructor Create(AnOwner: TJITMethods; aClass: TClass;
|
|
const aMethodName: shortstring);
|
|
destructor Destroy; override;
|
|
property Method: TMethod read FMethod;
|
|
property TheClass: TClass read FTheClass;
|
|
property TheMethodName: shortstring read FTheMethodName;
|
|
property Owner: TJITMethods read FOwner;
|
|
end;
|
|
|
|
|
|
{ TJITMethods }
|
|
|
|
TJITMethods = class
|
|
private
|
|
fClearing: boolean;
|
|
fMethods: TAvgLvlTree;// sorted with CompareJITMethod
|
|
procedure InternalAdd(const AMethod: TJITMethod);
|
|
procedure InternalRemove(const AMethod: TJITMethod);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
function Add(aClass: TClass; const aMethodName: shortstring): TJITMethod;
|
|
function Find(aClass: TClass; const aMethodName: shortstring): TJITMethod;
|
|
function Delete(aMethod: TJITMethod): boolean;
|
|
function Delete(aClass: TClass; const aMethodName: shortstring): boolean;
|
|
procedure DeleteAllOfClass(aClass: TClass);
|
|
function Rename(aClass: TClass;
|
|
const OldMethodName, NewMethodName: shortstring): boolean;
|
|
end;
|
|
|
|
function IsJITMethod(const aMethod: TMethod): boolean;
|
|
function CompareJITMethod(Data1, Data2: Pointer): integer;
|
|
|
|
var
|
|
JITMethods: TJITMethods = nil;
|
|
|
|
|
|
function ClassAsString(AClass: TClass): string;
|
|
function ClassMethodTableAsString(AClass: TClass): string;
|
|
function ClassTypeInfoAsString(AClass: TClass): string;
|
|
function ClassFieldTableAsString(AClass: TClass): string;
|
|
|
|
function CalculateTypeDataSize(PropInfoCount: integer): integer;
|
|
function CalculateTypeInfoSize(const AClassName: shortstring;
|
|
PropInfoCount: integer): integer;
|
|
function GetTypeDataPropCountAddr(TypeData: PTypeData): PWord;
|
|
|
|
const
|
|
DefaultJITUnitName = 'VirtualUnitForJITClasses';
|
|
|
|
|
|
implementation
|
|
|
|
{$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
|
|
|
|
//------------------------------------------------------------------------------
|
|
// adding, removing and renaming of classes and methods at runtime
|
|
|
|
const
|
|
vmtInstanceSizeNeg = vmtInstanceSize+sizeof(ptrint);
|
|
|
|
type
|
|
// these definitions are copied from objpas.inc
|
|
|
|
TMethodNameRec = packed record
|
|
Name : PShortString;
|
|
Addr : Pointer;
|
|
end;
|
|
|
|
TMethodNameTable = packed record
|
|
Count : DWord;
|
|
// for runtime range checking it is important to give a range
|
|
Entries : packed array[0..1000000] of TMethodNameRec;
|
|
end;
|
|
PMethodNameTable = ^TMethodNameTable;
|
|
|
|
PFieldClassTable = ^TFieldClassTable;
|
|
TFieldClassTable =
|
|
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
packed
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
record
|
|
Count: Word;
|
|
Entries: array[Word] of TPersistentClass;
|
|
end;
|
|
|
|
PFieldInfo = ^TFieldInfo;
|
|
TFieldInfo =
|
|
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
packed
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
record
|
|
FieldOffset: LongWord;
|
|
ClassTypeIndex: Word;
|
|
Name: ShortString;
|
|
end;
|
|
|
|
PFieldTable = ^TFieldTable;
|
|
TFieldTable =
|
|
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
packed
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
record
|
|
FieldCount: Word;
|
|
ClassTable: PFieldClassTable;
|
|
{ should be array[Word] of TFieldinfo; but Elements have variant size! force at least proper alignment }
|
|
Fields: array[0..0] of TFieldInfo;
|
|
end;
|
|
|
|
function GetVMTSize(AClass: TClass): integer;
|
|
var
|
|
p: PPointer;
|
|
begin
|
|
Result:=10000;
|
|
if AClass=nil then exit;
|
|
p:=PPointer(pointer(AClass)+vmtMethodStart);
|
|
Result:=vmtMethodStart;
|
|
while (p^<>nil) and (Result<10000) do begin
|
|
inc(p);
|
|
inc(Result,SizeOf(Pointer));
|
|
end;
|
|
end;
|
|
|
|
function FindVMTMethodOffset(AClass: TClass; MethodPointer: Pointer): integer;
|
|
var
|
|
i: Integer;
|
|
p: Pointer;
|
|
begin
|
|
i:=vmtMethodStart div SizeOf(Pointer);
|
|
while i<=10000 do begin
|
|
p:=PPointer(pointer(AClass))[i];
|
|
if p=nil then break;
|
|
if p=MethodPointer then begin
|
|
Result:=i*SizeOf(Pointer);
|
|
exit;
|
|
end;
|
|
inc(i);
|
|
end;
|
|
Result:=0;
|
|
end;
|
|
|
|
function GetVMTVirtualMethodOffset(
|
|
ParentClassWithVirtualMethod: TClass; MethodOfParentClass: Pointer;
|
|
ClassWithOverrideMethod: TClass; OverrideMethodOfClass: Pointer
|
|
): integer;
|
|
var
|
|
ParentMethodOffset: LongInt;
|
|
OverrideMethodOffset: LongInt;
|
|
begin
|
|
ParentMethodOffset:=FindVMTMethodOffset(
|
|
ParentClassWithVirtualMethod,MethodOfParentClass);
|
|
if ParentMethodOffset<=0 then
|
|
raise Exception.Create('GetVMTVirtualMethodOffset Parent Virtual Method not found');
|
|
OverrideMethodOffset:=FindVMTMethodOffset(
|
|
ClassWithOverrideMethod,OverrideMethodOfClass);
|
|
if OverrideMethodOffset<=0 then
|
|
raise Exception.Create('GetVMTVirtualMethodOffset Override Method not found');
|
|
if ParentMethodOffset<>OverrideMethodOffset then
|
|
raise Exception.Create('GetVMTVirtualMethodOffset Virtual Method Offset <> Override Method Offset');
|
|
Result:=OverrideMethodOffset;
|
|
end;
|
|
|
|
{ TComponentWithOverrideValidateRename }
|
|
type
|
|
TComponentWithOverrideValidateRename = class(TComponent)
|
|
public
|
|
procedure ValidateRename(AComponent: TComponent;
|
|
const CurName, NewName: string); override;
|
|
end;
|
|
|
|
var
|
|
TComponentValidateRenameOffset: LongInt = 0;
|
|
|
|
procedure TComponentWithOverrideValidateRename.ValidateRename(
|
|
AComponent: TComponent; const CurName, NewName: string);
|
|
var
|
|
Designer: TIDesigner;
|
|
begin
|
|
//debugln(['TComponentWithOverrideValidateRename.ValidateRename ',DbgSName(Self),' ',DbgSName(AComponent),' CurName=',CurName,' NewName=',NewName]);
|
|
inherited ValidateRename(AComponent, CurName, NewName);
|
|
Designer:=FindRootDesigner(Self);
|
|
if Designer <> nil then
|
|
Designer.ValidateRename(AComponent, CurName, NewName);
|
|
end;
|
|
|
|
|
|
function GetTComponentValidateRenameVMTOffset: integer;
|
|
begin
|
|
Result:=GetVMTVirtualMethodOffset(TComponent,
|
|
@TComponent.ValidateRename,
|
|
TComponentWithOverrideValidateRename,
|
|
@TComponentWithOverrideValidateRename.ValidateRename);
|
|
end;
|
|
|
|
var
|
|
MyFindGlobalComponentProc: function(const AName: AnsiString): TComponent of object;
|
|
|
|
function MyFindGlobalComponent(const AName: AnsiString): TComponent;
|
|
begin
|
|
Result:=MyFindGlobalComponentProc(AName);
|
|
end;
|
|
|
|
function IsJITMethod(const aMethod: TMethod): boolean;
|
|
begin
|
|
Result:=(aMethod.Data<>nil) and (aMethod.Code=nil)
|
|
and (TObject(aMethod.Data).ClassType=TJITMethod);
|
|
end;
|
|
|
|
function ClassAsString(AClass: TClass): string;
|
|
var
|
|
ParentClass: TClass;
|
|
begin
|
|
Result:='Class='+DbgS(AClass);
|
|
if AClass=nil then exit;
|
|
Result:=Result+' Name="'+AClass.ClassName+'"';
|
|
ParentClass:=AClass.ClassParent;
|
|
if ParentClass<>nil then
|
|
Result:=Result+' Parent='+DbgS(ParentClass)+'-"'+ParentClass.ClassName+'"';
|
|
Result:=Result+LineEnding;
|
|
Result:=Result+' vmtInstanceSize='+IntToStr(PLongInt(pointer(AClass)+vmtInstanceSize)^);
|
|
Result:=Result+' vmtInstanceSizeNeg='+IntToStr(PLongInt(pointer(AClass)+vmtInstanceSizeNeg)^);
|
|
Result:=Result+' vmtParent='+DbgS(pcardinal(pointer(AClass)+vmtParent)^);
|
|
Result:=Result+' vmtClassName="'+PShortString((Pointer(AClass)+vmtClassName)^)^+'"';
|
|
Result:=Result+' vmtDynamicTable='+DbgS(pcardinal(pointer(AClass)+vmtDynamicTable)^);
|
|
Result:=Result+' vmtMethodTable='+DbgS(pcardinal(pointer(AClass)+vmtMethodTable)^);
|
|
Result:=Result+' vmtFieldTable='+DbgS(pcardinal(pointer(AClass)+vmtFieldTable)^);
|
|
Result:=Result+' vmtTypeInfo='+DbgS(pcardinal(pointer(AClass)+vmtTypeInfo)^);
|
|
Result:=Result+' vmtInitTable='+DbgS(pcardinal(pointer(AClass)+vmtInitTable)^);
|
|
Result:=Result+' vmtAutoTable='+DbgS(pcardinal(pointer(AClass)+vmtAutoTable)^);
|
|
Result:=Result+' vmtIntfTable='+DbgS(pcardinal(pointer(AClass)+vmtIntfTable)^);
|
|
Result:=Result+' vmtMsgStrPtr='+DbgS(pcardinal(pointer(AClass)+vmtMsgStrPtr)^);
|
|
Result:=Result+LineEnding;
|
|
Result:=Result+' MethodTable=['+ClassMethodTableAsString(AClass)+']';
|
|
Result:=Result+LineEnding;
|
|
Result:=Result+' TypeInfo=['+ClassTypeInfoAsString(AClass)+']';
|
|
Result:=Result+LineEnding;
|
|
Result:=Result+' FieldTable=['+ClassFieldTableAsString(AClass)+']';
|
|
end;
|
|
|
|
function ClassMethodTableAsString(AClass: TClass): string;
|
|
var
|
|
MethodTable: PMethodNameTable;
|
|
i: Integer;
|
|
begin
|
|
Result:='';
|
|
if AClass=nil then exit;
|
|
MethodTable:=PMethodNameTable((Pointer(AClass)+vmtMethodTable)^);
|
|
if MethodTable=nil then exit;
|
|
for i:=0 to MethodTable^.Count-1 do begin
|
|
if i>0 then Result:=Result+',';
|
|
Result:=Result+IntToStr(i)+':"'+(MethodTable^.Entries[i].Name^)+'"'
|
|
+':'+DbgS(MethodTable^.Entries[i].Addr);
|
|
end;
|
|
end;
|
|
|
|
function ClassTypeInfoAsString(AClass: TClass): string;
|
|
var
|
|
TypeInfo: PTypeInfo;
|
|
TypeData: PTypeData;
|
|
PropInfo: PPropInfo;
|
|
CurCount: integer;
|
|
i: Integer;
|
|
begin
|
|
Result:='';
|
|
if AClass=nil then exit;
|
|
TypeInfo:=AClass.ClassInfo;
|
|
if TypeInfo=nil then exit;
|
|
Result:=Result+'ClassInfo^.Name="'+TypeInfo^.Name+'"';
|
|
// read all property infos of current class
|
|
TypeData:=GetTypeData(TypeInfo);
|
|
if TypeData=nil then exit;
|
|
Result:=Result+' ClassType='+DbgS(TypeData^.ClassType);
|
|
if TypeData^.ClassType<>AClass then
|
|
Result:=Result+LineEnding
|
|
+' WARNING: ClassType<>AClass('+DbgS(AClass)+')'+LineEnding;
|
|
Result:=Result+' ParentInfo='+DbgS(TypeData^.ParentInfo);
|
|
if (AClass.ClassParent<>nil)
|
|
and (TypeData^.ParentInfo<>AClass.ClassParent.ClassInfo) then
|
|
Result:=Result+LineEnding
|
|
+' WARNING: TypeData^.ParentInfo<>AClass.ClassParent.ClassInfo('
|
|
+DbgS(TypeData^.ParentInfo)+'<>'
|
|
+DbgS(AClass.ClassParent.ClassInfo)+'<>'+')'+LineEnding;
|
|
Result:=Result+' PropCount='+IntToStr(TypeData^.PropCount);
|
|
Result:=Result+' UnitName="'+TypeData^.UnitName+'"';
|
|
|
|
// skip unitname
|
|
PropInfo:=PPropInfo(PByte(@TypeData^.UnitName)+Length(TypeData^.UnitName)+1);
|
|
// read property count
|
|
CurCount:=PWord(PropInfo)^;
|
|
Result:=Result+' CurPropCnt='+IntToStr(CurCount);
|
|
inc(PropInfo,SizeOf(Word));
|
|
|
|
// read properties
|
|
Result:=Result+' Properties={';
|
|
for i:=0 to CurCount-1 do begin
|
|
if i>0 then Result:=Result+',';
|
|
// point PropInfo to next propinfo record.
|
|
// Located at Name[Length(Name)+1] !
|
|
Result:=Result+IntToStr(i)+':PropName="'+PropInfo^.Name+'"'
|
|
+':Type="'+PropInfo^.PropType^.Name+'"';
|
|
PropInfo:=PPropInfo(pointer(@PropInfo^.Name)+PByte(@PropInfo^.Name)^+1);
|
|
end;
|
|
Result:=Result+'}';
|
|
end;
|
|
|
|
function ClassFieldTableAsString(AClass: TClass): string;
|
|
var
|
|
FieldTable: PFieldTable;
|
|
FieldInfo: PFieldInfo;
|
|
i: Integer;
|
|
ClassTable: PFieldClassTable;
|
|
begin
|
|
Result:='';
|
|
if AClass=nil then exit;
|
|
FieldTable:=PFieldTable((Pointer(AClass)+vmtFieldTable)^);
|
|
if FieldTable=nil then exit;
|
|
Result:=Result+'FieldCount='+IntToStr(FieldTable^.FieldCount);
|
|
ClassTable:=FieldTable^.ClassTable;
|
|
Result:=Result+' ClassTable='+DbgS(ClassTable);
|
|
if ClassTable<>nil then begin
|
|
Result:=Result+'={';
|
|
for i:=0 to ClassTable^.Count-1 do begin
|
|
if i>0 then Result:=Result+',';
|
|
Result:=Result+IntToStr(i)+':Name="'+ClassTable^.Entries[i].ClassName+'"';
|
|
end;
|
|
end;
|
|
Result:=Result+'}';
|
|
FieldInfo := @FieldTable^.Fields[0];
|
|
Result := Result + ' Fields={';
|
|
for i := 0 to FieldTable^.FieldCount-1 do begin
|
|
if i > 0 then Result:=Result+',';
|
|
Result := Result + IntToStr(i)
|
|
+ ':Name="' + FieldInfo^.Name + '"'
|
|
+ ':Offset=' +IntToStr(FieldInfo^.FieldOffset);
|
|
FieldInfo := PFieldInfo(PByte(@FieldInfo^.Name) + 1 + Length(FieldInfo^.Name));
|
|
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
FieldInfo := Align(FieldInfo, SizeOf(Pointer));
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
end;
|
|
Result := Result+'}';
|
|
end;
|
|
|
|
function CalculateTypeDataSize(PropInfoCount: integer): integer;
|
|
begin
|
|
Result := SizeOf(TTypeData) + 2; // TTypeData + one word for new prop count
|
|
// Actually the size depends on the UnitName. But SizeOf(TTypeData) already
|
|
// uses the maximum size of the shortstring.
|
|
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
if Result and (SizeOf(Pointer) - 1) <> 0 then
|
|
Inc(Result, SizeOf(Pointer)); // a few bytes too much, but at least enough
|
|
{$endif}
|
|
inc(Result,PropInfoCount*SizeOf(TPropInfo));
|
|
end;
|
|
|
|
function GetTypeDataPropCountAddr(TypeData: PTypeData): PWord;
|
|
begin
|
|
Result:=PWord(PByte(@TypeData^.UnitName)+Length(TypeData^.UnitName)+1);
|
|
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
Result := Align(Result, SizeOf(Pointer));
|
|
{$endif}
|
|
end;
|
|
|
|
function CompareJITMethod(Data1, Data2: Pointer): integer;
|
|
var
|
|
JITMethod1: TJITMethod;
|
|
JITMethod2: TJITMethod;
|
|
begin
|
|
JITMethod1:=TJITMethod(Data1);
|
|
JITMethod2:=TJITMethod(Data2);
|
|
Result:=ComparePointers(JITMethod1.TheClass,JITMethod2.TheClass);
|
|
if Result<>0 then exit;
|
|
Result:=CompareText(JITMethod1.TheMethodName,JITMethod2.TheMethodName);
|
|
end;
|
|
|
|
function CalculateTypeInfoSize(const AClassName: shortstring;
|
|
PropInfoCount: integer): integer;
|
|
begin
|
|
Result := SizeOf(TTypeKind) + 1 + length(AClassName)
|
|
+ CalculateTypeDataSize(PropInfoCount);
|
|
{$warnings off}
|
|
if SizeOf(TTypeKind)<>1 then
|
|
raise Exception.Create('CalculateTypeInfoSize SizeOf(TTypeInfo^.Kind)<>1');
|
|
{$warnings on}
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
|
|
|
|
{ TJITComponentList }
|
|
|
|
constructor TJITComponentList.Create;
|
|
begin
|
|
inherited Create;
|
|
FJITComponents:=TList.Create;
|
|
FErrors:=TLRPositionLinks.Create;
|
|
end;
|
|
|
|
destructor TJITComponentList.Destroy;
|
|
begin
|
|
while FJITComponents.Count>0 do DestroyJITComponent(FJITComponents.Count-1);
|
|
FreeAndNil(FJITComponents);
|
|
FreeAndNil(FErrors);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJITComponentList.GetItem(Index:integer):TComponent;
|
|
begin
|
|
Result:=TComponent(FJITComponents[Index]);
|
|
end;
|
|
|
|
function TJITComponentList.Count:integer;
|
|
begin
|
|
Result:=FJITComponents.Count;
|
|
end;
|
|
|
|
function TJITComponentList.IndexOf(JITComponent:TComponent):integer;
|
|
begin
|
|
Result:=Count-1;
|
|
while (Result>=0) and (Items[Result]<>JITComponent) do dec(Result);
|
|
end;
|
|
|
|
function TJITComponentList.Contains(JITComponent: TComponent): boolean;
|
|
begin
|
|
Result:=IndexOf(JITComponent)>=0;
|
|
end;
|
|
|
|
procedure TJITComponentList.DestroyJITComponent(JITComponent:TComponent);
|
|
var a:integer;
|
|
begin
|
|
if JITComponent=nil then
|
|
RaiseException('TJITComponentList.DestroyJITForm JITComponent=nil');
|
|
a:=IndexOf(JITComponent);
|
|
if a<0 then
|
|
RaiseException('TJITComponentList.DestroyJITForm JITComponent.ClassName='+
|
|
JITComponent.ClassName);
|
|
if a>=0 then DestroyJITComponent(a);
|
|
end;
|
|
|
|
procedure TJITComponentList.DestroyJITComponent(Index:integer);
|
|
var
|
|
OldClass: TClass;
|
|
Action: TModalResult;
|
|
begin
|
|
OldClass:=Items[Index].ClassType;
|
|
try
|
|
Items[Index].Free;
|
|
except
|
|
on E: Exception do begin
|
|
HandleException(E,'[TJITComponentList.DestroyJITComponent] ERROR destroying component',Action);
|
|
end;
|
|
end;
|
|
FreeJITClass(OldClass);
|
|
FJITComponents.Delete(Index);
|
|
end;
|
|
|
|
function TJITComponentList.FindComponentByClassName(
|
|
const AClassName:shortstring):integer;
|
|
begin
|
|
Result:=FJITComponents.Count-1;
|
|
while (Result>=0)
|
|
and (CompareText(Items[Result].ClassName,AClassName)<>0) do
|
|
dec(Result);
|
|
end;
|
|
|
|
function TJITComponentList.FindComponentByClass(AClass: TComponentClass
|
|
): integer;
|
|
begin
|
|
Result:=FJITComponents.Count-1;
|
|
while (Result>=0) and (Items[Result].ClassType<>AClass) do
|
|
dec(Result);
|
|
end;
|
|
|
|
function TJITComponentList.FindComponentByName(const AName:shortstring):integer;
|
|
begin
|
|
Result:=FJITComponents.Count-1;
|
|
while (Result>=0)
|
|
and (CompareText(Items[Result].Name,AName)<>0) do
|
|
dec(Result);
|
|
end;
|
|
|
|
procedure TJITComponentList.GetUnusedNames(
|
|
var ComponentName,ComponentClassName:shortstring);
|
|
var a:integer;
|
|
ComponentPrefix: String;
|
|
begin
|
|
a:=1;
|
|
ComponentPrefix:=ComponentClassName;
|
|
if ComponentPrefix='' then
|
|
ComponentPrefix:='Component';
|
|
if ComponentPrefix[1] in ['t','T'] then
|
|
ComponentPrefix:=copy(ComponentPrefix,2,length(ComponentPrefix));
|
|
repeat
|
|
ComponentName:=ComponentPrefix+IntToStr(a);
|
|
ComponentClassName:='T'+ComponentName;
|
|
inc(a);
|
|
until (FindComponentByName(ComponentName)<0)
|
|
and (FindComponentByClassName(ComponentClassName)<0);
|
|
end;
|
|
|
|
function TJITComponentList.AddNewJITComponent(const NewUnitName: shortstring;
|
|
AncestorClass: TClass): integer;
|
|
var
|
|
NewComponentName, NewClassName: shortstring;
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList] AddNewJITComponent');
|
|
{$ENDIF}
|
|
NewClassName:=AncestorClass.ClassName;
|
|
GetUnusedNames(NewComponentName,NewClassName);
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('TJITComponentList.AddNewJITComponent NewComponentName=',NewComponentName,' NewClassName=',NewClassName,
|
|
' NewUnitName=',NewUnitName,' AncestorClass=',AncestorClass.ClassName);
|
|
{$ENDIF}
|
|
Result:=DoCreateJITComponent(NewComponentName,NewClassName,NewUnitName,
|
|
AncestorClass,true);
|
|
end;
|
|
|
|
function TJITComponentList.AddJITComponentFromStream(BinStream: TStream;
|
|
AncestorClass: TClass;
|
|
const NewUnitName: ShortString;
|
|
Interactive, Visible: Boolean;
|
|
ContextObj: TObject): integer;
|
|
// returns new index
|
|
// -1 = invalid stream
|
|
|
|
procedure ReadStream(AStream: TStream; StreamClass: TClass);
|
|
var
|
|
Reader: TReader;
|
|
DestroyDriver: Boolean;
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.AddJITComponentFromStream] InitReading ...');
|
|
{$ENDIF}
|
|
|
|
FCurReadStreamClass:=StreamClass;
|
|
DestroyDriver:=false;
|
|
InitReading;
|
|
CreateReader(AStream,Reader,DestroyDriver);
|
|
{ $IFDEF VerboseJITForms}
|
|
DebugLn(['TJITComponentList.AddJITComponentFromStream.ReadStream Reading: FCurReadJITComponent=',DbgSName(FCurReadJITComponent),' StreamClass=',DbgSName(StreamClass)]);
|
|
{ $ENDIF}
|
|
try
|
|
Reader.ReadRootComponent(FCurReadJITComponent);
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.AddJITComponentFromStream] Finish Reading ...');
|
|
{$ENDIF}
|
|
DoFinishReading;
|
|
finally
|
|
UnregisterFindGlobalComponentProc(@MyFindGlobalComponent);
|
|
Application.FindGlobalComponentEnabled:=true;
|
|
if DestroyDriver then Reader.Driver.Free;
|
|
Reader.Free;
|
|
end;
|
|
FCurReadStreamClass:=nil;
|
|
end;
|
|
|
|
function ReadAncestorStreams: boolean;
|
|
var
|
|
i: Integer;
|
|
Ancestors: TFPList;
|
|
AncestorStreams: TFPList;
|
|
Abort: boolean;
|
|
begin
|
|
if not Assigned(OnFindAncestors) then exit(true);
|
|
Ancestors:=nil;
|
|
AncestorStreams:=nil;
|
|
try
|
|
Abort:=false;
|
|
OnFindAncestors(Self,AncestorClass,Ancestors,AncestorStreams,Abort);
|
|
if Abort then exit(false);
|
|
if Ancestors<>nil then begin
|
|
for i:=Ancestors.Count-1 downto 0 do begin
|
|
ReadStream(TExtMemoryStream(AncestorStreams[i]),
|
|
TComponent(Ancestors[i]).ClassType);
|
|
end;
|
|
end;
|
|
finally
|
|
Ancestors.Free;
|
|
if AncestorStreams<>nil then
|
|
for i:=0 to AncestorStreams.Count-1 do
|
|
TObject(AncestorStreams[i]).Free;
|
|
AncestorStreams.Free;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
NewClassName: shortstring;
|
|
NewName: string;
|
|
IsInherited: Boolean;
|
|
Action: TModalResult;
|
|
begin
|
|
Result:=-1;
|
|
FContextObject:=ContextObj;
|
|
NewClassName:=GetClassNameFromLRSStream(BinStream, IsInherited);
|
|
if IsInherited then ;
|
|
if NewClassName='' then begin
|
|
MessageDlg('No classname in stream found.',mtError,[mbOK],0);
|
|
FContextObject:=nil;
|
|
exit;
|
|
end;
|
|
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.AddJITComponentFromStream] Create ...');
|
|
{$ENDIF}
|
|
try
|
|
Result:=DoCreateJITComponent('',NewClassName,NewUnitName,AncestorClass,Visible);
|
|
if Result<0 then exit;
|
|
ReadAncestorStreams;
|
|
ReadStream(BinStream,FCurReadJITComponent.ClassType);
|
|
|
|
if FCurReadJITComponent.Name='' then begin
|
|
NewName:=FCurReadJITComponent.ClassName;
|
|
if NewName[1] in ['T','t'] then
|
|
System.Delete(NewName,1,1);
|
|
FCurReadJITComponent.Name:=NewName;
|
|
end;
|
|
except
|
|
on E: Exception do begin
|
|
HandleException(E,'[TJITComponentList.AddJITChildComponentFromStream] ERROR reading form stream'
|
|
+' of Class "'+NewClassName+'"',Action);
|
|
if Result>=0 then begin
|
|
// try freeing the unfinished thing
|
|
FCurReadJITComponent:=nil;
|
|
DestroyJITComponent(Result);
|
|
Result:=-1;
|
|
end;
|
|
end;
|
|
end;
|
|
FCurReadStreamClass:=nil;
|
|
FCurReadJITComponent:=nil;
|
|
FContextObject:=nil;
|
|
end;
|
|
|
|
function TJITComponentList.OnFindGlobalComponent(
|
|
const AName: AnsiString): TComponent;
|
|
begin
|
|
// This event is triggered everytime TReader searches a Component.
|
|
// It is triggered for every sub component and every reference.
|
|
// The sub comonent are found by TReader itself.
|
|
// The other components are done at the end via GlobalFixupReferences.
|
|
// So, there is nothing left to do here.
|
|
Result := nil;
|
|
//DebugLn(dbgsName(CurReadJITComponent), ' FIND global component ', AName, ' ', dbgsName(Result));
|
|
end;
|
|
|
|
procedure TJITComponentList.InitReading;
|
|
begin
|
|
FFlags:=FFlags-[jclAutoRenameComponents];
|
|
FErrors.Clear;
|
|
|
|
MyFindGlobalComponentProc:=@OnFindGlobalComponent;
|
|
RegisterFindGlobalComponentProc(@MyFindGlobalComponent);
|
|
Application.FindGlobalComponentEnabled:=false;
|
|
end;
|
|
|
|
procedure TJITComponentList.CreateReader(BinStream: TStream;
|
|
var Reader: TReader; DestroyDriver: Boolean);
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.InitReading] A');
|
|
{$ENDIF}
|
|
DestroyDriver:=false;
|
|
Reader:=CreateLRSReader(BinStream,DestroyDriver);
|
|
// connect TReader events
|
|
Reader.OnError:=@ReaderError;
|
|
Reader.OnPropertyNotFound:=@ReaderPropertyNotFound;
|
|
Reader.OnFindMethod:=@ReaderFindMethod;
|
|
Reader.OnSetMethodProperty:=@ReaderSetMethodProperty;
|
|
Reader.OnSetName:=@ReaderSetName;
|
|
Reader.OnReferenceName:=@ReaderReferenceName;
|
|
Reader.OnAncestorNotFound:=@ReaderAncestorNotFound;
|
|
Reader.OnCreateComponent:=@ReaderCreateComponent;
|
|
Reader.OnFindComponentClass:=@ReaderFindComponentClass;
|
|
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.InitReading] B');
|
|
{$ENDIF}
|
|
|
|
FCurReadChildClass:=nil;
|
|
FCurReadChild:=nil;
|
|
FCurReadErrorMsg:='';
|
|
end;
|
|
|
|
function TJITComponentList.DoCreateJITComponent(
|
|
const NewComponentName, NewClassName, NewUnitName: shortstring;
|
|
AncestorClass: TClass; Visible: boolean):integer;
|
|
var
|
|
Instance:TComponent;
|
|
ok: boolean;
|
|
Action: TModalResult;
|
|
begin
|
|
Result:=-1;
|
|
Instance:=nil;
|
|
FCurReadClass:=nil;
|
|
FCurReadStreamClass:=nil;
|
|
FCurReadJITComponent:=nil;
|
|
|
|
try
|
|
ok:=false;
|
|
// create new class and an instance
|
|
//debugln('[TJITForms.DoCreateJITComponent] Creating new JIT class '''+NewClassName+''' ...');
|
|
Pointer(FCurReadClass):=CreateNewJITClass(AncestorClass,NewClassName,
|
|
NewUnitName);
|
|
//debugln('[TJITForms.DoCreateJITComponent] Creating an instance of JIT class "'+NewClassName+'" = class('+AncestorClass.ClassName+') ...');
|
|
Instance:=TComponent(FCurReadClass.NewInstance);
|
|
//debugln('[TJITForms.DoCreateJITComponent] Initializing new instance ... ',DbgS(Instance));
|
|
TComponent(FCurReadJITComponent):=Instance;
|
|
try
|
|
// set into design mode
|
|
SetComponentDesignMode(Instance, True);
|
|
// set csDesignInstance: it is a root design component
|
|
SetComponentDesignInstanceMode(Instance, True);
|
|
if (not Visible) and (Instance is TControl) then
|
|
TControl(Instance).ControlStyle:=
|
|
TControl(Instance).ControlStyle+[csNoDesignVisible];
|
|
// finish 'create' component
|
|
Instance.Create(nil);
|
|
if NewComponentName<>'' then
|
|
Instance.Name:=NewComponentName;
|
|
DoRenameClass(FCurReadClass,NewClassName);
|
|
ok:=true;
|
|
//debugln('[TJITForms.DoCreateJITComponent] Initialization was successful! FormName="',NewFormName,'"');
|
|
finally
|
|
if not ok then begin
|
|
TComponent(FCurReadJITComponent):=nil;
|
|
DebugLn('[TJITForms.DoCreateJITComponent] Error while creating instance: NewComponentName="',NewComponentName,'" NewClassName="',NewClassName,'" NewUnitName="',NewUnitName,'"');
|
|
end;
|
|
end;
|
|
except
|
|
on E: Exception do begin
|
|
HandleException(E,'[TJITForms.DoCreateJITComponent] Error',Action);
|
|
try
|
|
if FCurReadClass<>nil then
|
|
FreeJITClass(FCurReadClass);
|
|
Instance.Free;
|
|
except
|
|
on E: Exception do begin
|
|
HandleException(E,'[TJITForms.DoCreateJITComponent] Error while destroying instance: NewComponentName="'+NewComponentName+'" NewClassName="'+NewClassName+'" NewUnitName="'+NewUnitName+'"',Action);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
if FCurReadJITComponent<>nil then
|
|
Result:=FJITComponents.Add(FCurReadJITComponent);
|
|
end;
|
|
|
|
procedure TJITComponentList.ReadInlineComponent(var Component: TComponent;
|
|
ComponentClass: TComponentClass; Owner: TComponent);
|
|
var
|
|
DestroyDriver: Boolean;
|
|
SubReader: TReader;
|
|
BinStream: TExtMemoryStream;
|
|
Ancestor: TComponent;
|
|
Abort: boolean;
|
|
Ancestors: TFPList;
|
|
AncestorStreams: TFPList;
|
|
i: Integer;
|
|
OldStreamClass: TClass;
|
|
begin
|
|
fCurReadChild:=Component;
|
|
fCurReadChildClass:=ComponentClass;
|
|
|
|
if Assigned(OnFindAncestors) then begin
|
|
Ancestors:=nil;
|
|
AncestorStreams:=nil;
|
|
OldStreamClass:=FCurReadStreamClass;
|
|
try
|
|
Abort:=false;
|
|
OnFindAncestors(Self,ComponentClass,Ancestors,AncestorStreams,Abort);
|
|
if Abort then begin
|
|
DebugLn(['TJITComponentList.ReadInlineComponent aborted reading ComponentClass=',DbgSName(ComponentClass)]);
|
|
raise EReadError.Create('TJITComponentList.ReadInlineComponent aborted reading ComponentClass='+DbgSName(ComponentClass));
|
|
end;
|
|
if Ancestors<>nil then begin
|
|
// read ancestor streams
|
|
Ancestor:=nil;
|
|
for i:=Ancestors.Count-1 downto 0 do begin
|
|
BinStream:=TExtMemoryStream(AncestorStreams[i]);
|
|
FCurReadStreamClass:=TComponent(Ancestors[i]).ClassType;
|
|
|
|
DebugLn(['TJITComponentList.ReadInlineComponent Has Stream: ',DbgSName(FCurReadStreamClass)]);
|
|
// create component
|
|
if Component=nil then begin
|
|
DebugLn(['TJITComponentList.ReadInlineComponent creating ',DbgSName(ComponentClass),' Owner=',DbgSName(Owner),' ...']);
|
|
// allocate memory without running the constructor
|
|
Component:=TComponent(ComponentClass.newinstance);
|
|
// set csDesigning
|
|
SetComponentDesignMode(Component,true);
|
|
// this is a streamed sub component => set csInline
|
|
SetComponentInlineMode(Component,true);
|
|
// now run the constructor
|
|
Component.Create(Owner);
|
|
end;
|
|
// read stream
|
|
fCurReadChild:=Component;
|
|
fCurReadChildClass:=ComponentClass;
|
|
SubReader:=nil;
|
|
DestroyDriver:=false;
|
|
try
|
|
CreateReader(BinStream,SubReader,DestroyDriver);
|
|
// The stream contains only the diff to the Ancestor instance,
|
|
// => give it the Ancestor instance
|
|
SubReader.Ancestor:=Ancestor;
|
|
SubReader.ReadRootComponent(Component);
|
|
finally
|
|
if SubReader<>nil then begin
|
|
if DestroyDriver then SubReader.Driver.Free;
|
|
SubReader.Free;
|
|
end;
|
|
end;
|
|
FCurReadStreamClass:=OldStreamClass;
|
|
|
|
// next
|
|
Ancestor:=TComponent(Ancestors[i]);
|
|
end;
|
|
end;
|
|
finally
|
|
Ancestors.Free;
|
|
if AncestorStreams<>nil then
|
|
for i:=0 to AncestorStreams.Count-1 do
|
|
TObject(AncestorStreams[i]).Free;
|
|
AncestorStreams.Free;
|
|
end;
|
|
FCurReadStreamClass:=OldStreamClass;
|
|
fCurReadChild:=Component;
|
|
fCurReadChildClass:=ComponentClass;
|
|
end;
|
|
//debugln(['[TJITComponentList.ReadInlineComponent] Class=',ComponentClass.ClassName,' Component=',dbgsName(Component)]);
|
|
end;
|
|
|
|
procedure TJITComponentList.DoFinishReading;
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TJITComponentList.HandleException(E: Exception;
|
|
const Context: string; out Action: TModalResult);
|
|
begin
|
|
Action:=mrAbort;
|
|
FCurReadErrorMsg:=E.Message;
|
|
// first write error to debug
|
|
DebugLn(Context+' Error: '+FCurReadErrorMsg);
|
|
// then try to give a backtrace
|
|
DumpExceptionBackTrace;
|
|
if Assigned(OnException) then
|
|
OnException(Self,E,Action)
|
|
else begin
|
|
// then try to give a visible warning
|
|
MessageDlg('Read error',
|
|
Context+#13
|
|
+'Error: '+FCurReadErrorMsg,mtError,[mbCancel],0);
|
|
end;
|
|
end;
|
|
|
|
procedure TJITComponentList.RemoveMethod(JITComponent:TComponent;
|
|
const AName:ShortString);
|
|
var OldCode:Pointer;
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('TJITComponentList.RemoveMethod ',JITComponent.Name,':',JITComponent.Name,' Method=',AName);
|
|
{$ENDIF}
|
|
if JITComponent=nil then
|
|
raise Exception.Create('TJITComponentList.RemoveMethod JITComponent=nil');
|
|
if IndexOf(JITComponent)<0 then
|
|
raise Exception.Create('TJITComponentList.RemoveMethod JITComponent.ClassName='+
|
|
JITComponent.ClassName);
|
|
if (AName='') or (not IsValidIdent(AName)) then
|
|
raise Exception.Create('TJITComponentList.RemoveMethod invalid name: "'+AName+'"');
|
|
|
|
// delete TJITMethod
|
|
if JITMethods.Delete(JITComponent.ClassType,AName) then begin
|
|
// this was a TJITmethod
|
|
exit;
|
|
end;
|
|
|
|
// delete real method
|
|
OldCode:=nil;
|
|
DoRemoveMethod(JITComponent.ClassType,AName,OldCode);
|
|
FreeMem(OldCode);
|
|
end;
|
|
|
|
procedure TJITComponentList.RenameMethod(JITComponent:TComponent;
|
|
const OldName,NewName:ShortString);
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('TJITComponentList.RenameMethod ',JITComponent.Name,':',JITComponent.Name,' Old=',OldName,' NewName=',NewName);
|
|
{$ENDIF}
|
|
if JITComponent=nil then
|
|
raise Exception.Create('TJITComponentList.RenameMethod JITComponent=nil');
|
|
if IndexOf(JITComponent)<0 then
|
|
raise Exception.Create('TJITComponentList.RenameMethod JITComponent.ClassName='+
|
|
JITComponent.ClassName);
|
|
if (NewName='') or (not IsValidIdent(NewName)) then
|
|
raise Exception.Create('TJITComponentList.RenameMethod invalid name: "'+NewName+'"');
|
|
|
|
// rename TJITMethod
|
|
if JITMethods.Rename(JITComponent.ClassType,OldName,NewName) then begin
|
|
// this was a TJITMethod
|
|
exit;
|
|
end;
|
|
|
|
// rename real method
|
|
DoRenameMethod(JITComponent.ClassType,OldName,NewName);
|
|
end;
|
|
|
|
procedure TJITComponentList.RenameComponentClass(JITComponent:TComponent;
|
|
const NewName:ShortString);
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('TJITComponentList.RenameComponentClass ',JITComponent.Name,':',JITComponent.Name,' New=',NewName);
|
|
{$ENDIF}
|
|
if JITComponent=nil then
|
|
raise Exception.Create('TJITComponentList.RenameComponentClass JITComponent=nil');
|
|
if IndexOf(JITComponent)<0 then
|
|
raise Exception.Create('TJITComponentList.RenameComponentClass JITComponent.ClassName='+
|
|
JITComponent.ClassName);
|
|
if (NewName='') or (not IsValidIdent(NewName)) then
|
|
raise Exception.Create('TJITComponentList.RenameComponentClass invalid name: "'+NewName+'"');
|
|
DoRenameClass(JITComponent.ClassType,NewName);
|
|
end;
|
|
|
|
procedure TJITComponentList.RenameComponentUnitname(JITComponent: TComponent;
|
|
const NewUnitName: ShortString);
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('TJITComponentList.RenameComponentUnitname ',JITComponent.Name,':',JITComponent.Name,' New=',NewUnitName);
|
|
{$ENDIF}
|
|
if JITComponent=nil then
|
|
raise Exception.Create('TJITComponentList.RenameComponentUnitname JITComponent=nil');
|
|
if IndexOf(JITComponent)<0 then
|
|
raise Exception.Create('TJITComponentList.RenameComponentUnitname JITComponent.ClassName='+
|
|
JITComponent.ClassName);
|
|
if (NewUnitName='') or (not IsValidIdent(NewUnitName)) then
|
|
raise Exception.Create('TJITComponentList.RenameComponentUnitname invalid name: "'+NewUnitName+'"');
|
|
DoRenameUnitNameOfClass(JITComponent.ClassType,NewUnitName);
|
|
end;
|
|
|
|
function TJITComponentList.AddJITChildComponentFromStream(
|
|
JITOwnerComponent: TComponent; BinStream: TStream;
|
|
ComponentClass: TComponentClass; ParentControl: TWinControl): TComponent;
|
|
var
|
|
Reader: TReader;
|
|
NewComponent: TComponent;
|
|
DestroyDriver: Boolean;
|
|
Action: TModalResult;
|
|
begin
|
|
Result:=nil;
|
|
NewComponent:=nil;
|
|
if IndexOf(JITOwnerComponent)<0 then
|
|
RaiseException('TJITComponentList.AddJITChildComponentFromStream');
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.AddJITChildComponentFromStream] A');
|
|
{$ENDIF}
|
|
FCurReadJITComponent:=nil;
|
|
FCurReadClass:=nil;
|
|
FCurReadStreamClass:=nil;
|
|
try
|
|
DestroyDriver:=false;
|
|
InitReading;
|
|
CreateReader(BinStream,Reader,DestroyDriver);
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.AddJITChildComponentFromStream] B');
|
|
{$ENDIF}
|
|
try
|
|
FCurReadJITComponent:=JITOwnerComponent;
|
|
FCurReadClass:=JITOwnerComponent.ClassType;
|
|
FCurReadStreamClass:=FCurReadClass;
|
|
|
|
FFlags:=FFlags+[jclAutoRenameComponents];
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.AddJITChildComponentFromStream] C1 ',ComponentClass.ClassName);
|
|
{$ENDIF}
|
|
Reader.Root := FCurReadJITComponent;
|
|
Reader.Owner := FCurReadJITComponent;
|
|
Reader.Parent := ParentControl;
|
|
Reader.BeginReferences;
|
|
try
|
|
Reader.Driver.BeginRootComponent;
|
|
NewComponent:=Reader.ReadComponent(nil);
|
|
Reader.FixupReferences;
|
|
finally
|
|
Reader.EndReferences;
|
|
end;
|
|
DebugLn('[TJITComponentList.AddJITChildComponentFromStream] C6 ');
|
|
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.AddJITChildComponentFromStream] D');
|
|
{$ENDIF}
|
|
DoFinishReading;
|
|
finally
|
|
UnregisterFindGlobalComponentProc(@MyFindGlobalComponent);
|
|
Application.FindGlobalComponentEnabled:=true;
|
|
if DestroyDriver then Reader.Driver.Free;
|
|
Reader.Free;
|
|
end;
|
|
except
|
|
on E: Exception do begin
|
|
HandleException(E,'[TJITComponentList.AddJITChildComponentFromStream] ERROR reading form stream of Class "'+ComponentClass.ClassName+'"',Action);
|
|
end;
|
|
end;
|
|
FCurReadStreamClass:=nil;
|
|
Result:=NewComponent;
|
|
end;
|
|
|
|
procedure TJITComponentList.ReadInlineJITChildComponent(Component: TComponent);
|
|
var
|
|
Action: TModalResult;
|
|
begin
|
|
FCurReadStreamClass:=nil;
|
|
InitReading;
|
|
{ $IFDEF VerboseJITForms}
|
|
DebugLn(['TJITComponentList.ReadInlineJITChildComponent Reading: ',DbgSName(Component)]);
|
|
{ $ENDIF}
|
|
try
|
|
try
|
|
FCurReadJITComponent:=Component;
|
|
ReadInlineComponent(Component,TComponentClass(Component.ClassType),Component.Owner);
|
|
except
|
|
on E: Exception do begin
|
|
HandleException(E,'[TJITComponentList.ReadInlineJITChildComponent] ERROR reading inline stream'
|
|
+' of "'+DbgSName(Component)+'"',Action);
|
|
end;
|
|
end;
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.ReadInlineJITChildComponent] Finish Reading ...');
|
|
{$ENDIF}
|
|
DoFinishReading;
|
|
finally
|
|
UnregisterFindGlobalComponentProc(@MyFindGlobalComponent);
|
|
Application.FindGlobalComponentEnabled:=true;
|
|
end;
|
|
FCurReadJITComponent:=nil;
|
|
FCurReadStreamClass:=nil;
|
|
end;
|
|
|
|
function TJITComponentList.CreateNewMethod(JITComponent: TComponent;
|
|
const AName: ShortString): TMethod;
|
|
var
|
|
OldCode: Pointer;
|
|
{$IFNDEF DisableFakeMethods}
|
|
JITMethod: TJITMethod;
|
|
{$ELSE}
|
|
CodeTemplate, NewCode: Pointer;
|
|
CodeSize: integer;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('TJITComponentList.CreateNewMethod ',JITComponent.Name,':',JITComponent.Name,' Method=',AName);
|
|
{$ENDIF}
|
|
if JITComponent=nil then
|
|
raise Exception.Create('TJITComponentList.CreateNewMethod JITComponent=nil');
|
|
if IndexOf(JITComponent)<0 then
|
|
raise Exception.Create('TJITComponentList.CreateNewMethod JITComponent.ClassName='+
|
|
JITComponent.ClassName);
|
|
if (AName='') or (not IsValidIdent(AName)) then
|
|
raise Exception.Create('TJITComponentList.CreateNewMethod invalid name: "'+AName+'"');
|
|
OldCode:=JITComponent.MethodAddress(AName);
|
|
if OldCode<>nil then begin
|
|
// there is already a real method with this name
|
|
Result.Data:=JITComponent;
|
|
Result.Code:=OldCode;
|
|
exit;
|
|
end;
|
|
{$IFNDEF DisableFakeMethods}
|
|
// create a TJITMethod
|
|
JITMethod:=JITMethods.Add(JITComponent.ClassType,AName);
|
|
Result:=JITMethod.Method;
|
|
{$ELSE}
|
|
CodeTemplate:=MethodAddress('DoNothing');
|
|
CodeSize:=100; // !!! what is the real codesize of DoNothing? !!!
|
|
GetMem(NewCode,CodeSize);
|
|
Move(CodeTemplate^,NewCode^,CodeSize);
|
|
DoAddNewMethod(JITComponent.ClassType,AName,NewCode);
|
|
Result.Data:=JITComponent;
|
|
Result.Code:=NewCode;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TJITComponentList.CreateNewJITClass(AncestorClass: TClass;
|
|
const NewClassName, NewUnitName: ShortString): TClass;
|
|
// Create a new class (vmt, virtual method table, field table and typeinfo)
|
|
// that descends from AncestorClass.
|
|
// The new class will have no new variables, no new methods and no new fields.
|
|
var
|
|
NewVMT: Pointer;
|
|
ClassNamePShortString: Pointer;
|
|
NewFieldTable: PFieldTable;
|
|
NewClassTable: PFieldClassTable;
|
|
NewTypeInfo: PTypeInfo;
|
|
NewTypeData: PTypeData;
|
|
TypeInfoSize: Integer;
|
|
AddedPropCount: PWord;
|
|
vmtSize: Integer;
|
|
vmtTailSize: Integer;
|
|
begin
|
|
if AncestorClass=nil then
|
|
raise Exception.Create('CreateNewClass AncestorClass=nil');
|
|
if NewClassName='' then
|
|
raise Exception.Create('CreateNewClass NewClassName empty');
|
|
if not IsValidIdent(NewClassName) then
|
|
raise Exception.Create('CreateNewClass NewClassName is not a valid identifier');
|
|
if NewUnitName='' then
|
|
raise Exception.Create('CreateNewClass NewUnitName empty');
|
|
if not IsValidIdent(NewUnitName) then
|
|
raise Exception.Create('CreateNewClass NewUnitName is not a valid identifier');
|
|
Result:=nil;
|
|
|
|
// create vmt
|
|
vmtSize:=GetVMTSize(AncestorClass);
|
|
vmtTailSize:=vmtSize-vmtMethodStart;
|
|
GetMem(NewVMT,vmtSize);
|
|
FillChar(NewVMT^,vmtSize,0);
|
|
|
|
// set vmtInstanceSize
|
|
PPtrInt(NewVMT+vmtInstanceSize)^:=AncestorClass.InstanceSize;
|
|
PPtrInt(NewVMT+vmtInstanceSizeNeg)^:=-AncestorClass.InstanceSize;
|
|
|
|
// set vmtParent
|
|
TClass(Pointer(NewVMT+vmtParent)^):=AncestorClass;
|
|
|
|
// set vmtClassName: create pointer to classname (PShortString)
|
|
GetMem(ClassNamePShortString,SizeOf(ShortString));
|
|
System.Move(NewClassName[0],ClassNamePShortString^,SizeOf(ShortString));
|
|
Pointer(Pointer(NewVMT+vmtClassName)^):=ClassNamePShortString;// don't use
|
|
// PShortString, so that the compiler does not get silly ideas
|
|
|
|
// set vmtFieldTable
|
|
GetMem(NewFieldTable,SizeOf(TFieldTable));
|
|
FillChar(NewFieldTable^,SizeOf(TFieldTable),0);
|
|
PFieldTable(Pointer(NewVMT+vmtFieldTable)^):=NewFieldTable;
|
|
|
|
// ClassTable
|
|
GetMem(NewClassTable,SizeOf(Word));
|
|
FillChar(NewClassTable^,SizeOf(Word),0);
|
|
NewFieldTable^.ClassTable:=NewClassTable;
|
|
|
|
// set vmtTypeInfo
|
|
TypeInfoSize := CalculateTypeInfoSize(NewClassName,0);
|
|
GetMem(NewTypeInfo,TypeInfoSize);
|
|
FillChar(NewTypeInfo^,TypeInfoSize,0);
|
|
Pointer(Pointer(NewVMT+vmtTypeInfo)^):=NewTypeInfo;
|
|
|
|
// set TypeInfo Kind and Name
|
|
NewTypeInfo^.Kind:=tkClass;
|
|
System.Move(NewClassName[0],NewTypeInfo^.Name[0],length(NewClassName)+1);
|
|
NewTypeData:=GetTypeData(NewTypeInfo);
|
|
if NewTypeData<>Pointer(Pointer(@NewTypeInfo^.Name[0])+1+length(NewClassName))
|
|
then
|
|
raise Exception.Create('CreateNewClass new aligned TypeData');
|
|
|
|
// set TypeData (PropCount is the total number of properties, including ancestors)
|
|
NewTypeData^.ClassType:=TClass(NewVMT);
|
|
NewTypeData^.ParentInfo:=AncestorClass.ClassInfo;
|
|
NewTypeData^.PropCount:=GetTypeData(NewTypeData^.ParentInfo)^.PropCount;
|
|
NewTypeData^.UnitName:=NewUnitName;
|
|
AddedPropCount:=GetTypeDataPropCountAddr(NewTypeData);
|
|
AddedPropCount^:=0;
|
|
|
|
// copy the standard methods
|
|
System.Move(Pointer(Pointer(AncestorClass)+vmtMethodStart)^,
|
|
Pointer(NewVMT+vmtMethodStart)^,
|
|
vmtTailSize);
|
|
|
|
// override 'ValidateRename' for TComponent descendants
|
|
if AncestorClass.InheritsFrom(TComponent) then begin
|
|
Pointer(Pointer(NewVMT+TComponentValidateRenameOffset)^):=
|
|
@TComponentWithOverrideValidateRename.ValidateRename;
|
|
end;
|
|
|
|
Result:=TClass(NewVMT);
|
|
end;
|
|
|
|
procedure TJITComponentList.FreeJITClass(var AClass: TClass);
|
|
|
|
procedure FreeMethodTableEntries(MethodTable: PMethodNameTable);
|
|
var
|
|
CurCount, i: integer;
|
|
CurMethod: TMethodNameRec;
|
|
begin
|
|
if MethodTable=nil then exit;
|
|
CurCount:=MethodTable^.Count;
|
|
i:=CurCount;
|
|
while i>0 do begin
|
|
CurMethod:=MethodTable^.Entries[i-1];
|
|
if CurMethod.Name<>nil then
|
|
FreeMem(CurMethod.Name);
|
|
if CurMethod.Addr<>nil then
|
|
FreeMem(CurMethod.Addr);
|
|
dec(i);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
OldVMT: Pointer;
|
|
ClassNamePShortString: Pointer;
|
|
OldFieldTable: PFieldTable;
|
|
OldTypeInfo: PTypeInfo;
|
|
OldMethodTable: PMethodNameTable;
|
|
begin
|
|
// free TJITMethods
|
|
JITMethods.DeleteAllOfClass(AClass);
|
|
|
|
OldVMT:=Pointer(AClass);
|
|
// free methodtable
|
|
OldMethodTable:=PMethodNameTable((OldVMT+vmtMethodTable)^);
|
|
if Assigned(OldMethodTable) then begin
|
|
FreeMethodTableEntries(OldMethodTable);
|
|
FreeMem(OldMethodTable);
|
|
end;
|
|
// free classname
|
|
ClassNamePShortString:=Pointer(Pointer(OldVMT+vmtClassName)^);
|
|
FreeMem(ClassNamePShortString);
|
|
// free field table
|
|
OldFieldTable:=PFieldTable(Pointer(OldVMT+vmtFieldTable)^);
|
|
ReallocMem(OldFieldTable^.ClassTable,0);
|
|
FreeMem(OldFieldTable);
|
|
// free typeinfo
|
|
OldTypeInfo:=PTypeInfo(Pointer(OldVMT+vmtTypeInfo)^);
|
|
FreeMem(OldTypeInfo);
|
|
// free vmt
|
|
FreeMem(OldVMT);
|
|
AClass:=nil;
|
|
end;
|
|
|
|
procedure TJITComponentList.DoAddNewMethod(JITClass:TClass;
|
|
const AName:ShortString; ACode:Pointer);
|
|
var OldMethodTable, NewMethodTable: PMethodNameTable;
|
|
NewMethodTableSize:integer;
|
|
begin
|
|
//debugln('[TJITComponentList.AddNewMethod] '''+JITClass.ClassName+'.'+AName+'''');
|
|
OldMethodTable:=PMethodNameTable((Pointer(JITClass)+vmtMethodTable)^);
|
|
if Assigned(OldMethodTable) then begin
|
|
NewMethodTableSize:=SizeOf(DWord)+
|
|
(OldMethodTable^.Count + 1)*SizeOf(TMethodNameRec);
|
|
end else begin
|
|
NewMethodTableSize:=SizeOf(DWord)+SizeOf(TMethodNameRec);
|
|
end;
|
|
GetMem(NewMethodTable,NewMethodTableSize);
|
|
if Assigned(OldMethodTable) then begin
|
|
Move(OldMethodTable^,NewMethodTable^,
|
|
NewMethodTableSize-SizeOf(TMethodNameRec));
|
|
NewMethodTable^.Count:=NewMethodTable^.Count+1;
|
|
end else begin
|
|
NewMethodTable^.Count:=1;
|
|
end;
|
|
{$R-}
|
|
//for a:=0 to NewMethodTable^.Count-2 do
|
|
// debugln(a,'=',NewMethodTable^.Entries[a].Name^,' $'
|
|
// ,DbgS(PtrInt(NewMethodTable^.Entries[a].Name),8));
|
|
with NewMethodTable^.Entries[NewMethodTable^.Count-1] do begin
|
|
GetMem(Name,256);
|
|
Name^:=AName;
|
|
Addr:=ACode;
|
|
end;
|
|
//for a:=0 to NewMethodTable^.Count-1 do
|
|
// debugln(a,'=',NewMethodTable^.Entries[a].Name^,' $'
|
|
// ,DbgS(PtrInt(NewMethodTable^.Entries[a].Name),8));
|
|
{$IFDEF RangeCheckOn}{$R+}{$ENDIF}
|
|
PMethodNameTable((Pointer(JITClass)+vmtMethodTable)^):=NewMethodTable;
|
|
if Assigned(OldMethodTable) then
|
|
FreeMem(OldMethodTable);
|
|
end;
|
|
|
|
procedure TJITComponentList.DoRemoveMethod(JITClass:TClass;
|
|
AName:ShortString; var OldCode:Pointer);
|
|
// Note: does not free OldCode
|
|
var OldMethodTable, NewMethodTable: PMethodNameTable;
|
|
NewMethodTableSize:integer;
|
|
a:cardinal;
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.DoRemoveMethod] '''+JITClass.ClassName+'.'+AName+'''');
|
|
{$ENDIF}
|
|
AName:=uppercase(AName);
|
|
OldMethodTable:=PMethodNameTable((Pointer(JITClass)+vmtMethodTable)^);
|
|
OldCode:=nil;
|
|
if Assigned(OldMethodTable) then begin
|
|
a:=0;
|
|
while a<OldMethodTable^.Count do begin
|
|
{$R-}
|
|
if uppercase(OldMethodTable^.Entries[a].Name^)=AName then begin
|
|
OldCode:=OldMethodTable^.Entries[a].Addr;
|
|
FreeMem(OldMethodTable^.Entries[a].Name);
|
|
if OldMethodTable^.Count>0 then begin
|
|
NewMethodTableSize:=SizeOf(DWord)+
|
|
OldMethodTable^.Count*SizeOf(TMethodNameRec);
|
|
GetMem(NewMethodTable,NewMethodTableSize);
|
|
NewMethodTable^.Count:=OldMethodTable^.Count-1;
|
|
Move(OldMethodTable^,NewMethodTable^,
|
|
SizeOf(DWord)+a*SizeOf(TMethodNameRec));
|
|
Move(OldMethodTable^.Entries[a],NewMethodTable^.Entries[a+1],
|
|
SizeOf(DWord)+a*SizeOf(TMethodNameRec));
|
|
end else begin
|
|
NewMethodTable:=nil;
|
|
end;
|
|
PMethodNameTable((Pointer(JITClass)+vmtMethodTable)^):=NewMethodTable;
|
|
FreeMem(OldMethodTable);
|
|
break;
|
|
end;
|
|
{$IFDEF RangeCheckOn}{$R+}{$ENDIF}
|
|
inc(a);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TJITComponentList.DoRenameMethod(JITClass:TClass;
|
|
OldName,NewName:ShortString);
|
|
var MethodTable: PMethodNameTable;
|
|
a:integer;
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.DoRenameMethod] ClassName='''+JITClass.ClassName+''''
|
|
+' OldName='''+OldName+''' NewName='''+OldName+'''');
|
|
{$ENDIF}
|
|
OldName:=uppercase(OldName);
|
|
MethodTable:=PMethodNameTable((Pointer(JITClass)+vmtMethodTable)^);
|
|
if Assigned(MethodTable) then begin
|
|
for a:=0 to MethodTable^.Count-1 do begin
|
|
if uppercase(MethodTable^.Entries[a].Name^)=OldName then
|
|
MethodTable^.Entries[a].Name^:=NewName;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TJITComponentList.DoRenameClass(JITClass:TClass;
|
|
const NewName:ShortString);
|
|
begin
|
|
{$IFDEF VerboseJITForms}
|
|
debugln('[TJITComponentList.DoRenameClass] OldName='''+JITClass.ClassName
|
|
+''' NewName='''+NewName+''' ');
|
|
{$ENDIF}
|
|
PShortString((Pointer(JITClass)+vmtClassName)^)^:=NewName;
|
|
end;
|
|
|
|
procedure TJITComponentList.DoRenameUnitNameOfClass(JITClass: TClass;
|
|
const NewUnitName: ShortString);
|
|
var
|
|
TypeInfo: PTypeInfo;
|
|
TypeData: PTypeData;
|
|
OldPropCount: Word;
|
|
begin
|
|
TypeInfo:=PTypeInfo(JITClass.ClassInfo);
|
|
if TypeInfo=nil then
|
|
RaiseException('TJITComponentList.DoRenameUnitNameOfClass');
|
|
TypeData:=GetTypeData(TypeInfo);
|
|
//DebugLn(['TJITComponentList.DoRenameUnitNameOfClass Old=',TypeData^.UnitName,' New=',NewUnitName]);
|
|
OldPropCount:=GetTypeDataPropCountAddr(TypeData)^;
|
|
if OldPropCount<>0 then
|
|
RaiseGDBException('TJITComponentList.DoRenameUnitNameOfClass TODO: move properties and realloc mem');
|
|
TypeData^.UnitName:=NewUnitName;
|
|
GetTypeDataPropCountAddr(TypeData)^:=OldPropCount;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
|
|
{
|
|
TReader events.
|
|
Normally at runtime a LFM is streamed back into the corresponding TForm
|
|
descendent, all methods and components are published members and TReader can
|
|
set these values.
|
|
But at design time we do not have the corresponding TForm descendent. And
|
|
there is no compiled code, thus it must be produced (just-in-time),
|
|
if fake methods are not used .
|
|
}
|
|
procedure TJITComponentList.ReaderFindMethod(Reader: TReader;
|
|
const FindMethodName: Ansistring; var Address: Pointer; var Error: Boolean);
|
|
{$IFDEF DisableFakeMethods}
|
|
var NewMethod: TMethod;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF IDE_DEBUG}
|
|
debugln('[TJITComponentList.ReaderFindMethod] A "'+FindMethodName+'" Address=',DbgS(Address));
|
|
{$ENDIF}
|
|
{$IFNDEF DisableFakeMethods}
|
|
RaiseGDBException('TJITComponentList.ReaderFindMethod this event should never be called -> this is a bug in TReader, or misuse of TReader.OnFindMethod');
|
|
{$ELSE}
|
|
if Address=nil then begin
|
|
// there is no method in the ancestor class with this name
|
|
// => add a JIT method with this name to the JITForm
|
|
NewMethod:=CreateNewMethod(FCurReadJITComponent,FindMethodName);
|
|
Address:=NewMethod.Code;
|
|
Error:=false;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderPropertyNotFound(Reader: TReader;
|
|
Instance: TPersistent; var PropName: string; IsPath: Boolean;
|
|
var Handled, Skip: Boolean);
|
|
begin
|
|
DebugLn('TJITComponentList.ReaderPropertyNotFound ',Instance.ClassName,'.',PropName);
|
|
if Assigned(OnPropertyNotFound) then
|
|
OnPropertyNotFound(Self,Reader,Instance,PropName,IsPath,Handled,Skip);
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderSetMethodProperty(Reader: TReader;
|
|
Instance: TPersistent; PropInfo: PPropInfo; const TheMethodName: string;
|
|
var Handled: boolean);
|
|
{$IFNDEF DisableFakeMethods}
|
|
var
|
|
Method: TMethod;
|
|
JITMethod: TJITMethod;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFNDEF DisableFakeMethods}
|
|
//debugln('TJITComponentList.ReaderSetMethodProperty ',DbgSName(Instance),' ',PropInfo^.Name,':=',TheMethodName);
|
|
Method.Code:=FCurReadJITComponent.MethodAddress(TheMethodName);
|
|
if Method.Code<>nil then begin
|
|
// there is a real method with this name
|
|
Method.Data := FCurReadJITComponent;
|
|
end else begin
|
|
// create a fake TJITMethod
|
|
JITMethod:=JITMethods.Add(Reader.LookupRoot.ClassType,TheMethodName);
|
|
Method:=JITMethod.Method;
|
|
end;
|
|
SetMethodProp(Instance, PropInfo, Method);
|
|
|
|
Handled:=true;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderSetName(Reader: TReader;
|
|
Component: TComponent; var NewName: Ansistring);
|
|
begin
|
|
// debugln('[TJITComponentList.ReaderSetName] OldName="'+Component.Name+'" NewName="'+NewName+'"');
|
|
if jclAutoRenameComponents in FFlags then begin
|
|
while FCurReadJITComponent.FindComponent(NewName)<>nil do
|
|
NewName:=CreateNextIdentifier(NewName);
|
|
end;
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderReferenceName(Reader: TReader;
|
|
var RefName: Ansistring);
|
|
begin
|
|
// debugln('[TJITComponentList.ReaderReferenceName] Name='''+RefName+'''');
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderAncestorNotFound(Reader: TReader;
|
|
const ComponentName: Ansistring; ComponentClass: TPersistentClass;
|
|
var Component: TComponent);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
// ToDo: this is for custom form templates
|
|
debugln('[TJITComponentList.ReaderAncestorNotFound] ComponentName="'+ComponentName
|
|
+'" Component="'+dbgsName(Component)+'" ComponentClass="',dbgsName(ComponentClass)+'"');
|
|
DebugLn(['TJITComponentList.ReaderAncestorNotFound FCurReadJITComponent=',dbgsName(FCurReadJITComponent)]);
|
|
for i:=0 to FCurReadJITComponent.ComponentCount-1 do
|
|
DebugLn(['TJITComponentList.ReaderAncestorNotFound ',i,' ',dbgsName(FCurReadJITComponent.Components[i])]);
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderError(Reader: TReader;
|
|
const ErrorMsg: Ansistring; var Handled: Boolean);
|
|
// ToDo: use SUnknownProperty when it is published by the fpc team
|
|
const
|
|
SUnknownProperty = 'Unknown property';
|
|
var
|
|
ErrorType: TJITFormError;
|
|
Action: TModalResult;
|
|
ErrorBinPos: Int64;
|
|
begin
|
|
ErrorType:=jfeReaderError;
|
|
Action:=mrCancel;
|
|
FCurReadErrorMsg:=ErrorMsg;
|
|
FCurUnknownProperty:=''; // ToDo find name property
|
|
// find out, what error occured
|
|
if RightStr(ErrorMsg,length(SUnknownProperty))=SUnknownProperty then begin
|
|
ErrorType:=jfeUnknownProperty;
|
|
Action:=mrIgnore;
|
|
end;
|
|
if Reader.Driver is TLRSObjectReader then begin
|
|
// save error position
|
|
ErrorBinPos:=TLRSObjectReader(Reader.Driver).Stream.Position;
|
|
FErrors.Add(-1,ErrorBinPos,nil);
|
|
end;
|
|
if Assigned(OnReaderError) then
|
|
OnReaderError(Self,Reader,ErrorType,Action);
|
|
Handled:=Action in [mrIgnore];
|
|
FCurUnknownProperty:='';
|
|
|
|
DebugLn('>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>');
|
|
DebugLn(['[TJITComponentList.ReaderError] "'+ErrorMsg+'" ignoring=',Handled]);
|
|
DebugLn('<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<');
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderFindComponentClass(Reader: TReader;
|
|
const FindClassName: Ansistring; var ComponentClass: TComponentClass);
|
|
begin
|
|
fCurReadChild:=nil;
|
|
fCurReadChildClass:=ComponentClass;
|
|
FCurUnknownClass:=FindClassName;
|
|
if ComponentClass=nil then begin
|
|
if Assigned(OnFindClass) then
|
|
OnFindClass(Self,FindClassName,ComponentClass);
|
|
fCurReadChildClass:=ComponentClass;
|
|
if ComponentClass=nil then begin
|
|
DebugLn('[TJITComponentList.ReaderFindComponentClass] '''+FindClassName
|
|
+''' is unregistered');
|
|
// The reader will create a ReaderError automatically
|
|
end;
|
|
end;
|
|
FCurUnknownClass:='';
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderCreateComponent(Reader: TReader;
|
|
ComponentClass: TComponentClass; var Component: TComponent);
|
|
begin
|
|
fCurReadChild:=Component;
|
|
fCurReadChildClass:=ComponentClass;
|
|
|
|
{$IFDEF EnableTFrame}
|
|
ReadInlineComponent(Component,ComponentClass,Reader.Owner);
|
|
{$ENDIF}
|
|
//debugln(['[TJITComponentList.ReaderCreateComponent] Class=',ComponentClass.ClassName,' Component=',dbgsName(Component)]);
|
|
end;
|
|
|
|
procedure TJITComponentList.ReaderReadComponent(Component: TComponent);
|
|
begin
|
|
fCurReadChild:=Component;
|
|
fCurReadChildClass:=TComponentClass(Component.ClassType);
|
|
DebugLn('TJITComponentList.ReaderReadComponent A ',Component.Name,':',Component.ClassName);
|
|
end;
|
|
|
|
//==============================================================================
|
|
|
|
|
|
{ TJITForms }
|
|
|
|
function TJITForms.IsJITForm(AComponent: TComponent): boolean;
|
|
begin
|
|
Result:=(AComponent<>nil) and (AComponent is TForm)
|
|
and (TForm(AComponent).Parent=nil) and (IndexOf(AComponent)>=0);
|
|
end;
|
|
|
|
function TJITForms.GetItem(Index: integer): TForm;
|
|
begin
|
|
Result:=TForm(inherited Items[Index]);
|
|
end;
|
|
|
|
{ TJITNonFormComponents }
|
|
|
|
function TJITNonFormComponents.IsJITNonForm(AComponent: TComponent): boolean;
|
|
begin
|
|
Result:=(AComponent<>nil) and (not (AComponent is TForm))
|
|
and (IndexOf(AComponent)>=0);
|
|
end;
|
|
|
|
{ TJITMethod }
|
|
|
|
constructor TJITMethod.Create(AnOwner: TJITMethods;
|
|
aClass: TClass; const aMethodName: shortstring);
|
|
begin
|
|
FMethod.Data:=Self;
|
|
FMethod.Code:=nil;
|
|
fTheClass:=AClass;
|
|
fTheMethodName:=aMethodName;
|
|
FOwner:=AnOwner;
|
|
Owner.InternalAdd(Self);
|
|
end;
|
|
|
|
destructor TJITMethod.Destroy;
|
|
begin
|
|
if Owner<>nil then
|
|
Owner.InternalRemove(Self);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TJITMethods }
|
|
|
|
procedure TJITMethods.InternalAdd(const AMethod: TJITMethod);
|
|
begin
|
|
fMethods.Add(AMethod);
|
|
AMethod.fOwner:=Self;
|
|
end;
|
|
|
|
procedure TJITMethods.InternalRemove(const AMethod: TJITMethod);
|
|
begin
|
|
AMethod.fOwner:=nil;
|
|
if not fClearing then
|
|
fMethods.Remove(AMethod);
|
|
end;
|
|
|
|
constructor TJITMethods.Create;
|
|
begin
|
|
fMethods:=TAvgLvlTree.Create(@CompareJITMethod);
|
|
end;
|
|
|
|
destructor TJITMethods.Destroy;
|
|
begin
|
|
Clear;
|
|
FreeAndNil(fMethods);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TJITMethods.Clear;
|
|
begin
|
|
fClearing:=true;
|
|
fMethods.FreeAndClear;
|
|
fClearing:=false;
|
|
end;
|
|
|
|
function TJITMethods.Add(aClass: TClass;
|
|
const aMethodName: shortstring): TJITMethod;
|
|
begin
|
|
Result:=Find(aClass,aMethodName);
|
|
if Result=nil then begin
|
|
//DebugLn(['TJITMethods.Add Create Class=',dbgsname(aClass),' aMethodName=',aMethodName]);
|
|
Result:=TJITMethod.Create(Self,aClass,aMethodName);
|
|
end;
|
|
end;
|
|
|
|
function TJITMethods.Find(aClass: TClass;
|
|
const aMethodName: shortstring): TJITMethod;
|
|
var
|
|
CurMethod: TJITMethod;
|
|
Node: TAvgLvlTreeNode;
|
|
Comp: LongInt;
|
|
begin
|
|
//DebugLn(['TJITMethods.Find Class=',dbgsname(aClass),' aMethodName=',aMethodName]);
|
|
Node:=fMethods.Root;
|
|
while (Node<>nil) do begin
|
|
CurMethod:=TJITMethod(Node.Data);
|
|
Comp:=ComparePointers(aClass,CurMethod.TheClass);
|
|
if Comp=0 then
|
|
Comp:=CompareText(aMethodName,CurMethod.TheMethodName);
|
|
if Comp=0 then
|
|
exit(CurMethod);
|
|
if Comp<0 then begin
|
|
Node:=Node.Left
|
|
end else begin
|
|
Node:=Node.Right
|
|
end;
|
|
end;
|
|
Result:=nil;
|
|
end;
|
|
|
|
function TJITMethods.Delete(aMethod: TJITMethod): boolean;
|
|
begin
|
|
//DebugLn(['TJITMethods.Delete Class=',dbgsname(AMethod.TheClass),' aMethodName=',aMethod.TheMethodName]);
|
|
if (aMethod=nil) then
|
|
Result:=false
|
|
else if aMethod.Owner<>Self then
|
|
RaiseGDBException('TJITMethods.DeleteJITMethod')
|
|
else begin
|
|
Result:=true;
|
|
InternalRemove(aMethod);
|
|
aMethod.Free;
|
|
end;
|
|
end;
|
|
|
|
function TJITMethods.Delete(aClass: TClass;
|
|
const aMethodName: shortstring): boolean;
|
|
var
|
|
CurMethod: TJITMethod;
|
|
begin
|
|
CurMethod:=Find(aClass,aMethodName);
|
|
if CurMethod=nil then begin
|
|
Result:=false;
|
|
end else begin
|
|
Result:=true;
|
|
InternalRemove(CurMethod);
|
|
CurMethod.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TJITMethods.DeleteAllOfClass(aClass: TClass);
|
|
var
|
|
CurMethod: TJITMethod;
|
|
Node: TAvgLvlTreeNode;
|
|
Comp: LongInt;
|
|
NextNode: TAvgLvlTreeNode;
|
|
begin
|
|
Node:=fMethods.Root;
|
|
while (Node<>nil) do begin
|
|
CurMethod:=TJITMethod(Node.Data);
|
|
Comp:=ComparePointers(aClass,CurMethod.TheClass);
|
|
if Comp<0 then begin
|
|
Node:=Node.Left
|
|
end else if Comp>0 then begin
|
|
Node:=Node.Right
|
|
end else begin
|
|
// one node found
|
|
|
|
// search lowest
|
|
repeat
|
|
NextNode:=fMethods.FindPrecessor(Node);
|
|
if (NextNode=nil)
|
|
or (ComparePointers(aClass,TJITMethod(NextNode.Data).TheClass)<>0)
|
|
then
|
|
break;
|
|
Node:=NextNode;
|
|
until false;
|
|
|
|
// delete all nodes of this class
|
|
repeat
|
|
NextNode:=fMethods.FindSuccessor(Node);
|
|
CurMethod:=TJITMethod(Node.Data);
|
|
CurMethod.FOwner:=nil;
|
|
fMethods.Delete(Node);
|
|
CurMethod.Free;
|
|
Node:=NextNode;
|
|
until (Node=nil)
|
|
or (ComparePointers(aClass,TJITMethod(Node.Data).TheClass)<>0);
|
|
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TJITMethods.Rename(aClass: TClass; const OldMethodName,
|
|
NewMethodName: shortstring): boolean;
|
|
var
|
|
CurMethod: TJITMethod;
|
|
begin
|
|
CurMethod:=Find(aClass,OldMethodName);
|
|
if CurMethod=nil then begin
|
|
Result:=false;
|
|
end else begin
|
|
Result:=true;
|
|
//DebugLn(['TJITMethods.Rename Class=',DbgSName(aClass),' Old=',CurMethod.TheMethodName,' New=',NewMethodName]);
|
|
fMethods.Remove(CurMethod);
|
|
CurMethod.fTheMethodName:=NewMethodName;
|
|
fMethods.Add(CurMethod);
|
|
end;
|
|
end;
|
|
|
|
Initialization
|
|
TComponentValidateRenameOffset:=GetTComponentValidateRenameVMTOffset;
|
|
JITMethods:=TJITMethods.Create;
|
|
|
|
finalization
|
|
FreeAndNil(JITMethods);
|
|
|
|
end.
|
|
|