IDE: implemented fake methods (-dEnableFakeMethods). ToDos: 1. extend TWriter.OnWriteMethodProperty for fPropPath, 2. test

git-svn-id: trunk@11037 -
This commit is contained in:
mattias 2007-04-30 00:36:05 +00:00
parent a6d2e13791
commit 83d784f501
4 changed files with 344 additions and 16 deletions

View File

@ -47,8 +47,8 @@ uses
{$IFDEF IDE_MEM_CHECK} {$IFDEF IDE_MEM_CHECK}
MemCheck, MemCheck,
{$ENDIF} {$ENDIF}
Classes, SysUtils, TypInfo, LCLProc, LResources, Forms, Controls, LCLIntf, Classes, SysUtils, AvgLvlTree, TypInfo, LCLProc, LResources, Forms, Controls,
Dialogs, JITForm, ComponentReg, IDEProcs; LCLIntf, Dialogs, JITForm, ComponentReg, IDEProcs;
type type
//---------------------------------------------------------------------------- //----------------------------------------------------------------------------
@ -150,7 +150,6 @@ type
function FindComponentByClass(AClass: TComponentClass): integer; function FindComponentByClass(AClass: TComponentClass): integer;
function FindComponentByName(const AName: shortstring): integer; function FindComponentByName(const AName: shortstring): integer;
procedure GetUnusedNames(var ComponentName, ComponentClassName: shortstring); procedure GetUnusedNames(var ComponentName, ComponentClassName: shortstring);
procedure AddNewMethod(JITComponent: TComponent; const AName: ShortString);
function CreateNewMethod(JITComponent: TComponent; function CreateNewMethod(JITComponent: TComponent;
const AName: ShortString): TMethod; const AName: ShortString): TMethod;
procedure RemoveMethod(JITComponent: TComponent; const AName: ShortString); procedure RemoveMethod(JITComponent: TComponent; const AName: ShortString);
@ -199,6 +198,55 @@ type
end; 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 ClassAsString(AClass: TClass): string;
function ClassMethodTableAsString(AClass: TClass): string; function ClassMethodTableAsString(AClass: TClass): string;
function ClassTypeInfoAsString(AClass: TClass): string; function ClassTypeInfoAsString(AClass: TClass): string;
@ -364,6 +412,12 @@ begin
Result:=MyFindGlobalComponentProc(AName); Result:=MyFindGlobalComponentProc(AName);
end; 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; function ClassAsString(AClass: TClass): string;
var var
ParentClass: TClass; ParentClass: TClass;
@ -518,6 +572,18 @@ begin
{$endif} {$endif}
end; 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; function CalculateTypeInfoSize(const AClassName: shortstring;
PropInfoCount: integer): integer; PropInfoCount: integer): integer;
begin begin
@ -843,12 +909,6 @@ begin
end; end;
procedure TJITComponentList.AddNewMethod(JITComponent:TComponent;
const AName:ShortString);
begin
CreateNewmethod(JITComponent,AName);
end;
procedure TJITComponentList.RemoveMethod(JITComponent:TComponent; procedure TJITComponentList.RemoveMethod(JITComponent:TComponent;
const AName:ShortString); const AName:ShortString);
var OldCode:Pointer; var OldCode:Pointer;
@ -863,6 +923,14 @@ begin
JITComponent.ClassName); JITComponent.ClassName);
if (AName='') or (not IsValidIdent(AName)) then if (AName='') or (not IsValidIdent(AName)) then
raise Exception.Create('TJITComponentList.RemoveMethod invalid name: "'+AName+'"'); 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; OldCode:=nil;
DoRemoveMethod(JITComponent.ClassType,AName,OldCode); DoRemoveMethod(JITComponent.ClassType,AName,OldCode);
FreeMem(OldCode); FreeMem(OldCode);
@ -881,6 +949,14 @@ begin
JITComponent.ClassName); JITComponent.ClassName);
if (NewName='') or (not IsValidIdent(NewName)) then if (NewName='') or (not IsValidIdent(NewName)) then
raise Exception.Create('TJITComponentList.RenameMethod invalid name: "'+NewName+'"'); 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); DoRenameMethod(JITComponent.ClassType,OldName,NewName);
end; end;
@ -982,6 +1058,9 @@ function TJITComponentList.CreateNewMethod(JITComponent: TComponent;
var CodeTemplate,NewCode:Pointer; var CodeTemplate,NewCode:Pointer;
CodeSize:integer; CodeSize:integer;
OldCode: Pointer; OldCode: Pointer;
{$IFDEF EnableFakeMethods}
JITMethod: TJITMethod;
{$ENDIF}
begin begin
{$IFDEF VerboseJITForms} {$IFDEF VerboseJITForms}
debugln('TJITComponentList.CreateNewMethod ',JITComponent.Name,':',JITComponent.Name,' Method=',AName); debugln('TJITComponentList.CreateNewMethod ',JITComponent.Name,':',JITComponent.Name,' Method=',AName);
@ -995,10 +1074,16 @@ begin
raise Exception.Create('TJITComponentList.CreateNewMethod invalid name: "'+AName+'"'); raise Exception.Create('TJITComponentList.CreateNewMethod invalid name: "'+AName+'"');
OldCode:=JITComponent.MethodAddress(AName); OldCode:=JITComponent.MethodAddress(AName);
if OldCode<>nil then begin if OldCode<>nil then begin
// there is already a real method with this name
Result.Data:=JITComponent; Result.Data:=JITComponent;
Result.Code:=OldCode; Result.Code:=OldCode;
exit; exit;
end; end;
{$IFDEF EnableFakeMethods}
// create a TJITMethod
JITMethod:=JITMethods.Add(JITComponent.ClassType,AName);
Result:=JITMethod.Method;
{$ELSE}
CodeTemplate:=MethodAddress('DoNothing'); CodeTemplate:=MethodAddress('DoNothing');
CodeSize:=100; // !!! what is the real codesize of DoNothing? !!! CodeSize:=100; // !!! what is the real codesize of DoNothing? !!!
GetMem(NewCode,CodeSize); GetMem(NewCode,CodeSize);
@ -1006,6 +1091,7 @@ begin
DoAddNewMethod(JITComponent.ClassType,AName,NewCode); DoAddNewMethod(JITComponent.ClassType,AName,NewCode);
Result.Data:=JITComponent; Result.Data:=JITComponent;
Result.Code:=NewCode; Result.Code:=NewCode;
{$ENDIF}
end; end;
function TJITComponentList.CreateNewJITClass(ParentClass: TClass; function TJITComponentList.CreateNewJITClass(ParentClass: TClass;
@ -1129,6 +1215,9 @@ var
OldTypeInfo: PTypeInfo; OldTypeInfo: PTypeInfo;
OldMethodTable: PMethodNameTable; OldMethodTable: PMethodNameTable;
begin begin
// free TJITMethods
JITMethods.DeleteAllOfClass(AClass);
OldVMT:=Pointer(AClass); OldVMT:=Pointer(AClass);
// free methodtable // free methodtable
OldMethodTable:=PMethodNameTable((OldVMT+vmtMethodTable)^); OldMethodTable:=PMethodNameTable((OldVMT+vmtMethodTable)^);
@ -1288,7 +1377,7 @@ end;
descendent, all methods and components are published members and TReader can descendent, all methods and components are published members and TReader can
set these values. set these values.
But at design time we do not have the corresponding TForm descendent. And 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 there is no compiled code, thus it must be produced
(just-in-time). (just-in-time).
} }
procedure TJITComponentList.ReaderFindMethod(Reader: TReader; procedure TJITComponentList.ReaderFindMethod(Reader: TReader;
@ -1298,6 +1387,9 @@ begin
{$IFDEF IDE_DEBUG} {$IFDEF IDE_DEBUG}
debugln('[TJITComponentList.ReaderFindMethod] A "'+FindMethodName+'" Address=',DbgS(Address)); debugln('[TJITComponentList.ReaderFindMethod] A "'+FindMethodName+'" Address=',DbgS(Address));
{$ENDIF} {$ENDIF}
{$IFDEF EnableFakeMethods}
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 if Address=nil then begin
// there is no method in the ancestor class with this name // there is no method in the ancestor class with this name
// => add a JIT method with this name to the JITForm // => add a JIT method with this name to the JITForm
@ -1305,6 +1397,7 @@ begin
Address:=NewMethod.Code; Address:=NewMethod.Code;
Error:=false; Error:=false;
end; end;
{$ENDIF}
end; end;
procedure TJITComponentList.ReaderPropertyNotFound(Reader: TReader; procedure TJITComponentList.ReaderPropertyNotFound(Reader: TReader;
@ -1319,8 +1412,27 @@ end;
procedure TJITComponentList.ReaderSetMethodProperty(Reader: TReader; procedure TJITComponentList.ReaderSetMethodProperty(Reader: TReader;
Instance: TPersistent; PropInfo: PPropInfo; const TheMethodName: string; Instance: TPersistent; PropInfo: PPropInfo; const TheMethodName: string;
var Handled: boolean); var Handled: boolean);
{$IFDEF EnableFakeMethods}
var
Method: TMethod;
JITMethod: TJITMethod;
{$ENDIF}
begin begin
//debugln('TJITComponentList.ReaderSetMethodProperty ',PropInfo^.Name,':=',TheMethodName); //debugln('TJITComponentList.ReaderSetMethodProperty ',PropInfo^.Name,':=',TheMethodName);
{$IFDEF EnableFakeMethods}
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(FCurReadJITComponent.ClassType,TheMethodName);
Method:=JITMethod.Method;
end;
SetMethodProp(Instance, PropInfo, Method);
Handled:=true;
{$ENDIF}
end; end;
procedure TJITComponentList.ReaderSetName(Reader: TReader; procedure TJITComponentList.ReaderSetName(Reader: TReader;
@ -1442,8 +1554,184 @@ begin
and (IndexOf(AComponent)>=0); and (IndexOf(AComponent)>=0);
end; end;
{ TJITMethod }
constructor TJITMethod.Create(AnOwner: TJITMethods;
aClass: TClass; const aMethodName: shortstring);
begin
FMethod.Data:=Self;
FMethod.Code:=nil;
fTheClass:=AClass;
fTheMethodName:=aMethodName;
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
Result:=TJITMethod.Create(Self,aClass,aMethodName);
end;
function TJITMethods.Find(aClass: TClass;
const aMethodName: shortstring): TJITMethod;
var
CurMethod: TJITMethod;
Node: TAvgLvlTreeNode;
Comp: LongInt;
begin
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
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;
fMethods.Remove(CurMethod);
CurMethod.fTheMethodName:=NewMethodName;
fMethods.Add(CurMethod);
end;
end;
Initialization Initialization
TComponentValidateRenameOffset:=GetTComponentValidateRenameVMTOffset; TComponentValidateRenameOffset:=GetTComponentValidateRenameVMTOffset;
JITMethods:=TJITMethods.Create;
finalization
FreeAndNil(JITMethods);
end. end.

View File

@ -183,6 +183,9 @@ each control that's dropped onto the form
): TComponent; ): TComponent;
function FindJITComponentByClass(AComponentClass: TComponentClass function FindJITComponentByClass(AComponentClass: TComponentClass
): TComponent; ): TComponent;
procedure WriteMethodPropertyEvent(Writer: TWriter; Instance: TPersistent;
PropInfo: PPropInfo; const MethodValue: TMethod;
const DefMethodCodeValue: Pointer; var Handled: boolean);
// designers // designers
function DesignerCount: integer; override; function DesignerCount: integer; override;
@ -1261,6 +1264,40 @@ begin
end; end;
end; end;
procedure TCustomFormEditor.WriteMethodPropertyEvent(Writer: TWriter;
Instance: TPersistent; PropInfo: PPropInfo; const MethodValue: TMethod;
const DefMethodCodeValue: Pointer; var Handled: boolean);
{$IFDEF EnableFakeMethods}
var
DefaultValue: TMethod;
PropPath: String;
CurName: String;
{$ENDIF}
begin
{$IFDEF EnableFakeMethods}
Handled:=true;
DebugLn(['TCustomFormEditor.WriteMethodPropertyEvent ',GlobalDesignHook.GetMethodName(MethodValue,nil)]);
// find ancestor method value
DefaultValue := GetMethodProp(Writer.Ancestor, PropInfo);
if (DefaultValue.Data=MethodValue.Data)
and (DefaultValue.Code=MethodValue.Code) then
exit;
PropPath:='';// ToDo: Writer.FPropPath
Writer.Driver.BeginProperty(PropPath + PPropInfo(PropInfo)^.Name);
if IsJITMethod(MethodValue) then
CurName:=TJITMethod(MethodValue.Data).TheMethodName
else if MethodValue.Code<>nil then
CurName:=Writer.LookupRoot.MethodName(MethodValue.Code)
else
CurName:='';
Writer.Driver.WriteMethodName(CurName);
Writer.Driver.EndProperty;
{$ENDIF}
end;
function TCustomFormEditor.DesignerCount: integer; function TCustomFormEditor.DesignerCount: integer;
begin begin
Result:=JITFormList.Count+JITNonFormList.Count; Result:=JITFormList.Count+JITNonFormList.Count;

View File

@ -94,7 +94,7 @@ uses
// help manager // help manager
IDEContextHelpEdit, HelpManager, IDEContextHelpEdit, HelpManager,
// designer // designer
JITForm, ComponentPalette, ComponentReg, ObjInspExt, JITForm, JITForms, ComponentPalette, ComponentReg, ObjInspExt,
Designer, FormEditor, CustomFormEditor, Designer, FormEditor, CustomFormEditor,
ControlSelection, AnchorEditor, ControlSelection, AnchorEditor,
{$DEFINE UseNewMenuEditor} {$DEFINE UseNewMenuEditor}
@ -1279,7 +1279,7 @@ end;
function TMainIDE.OnPropHookGetMethodName(const Method: TMethod; function TMainIDE.OnPropHookGetMethodName(const Method: TMethod;
CheckOwner: TObject): ShortString; CheckOwner: TObject): ShortString;
begin begin
if Assigned(Method.Code) then begin if Method.Code<>nil then begin
if Method.Data<>nil then begin if Method.Data<>nil then begin
if (CheckOwner<>nil) and (TObject(Method.Data)<>CheckOwner) then if (CheckOwner<>nil) and (TObject(Method.Data)<>CheckOwner) then
Result:='' Result:=''
@ -1290,6 +1290,8 @@ begin
end; end;
end else end else
Result:='<No LookupRoot>'; Result:='<No LookupRoot>';
end else if IsJITMethod(Method) then begin
Result:=TJITMethod(Method.Data).TheMethodName;
end else end else
Result:=''; Result:='';
end; end;
@ -4195,6 +4197,7 @@ begin
Grubber:=TLRTGrubber.Create; Grubber:=TLRTGrubber.Create;
Writer.OnWriteStringProperty:=@Grubber.Grub; Writer.OnWriteStringProperty:=@Grubber.Grub;
{$ENDIF} {$ENDIF}
Writer.OnWriteMethodProperty:=@FormEditor1.WriteMethodPropertyEvent;
AncestorUnit:=GetAncestorUnit(AnUnitInfo); AncestorUnit:=GetAncestorUnit(AnUnitInfo);
if AncestorUnit<>nil then if AncestorUnit<>nil then
AncestorInstance:=AncestorUnit.Component AncestorInstance:=AncestorUnit.Component

View File

@ -3722,6 +3722,7 @@ begin
CurFirstValue := GetMethodValue; CurFirstValue := GetMethodValue;
for I := 1 to PropCount - 1 do begin for I := 1 to PropCount - 1 do begin
AnotherValue := GetMethodValueAt(I); AnotherValue := GetMethodValueAt(I);
// Note: compare Code and Data
if (AnotherValue.Code <> CurFirstValue.Code) if (AnotherValue.Code <> CurFirstValue.Code)
or (AnotherValue.Data <> CurFirstValue.Data) then or (AnotherValue.Data <> CurFirstValue.Data) then
Exit; Exit;
@ -3827,7 +3828,7 @@ begin
System.Delete(Result, I, 1); System.Delete(Result, I, 1);
end; end;
if Result = '' then begin if Result = '' then begin
{raise EPropertyError.CreateRes(@SCannotCreateName);} DebugLn(['TMethodPropertyEditor.GetDefaultMethodName can not create name - this should never happen']);
exit; exit;
end; end;
Postfix := PropName; Postfix := PropName;
@ -3897,7 +3898,7 @@ begin
and (not PropertyHook.MethodFromAncestor(GetMethodValue)) then begin and (not PropertyHook.MethodFromAncestor(GetMethodValue)) then begin
// rename the method // rename the method
// Note: // Note:
// All other not selected properties that use this method, contains just // All other not selected properties that use this method, contain just
// the TMethod record. So, changing the name in the jitform will change // the TMethod record. So, changing the name in the jitform will change
// all other event names in all other components automatically. // all other event names in all other components automatically.
//writeln('### TMethodPropertyEditor.SetValue D'); //writeln('### TMethodPropertyEditor.SetValue D');
@ -3906,7 +3907,6 @@ begin
begin begin
//writeln('### TMethodPropertyEditor.SetValue E'); //writeln('### TMethodPropertyEditor.SetValue E');
CreateNewMethod := IsValidIdent(NewValue) and not NewMethodExists; CreateNewMethod := IsValidIdent(NewValue) and not NewMethodExists;
//OldMethod := GetMethodValue;
SetMethodValue(PropertyHook.CreateMethod(NewValue,GetPropType,GetUnitName)); SetMethodValue(PropertyHook.CreateMethod(NewValue,GetPropType,GetUnitName));
//writeln('### TMethodPropertyEditor.SetValue F NewValue=',GetValue); //writeln('### TMethodPropertyEditor.SetValue F NewValue=',GetValue);
if CreateNewMethod then begin if CreateNewMethod then begin