mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-28 13:42:41 +02:00
779 lines
26 KiB
ObjectPascal
779 lines
26 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.
|
|
Subcomponents are looked up in the list of registered components
|
|
(TJITForms.RegCompList).
|
|
|
|
ToDo:
|
|
-Add recursion needed for frames.
|
|
}
|
|
unit JITForms;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
{$I ide.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF IDE_MEM_CHECK}
|
|
MemCheck,
|
|
{$ENDIF}
|
|
Classes, SysUtils, CompReg, Forms, Controls, LCLLinux, Dialogs, JITForm;
|
|
|
|
type
|
|
//----------------------------------------------------------------------------
|
|
TJITFormError = (
|
|
jfeNone,
|
|
jfeUnknown,
|
|
jfeUnknownProperty,
|
|
jfeUnknownComponentClass,
|
|
jfeReaderError
|
|
);
|
|
TJITFormErrors = set of TJITFormError;
|
|
|
|
TJITReaderErrorEvent = procedure(Sender: TObject; ErrorType: TJITFormError;
|
|
var Action: TModalResult) of object;
|
|
|
|
|
|
// Just-In-Time-Form List
|
|
TJITForms = class(TPersistentWithTemplates)
|
|
private
|
|
FCurReadErrorMsg: string;
|
|
FCurReadForm:TForm;
|
|
FCurReadClass:TClass;
|
|
FCurReadComponent: TComponent;
|
|
FCurReadComponentClass: TComponentClass;
|
|
FForms: TList; // list of TJITForm
|
|
FOnReaderError: TJITReaderErrorEvent;
|
|
FRegCompList:TRegisteredComponentList;
|
|
// jit procedures
|
|
function CreateVMTCopy(SourceClass:TClass; const NewClassName:ShortString):Pointer;
|
|
procedure FreevmtCopy(vmtCopy:Pointer);
|
|
procedure DoAddNewMethod(JITClass:TClass; AName:ShortString; ACode:Pointer);
|
|
// AddNewMethod does not check if method already exists
|
|
procedure DoRemoveMethod(JITClass:TClass; AName:ShortString; var OldCode:Pointer);
|
|
// RemoveMethod does not free code memory
|
|
procedure DoRenameMethod(JITClass:TClass; OldName,NewName:ShortString);
|
|
procedure DoRenameClass(JITClass:TClass; NewName:ShortString);
|
|
// TReader events
|
|
procedure ReaderFindMethod(Reader: TReader; const FindMethodName: Ansistring;
|
|
var Address: Pointer; var Error: 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);
|
|
// some useful functions
|
|
function GetItem(Index:integer):TForm;
|
|
function GetClassNameFromStream(s:TStream):shortstring;
|
|
function DoCreateJITForm(NewFormName,NewClassName:shortstring):integer;
|
|
function OnFindGlobalComponent(const AName:AnsiString):TComponent;
|
|
procedure InitReading;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
property Items[Index:integer]:TForm read GetItem; default;
|
|
function Count:integer;
|
|
property RegCompList:TRegisteredComponentList read FRegCompList write FRegCompList;
|
|
function AddNewJITForm:integer;
|
|
function AddJITFormFromStream(BinStream:TStream):integer;
|
|
procedure DestroyJITForm(JITForm:TForm);
|
|
procedure DestroyJITForm(Index:integer);
|
|
function IndexOf(JITForm:TForm):integer;
|
|
function FindFormByClassName(AClassName:shortstring):integer;
|
|
function FindFormByName(AName:shortstring):integer;
|
|
procedure GetUnusedNames(var FormName,FormClassName:shortstring);
|
|
procedure AddNewMethod(JITForm:TForm; AName:ShortString);
|
|
function CreateNewMethod(JITForm:TForm; AName:ShortString): TMethod;
|
|
procedure RemoveMethod(JITForm:TForm; AName:ShortString);
|
|
procedure RenameMethod(JITForm:TForm; OldName,NewName:ShortString);
|
|
procedure RenameFormClass(JITForm:TForm; NewName:ShortString);
|
|
property OnReaderError: TJITReaderErrorEvent
|
|
read FOnReaderError write FOnReaderError;
|
|
property CurReadForm:TForm read FCurReadForm;
|
|
property CurReadClass:TClass read FCurReadClass;
|
|
property CurReadComponent: TComponent read FCurReadComponent;
|
|
property CurReadComponentClass: TComponentClass read FCurReadComponentClass;
|
|
property CurReadErrorMsg: string read FCurReadErrorMsg;
|
|
end;
|
|
|
|
implementation
|
|
|
|
var
|
|
MyFindGlobalComponentProc:function(const AName:AnsiString):TComponent of object;
|
|
|
|
function MyFindGlobalComponent(const AName:AnsiString):TComponent;
|
|
begin
|
|
Result:=MyFindGlobalComponentProc(AName);
|
|
end;
|
|
|
|
//----------------------------------------------------------------------------
|
|
|
|
|
|
{ TJITForms }
|
|
|
|
constructor TJITForms.Create;
|
|
begin
|
|
inherited Create;
|
|
FForms:=TList.Create;
|
|
end;
|
|
|
|
destructor TJITForms.Destroy;
|
|
begin
|
|
while FForms.Count>0 do DestroyJITForm(FForms.Count-1);
|
|
FForms.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TJITForms.GetItem(Index:integer):TForm;
|
|
begin
|
|
Result:=TForm(FForms[Index]);
|
|
end;
|
|
|
|
function TJITForms.Count:integer;
|
|
begin
|
|
Result:=FForms.Count;
|
|
end;
|
|
|
|
function TJITForms.IndexOf(JITForm:TForm):integer;
|
|
begin
|
|
Result:=Count-1;
|
|
while (Result>=0) and (Items[Result]<>JITForm) do dec(Result);
|
|
end;
|
|
|
|
procedure TJITForms.DestroyJITForm(JITForm:TForm);
|
|
var a:integer;
|
|
begin
|
|
if JITForm=nil then
|
|
raise Exception.Create('TJITForms.DestroyJITForm JITForm=nil');
|
|
a:=IndexOf(JITForm);
|
|
if a<0 then
|
|
raise Exception.Create('TJITForms.DestroyJITForm JITForm.ClassName='+
|
|
JITForm.ClassName);
|
|
if a>=0 then DestroyJITForm(a);
|
|
end;
|
|
|
|
procedure TJITForms.DestroyJITForm(Index:integer);
|
|
var OldClass:TClass;
|
|
begin
|
|
OldClass:=Items[Index].ClassType;
|
|
Items[Index].Free;
|
|
FreevmtCopy(OldClass);
|
|
FForms.Delete(Index);
|
|
end;
|
|
|
|
function TJITForms.FindFormByClassName(AClassName:shortstring):integer;
|
|
begin
|
|
AClassName:=uppercase(AClassName);
|
|
Result:=FForms.Count-1;
|
|
while (Result>=0) and (uppercase(Items[Result].ClassName)<>AClassName) do
|
|
dec(Result);
|
|
end;
|
|
|
|
function TJITForms.FindFormByName(AName:shortstring):integer;
|
|
begin
|
|
AName:=uppercase(AName);
|
|
Result:=FForms.Count-1;
|
|
while (Result>=0) and (uppercase(Items[Result].Name)<>AName) do
|
|
dec(Result);
|
|
end;
|
|
|
|
procedure TJITForms.GetUnusedNames(var FormName,FormClassName:shortstring);
|
|
var a:integer;
|
|
begin
|
|
a:=1;
|
|
repeat
|
|
FormName:='Form'+IntToStr(a);
|
|
FormClassName:='TForm'+IntToStr(a);
|
|
inc(a);
|
|
until (FindFormByName(FormName)<0) and (FindFormByClassName(FormClassName)<0);
|
|
end;
|
|
|
|
function TJITForms.DoCreateJITForm(
|
|
NewFormName,NewClassName:shortstring):integer;
|
|
var
|
|
Instance:TComponent;
|
|
begin
|
|
Result:=-1;
|
|
// create new class and an instance
|
|
//writeln('[TJITForms.DoCreateJITForm] Creating new JIT class '''+NewClassName+''' ...');
|
|
Pointer(FCurReadClass):=CreateVMTCopy(TJITForm,'TJITForm');
|
|
//writeln('[TJITForms.DoCreateJITForm] Creating an instance of JIT class '''+NewClassName+''' ...');
|
|
Instance:=TComponent(FCurReadClass.NewInstance);
|
|
//writeln('[TJITForms.DoCreateJITForm] Initializing new instance ...');
|
|
TComponent(FCurReadForm):=Instance;
|
|
try
|
|
Instance.Create(nil);
|
|
if NewFormName<>'' then
|
|
Instance.Name:=NewFormName;
|
|
DoRenameClass(FCurReadClass,NewClassName);
|
|
//writeln('[TJITForms.DoCreateJITForm] Initialization was successful! FormName="',NewFormName,'"');
|
|
except
|
|
TComponent(FCurReadForm):=nil;
|
|
writeln('[TJITForms.DoCreateJITForm] Error while creating instance');
|
|
raise;
|
|
end;
|
|
Result:=FForms.Add(FCurReadForm);
|
|
end;
|
|
|
|
function TJITForms.AddNewJITForm:integer;
|
|
var NewFormName,NewClassName:shortstring;
|
|
begin
|
|
{$IFDEF IDE_VERBOSE}
|
|
Writeln('[TJITForms] AddNewJITForm');
|
|
{$ENDIF}
|
|
GetUnusedNames(NewFormName,NewClassName);
|
|
{$IFDEF IDE_VERBOSE}
|
|
Writeln('NewFormName is ',NewFormname,', NewClassName is ',NewClassName);
|
|
{$ENDIF}
|
|
Result:=DoCreateJITForm(NewFormName,NewClassName);
|
|
end;
|
|
|
|
function TJITForms.GetClassNameFromStream(s:TStream):shortstring;
|
|
var Signature:shortstring;
|
|
NameLen:byte;
|
|
begin
|
|
Result:='';
|
|
// read signature
|
|
Signature:='1234';
|
|
s.Read(Signature[1],length(Signature));
|
|
if Signature<>'TPF0' then exit;
|
|
// read classname length
|
|
NameLen:=0;
|
|
s.Read(NameLen,1);
|
|
// read classname
|
|
if NameLen>0 then begin
|
|
SetLength(Result,NameLen);
|
|
s.Read(Result[1],NameLen);
|
|
end;
|
|
s.Position:=0;
|
|
end;
|
|
|
|
function TJITForms.AddJITFormFromStream(BinStream:TStream):integer;
|
|
// returns new index
|
|
// -1 = invalid stream
|
|
|
|
procedure ApplyVisible;
|
|
var
|
|
i: integer;
|
|
AControl: TControl;
|
|
begin
|
|
// The LCL has as default Visible=false. But for Delphi compatbility
|
|
// loading control defaults to true.
|
|
for i:=0 to FCurReadForm.ComponentCount-1 do begin
|
|
AControl:=TControl(FCurReadForm.Components[i]);
|
|
if (AControl is TControl) then begin
|
|
if (not (csVisibleSetInLoading in AControl.ControlState)) then
|
|
AControl.Visible:=true
|
|
else
|
|
AControl.ControlState:=
|
|
AControl.ControlState-[csVisibleSetInLoading];
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
Reader:TReader;
|
|
NewClassName:shortstring;
|
|
NewName: string;
|
|
begin
|
|
Result:=-1;
|
|
NewClassName:=GetClassNameFromStream(BinStream);
|
|
if NewClassName='' then begin
|
|
|
|
// Application.MessageBox('No classname in form stream found.','',mb_OK);
|
|
MessageDlg('No classname in form stream found.',mterror,[mbOK],0);
|
|
|
|
exit;
|
|
end;
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.AddJITFormFromStream] 1');
|
|
{$ENDIF}
|
|
try
|
|
Result:=DoCreateJITForm('',NewClassName);
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.AddJITFormFromStream] 2');
|
|
{$ENDIF}
|
|
|
|
Reader:=TReader.Create(BinStream,4096);
|
|
MyFindGlobalComponentProc:=@OnFindGlobalComponent;
|
|
FindGlobalComponent:=@MyFindGlobalComponent;
|
|
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.AddJITFormFromStream] 3');
|
|
{$ENDIF}
|
|
try
|
|
// connect TReader events
|
|
Reader.OnError:=@ReaderError;
|
|
Reader.OnFindMethod:=@ReaderFindMethod;
|
|
Reader.OnSetName:=@ReaderSetName;
|
|
Reader.OnReferenceName:=@ReaderReferenceName;
|
|
Reader.OnAncestorNotFound:=@ReaderAncestorNotFound;
|
|
Reader.OnCreateComponent:=@ReaderCreateComponent;
|
|
Reader.OnFindComponentClass:=@ReaderFindComponentClass;
|
|
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.AddJITFormFromStream] 4');
|
|
{$ENDIF}
|
|
InitReading;
|
|
|
|
Reader.ReadRootComponent(FCurReadForm);
|
|
if FCurReadForm.Name='' then begin
|
|
NewName:=FCurReadForm.ClassName;
|
|
if NewName[1] in ['T','t'] then
|
|
System.Delete(NewName,1,1);
|
|
FCurReadForm.Name:=NewName;
|
|
end;
|
|
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.AddJITFormFromStream] 5');
|
|
{$ENDIF}
|
|
ApplyVisible;
|
|
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.AddJITFormFromStream] 6');
|
|
{$ENDIF}
|
|
FCurReadForm.Show;
|
|
finally
|
|
FindGlobalComponent:=nil;
|
|
Reader.Free;
|
|
end;
|
|
except
|
|
writeln('[TJITForms.AddJITFormFromStream] ERROR reading form stream'
|
|
+' of Class ''',NewClassName,'''');
|
|
Result:=-1;
|
|
end;
|
|
end;
|
|
|
|
function TJITForms.OnFindGlobalComponent(const AName:AnsiString):TComponent;
|
|
begin
|
|
Result:=Application.FindComponent(AName);
|
|
end;
|
|
|
|
procedure TJITForms.InitReading;
|
|
begin
|
|
FCurReadComponentClass:=nil;
|
|
FCurReadComponent:=nil;
|
|
FCurReadErrorMsg:='';
|
|
end;
|
|
|
|
procedure TJITForms.AddNewMethod(JITForm:TForm; AName:ShortString);
|
|
begin
|
|
CreateNewmethod(JITForm,AName);
|
|
end;
|
|
|
|
procedure TJITForms.RemoveMethod(JITForm:TForm; AName:ShortString);
|
|
var OldCode:Pointer;
|
|
begin
|
|
if JITForm=nil then
|
|
raise Exception.Create('TJITForms.RemoveMethod JITForm=nil');
|
|
if IndexOf(JITForm)<0 then
|
|
raise Exception.Create('TJITForms.RemoveMethod JITForm.ClassName='+
|
|
JITForm.ClassName);
|
|
if (AName='') or (not IsValidIdent(AName)) then
|
|
raise Exception.Create('TJITForms.RemoveMethod invalid name: "'+AName+'"');
|
|
OldCode:=nil;
|
|
DoRemoveMethod(JITForm.ClassType,AName,OldCode);
|
|
FreeMem(OldCode);
|
|
end;
|
|
|
|
procedure TJITForms.RenameMethod(JITForm:TForm; OldName,NewName:ShortString);
|
|
begin
|
|
if JITForm=nil then
|
|
raise Exception.Create('TJITForms.RenameMethod JITForm=nil');
|
|
if IndexOf(JITForm)<0 then
|
|
raise Exception.Create('TJITForms.RenameMethod JITForm.ClassName='+
|
|
JITForm.ClassName);
|
|
if (NewName='') or (not IsValidIdent(NewName)) then
|
|
raise Exception.Create('TJITForms.RenameMethod invalid name: "'+NewName+'"');
|
|
DoRenameMethod(JITForm.ClassType,OldName,NewName);
|
|
end;
|
|
|
|
procedure TJITForms.RenameFormClass(JITForm:TForm; NewName:ShortString);
|
|
begin
|
|
if JITForm=nil then
|
|
raise Exception.Create('TJITForms.RenameFormClass JITForm=nil');
|
|
if IndexOf(JITForm)<0 then
|
|
raise Exception.Create('TJITForms.RenameFormClass JITForm.ClassName='+
|
|
JITForm.ClassName);
|
|
if (NewName='') or (not IsValidIdent(NewName)) then
|
|
raise Exception.Create('TJITForms.RenameFormClass invalid name: "'+NewName+'"');
|
|
DoRenameClass(JITForm.ClassType,NewName);
|
|
end;
|
|
|
|
function TJITForms.CreateNewMethod(JITForm: TForm; AName: ShortString): TMethod;
|
|
var CodeTemplate,NewCode:Pointer;
|
|
CodeSize:integer;
|
|
OldCode: Pointer;
|
|
begin
|
|
if JITForm=nil then
|
|
raise Exception.Create('TJITForms.CreateNewMethod JITForm=nil');
|
|
if IndexOf(JITForm)<0 then
|
|
raise Exception.Create('TJITForms.CreateNewMethod JITForm.ClassName='+
|
|
JITForm.ClassName);
|
|
if (AName='') or (not IsValidIdent(AName)) then
|
|
raise Exception.Create('TJITForms.CreateNewMethod invalid name: "'+AName+'"');
|
|
OldCode:=JITForm.MethodAddress(AName);
|
|
if OldCode<>nil then begin
|
|
Result.Data:=JITForm;
|
|
Result.Code:=OldCode;
|
|
exit;
|
|
end;
|
|
CodeTemplate:=MethodAddress('DoNothing');
|
|
CodeSize:=100; // !!! what is the real codesize of DoNothing? !!!
|
|
GetMem(NewCode,CodeSize);
|
|
Move(CodeTemplate^,NewCode^,CodeSize);
|
|
DoAddNewMethod(JITForm.ClassType,AName,NewCode);
|
|
Result.Data:=JITForm;
|
|
Result.Code:=NewCode;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
// adding, removing and renaming of classes and methods at runtime
|
|
|
|
type
|
|
// these definitions are copied from objpas.inc
|
|
|
|
TMethodNameRec = packed record
|
|
Name : PShortString;
|
|
Addr : Pointer;
|
|
end;
|
|
|
|
TMethodNameTable = packed record
|
|
Count : DWord;
|
|
Entries : packed array[0..0] of TMethodNameRec;
|
|
end;
|
|
|
|
PMethodNameTable = ^TMethodNameTable;
|
|
|
|
|
|
function TJITForms.CreateVMTCopy(SourceClass:TClass;
|
|
const NewClassName:ShortString):Pointer;
|
|
const
|
|
vmtSize:integer=2000; //XXX how big is the vmt of class TJITForm ?
|
|
var MethodTable, NewMethodTable : PMethodNameTable;
|
|
MethodTableSize: integer;
|
|
ClassNamePtr, ClassNamePShortString: Pointer;
|
|
begin
|
|
//writeln('[TJITForms.CreatevmtCopy] SourceClass='''+SourceClass.ClassName+''''
|
|
// +' NewClassName='''+NewClassName+'''');
|
|
// create copy of vmt
|
|
GetMem(Result,vmtSize);
|
|
// type of self is class of TJITForm => it points to the vmt
|
|
Move(Pointer(SourceClass)^,Result^,vmtSize);
|
|
// create copy of methodtable
|
|
MethodTable:=PMethodNameTable((Pointer(SourceClass)+vmtMethodTable)^);
|
|
if Assigned(MethodTable) then begin
|
|
MethodTableSize:=SizeOf(DWord)+
|
|
MethodTable^.Count*SizeOf(TMethodNameRec);
|
|
GetMem(NewMethodTable,MethodTableSize);
|
|
Move(MethodTable^,NewMethodTable^,MethodTableSize);
|
|
PPointer(Result+vmtMethodTable)^:=NewMethodTable;
|
|
end;
|
|
// create pointer to classname
|
|
// set ClassNamePtr to point to the PShortString of ClassName
|
|
ClassNamePtr:=Pointer(Result)+vmtClassName;
|
|
GetMem(ClassNamePShortString,SizeOf(ShortString));
|
|
Pointer(ClassNamePtr^):=ClassNamePShortString;
|
|
Move(NewClassName[0],ClassNamePShortString^,SizeOf(ShortString));
|
|
end;
|
|
|
|
procedure TJITForms.FreevmtCopy(vmtCopy:Pointer);
|
|
|
|
procedure FreeNewMethods(MethodTable: PMethodNameTable);
|
|
var
|
|
CurCount, BaseCount, i: integer;
|
|
BaseMethodTable: PMethodNameTable;
|
|
CurMethod: TMethodNameRec;
|
|
begin
|
|
if MethodTable=nil then exit;
|
|
BaseMethodTable:=PMethodNameTable((Pointer(TJITForm)+vmtMethodTable)^);
|
|
if Assigned(BaseMethodTable) then
|
|
BaseCount:=BaseMethodTable^.Count
|
|
else
|
|
BaseCount:=0;
|
|
CurCount:=MethodTable^.Count;
|
|
if CurCount=BaseCount then exit;
|
|
i:=CurCount;
|
|
while i>BaseCount 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
|
|
MethodTable : PMethodNameTable;
|
|
ClassNamePtr: Pointer;
|
|
begin
|
|
//writeln('[TJITForms.FreevmtCopy] ClassName='''+TClass(vmtCopy).ClassName+'''');
|
|
if vmtCopy=nil then exit;
|
|
// free copy of methodtable
|
|
MethodTable:=PMethodNameTable((Pointer(vmtCopy)+vmtMethodTable)^);
|
|
if (Assigned(MethodTable)) then begin
|
|
FreeNewMethods(MethodTable);
|
|
FreeMem(MethodTable);
|
|
end;
|
|
// free pointer to classname
|
|
ClassNamePtr:=Pointer(vmtCopy)+vmtClassName;
|
|
FreeMem(Pointer(ClassNamePtr^));
|
|
// free copy of VMT
|
|
FreeMem(vmtCopy);
|
|
end;
|
|
|
|
procedure TJITForms.DoAddNewMethod(JITClass:TClass;
|
|
AName:ShortString; ACode:Pointer);
|
|
var OldMethodTable,NewMethodTable: PMethodNameTable;
|
|
NewMethodTableSize:integer;
|
|
begin
|
|
//writeln('[TJITForms.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
|
|
// writeln(a,'=',NewMethodTable^.Entries[a].Name^,' $'
|
|
// ,HexStr(Integer(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
|
|
// writeln(a,'=',NewMethodTable^.Entries[a].Name^,' $'
|
|
// ,HexStr(Integer(NewMethodTable^.Entries[a].Name),8));
|
|
{$R+}
|
|
PMethodNameTable((Pointer(JITClass)+vmtMethodTable)^):=NewMethodTable;
|
|
if Assigned(OldMethodTable) then
|
|
FreeMem(OldMethodTable);
|
|
end;
|
|
|
|
procedure TJITForms.DoRemoveMethod(JITClass:TClass; AName:ShortString;
|
|
var OldCode:Pointer);
|
|
var OldMethodTable, NewMethodTable: PMethodNameTable;
|
|
NewMethodTableSize:integer;
|
|
a:cardinal;
|
|
begin
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.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;
|
|
{$R+}
|
|
inc(a);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TJITForms.DoRenameMethod(JITClass:TClass;
|
|
OldName,NewName:ShortString);
|
|
var MethodTable: PMethodNameTable;
|
|
a:integer;
|
|
begin
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.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 TJITForms.DoRenameClass(JITClass:TClass; NewName:ShortString);
|
|
begin
|
|
{$IFDEF IDE_VERBOSE}
|
|
writeln('[TJITForms.DoRenameClass] OldName='''+JITClass.ClassName
|
|
+''' NewName='''+NewName+''' ');
|
|
{$ENDIF}
|
|
PShortString((Pointer(JITClass)+vmtClassName)^)^:=NewName;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
|
|
{
|
|
TReader events.
|
|
If a LFM is streamed back into the corresponfing 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 it at runtime
|
|
(just-in-time).
|
|
}
|
|
|
|
procedure TJITForms.ReaderFindMethod(Reader: TReader;
|
|
const FindMethodName: Ansistring; var Address: Pointer; var Error: Boolean);
|
|
var NewMethod: TMethod;
|
|
begin
|
|
{$IFDEF IDE_DEBUG}
|
|
writeln('[TJITForms.ReaderFindMethod] A "'+FindMethodName+'" Address=',HexStr(Cardinal(Address),8));
|
|
{$ENDIF}
|
|
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(FCurReadForm,FindMethodName);
|
|
Address:=NewMethod.Code;
|
|
Error:=false;
|
|
end;
|
|
end;
|
|
|
|
procedure TJITForms.ReaderSetName(Reader: TReader; Component: TComponent;
|
|
var NewName: Ansistring);
|
|
begin
|
|
// writeln('[TJITForms.ReaderSetName] OldName="'+Component.Name+'" NewName="'+NewName+'"');
|
|
end;
|
|
|
|
procedure TJITForms.ReaderReferenceName(Reader: TReader; var RefName: Ansistring);
|
|
begin
|
|
// writeln('[TJITForms.ReaderReferenceName] Name='''+RefName+'''');
|
|
end;
|
|
|
|
procedure TJITForms.ReaderAncestorNotFound(Reader: TReader;
|
|
const ComponentName: Ansistring; ComponentClass: TPersistentClass;
|
|
var Component: TComponent);
|
|
begin
|
|
// ToDo: this is for custom form templates
|
|
// writeln('[TJITForms.ReaderAncestorNotFound] ComponentName='''+ComponentName
|
|
// +''' Component='''+Component.Name+'''');
|
|
end;
|
|
|
|
procedure TJITForms.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;
|
|
begin
|
|
ErrorType:=jfeReaderError;
|
|
Action:=mrCancel;
|
|
FCurReadErrorMsg:=ErrorMsg;
|
|
// find out, what error occured
|
|
if RightStr(ErrorMsg,length(SUnknownProperty))=SUnknownProperty then begin
|
|
ErrorType:=jfeUnknownProperty;
|
|
Action:=mrIgnore;
|
|
end;
|
|
if Assigned(OnReaderError) then
|
|
OnReaderError(Self,ErrorType,Action);
|
|
Handled:=Action in [mrIgnore];
|
|
writeln('>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>');
|
|
writeln('[TJITForms.ReaderError] "'+ErrorMsg+'" ignoring=',Handled);
|
|
writeln('<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<');
|
|
end;
|
|
|
|
procedure TJITForms.ReaderFindComponentClass(Reader: TReader;
|
|
const FindClassName: Ansistring; var ComponentClass: TComponentClass);
|
|
var
|
|
RegComp:TRegisteredComponent;
|
|
Action: TModalResult;
|
|
ErrorType: TJITFormError;
|
|
begin
|
|
fCurReadComponent:=nil;
|
|
fCurReadComponentClass:=ComponentClass;
|
|
if ComponentClass=nil then begin
|
|
RegComp:=FRegCompList.FindComponentClassByName(FindClassName);
|
|
if RegComp<>nil then begin
|
|
//writeln('[TJITForms.ReaderFindComponentClass] '''+FindClassName
|
|
// +''' is registered');
|
|
ComponentClass:=RegComp.ComponentClass;
|
|
end else begin
|
|
writeln('[TJITForms.ReaderFindComponentClass] '''+FindClassName
|
|
+''' is unregistered');
|
|
Action:=mrCancel;
|
|
ErrorType:=jfeUnknownComponentClass;
|
|
if Assigned(OnReaderError) then
|
|
OnReaderError(Self,ErrorType,Action);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TJITForms.ReaderCreateComponent(Reader: TReader;
|
|
ComponentClass: TComponentClass; var Component: TComponent);
|
|
begin
|
|
fCurReadComponent:=Component;
|
|
fCurReadComponentClass:=ComponentClass;
|
|
// writeln('[TJITForms.ReaderCreateComponent] Class='''+ComponentClass.ClassName+'''');
|
|
end;
|
|
|
|
//==============================================================================
|
|
|
|
|
|
end.
|
|
|