{ *************************************************************************** * * * 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 . 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} { $DEFINE VerboseJITForms} interface uses {$IFDEF IDE_MEM_CHECK} MemCheck, {$ENDIF} {$IFDEF VER1_0} FPCAdds, {$ENDIF} Classes, SysUtils, TypInfo, LCLProc, LResources, Forms, Controls, LCLIntf, Dialogs, JITForm, ComponentReg, IDEProcs; type //---------------------------------------------------------------------------- TJITFormError = ( jfeNone, jfeUnknown, jfeUnknownProperty, jfeUnknownComponentClass, jfeReaderError ); TJITFormErrors = set of TJITFormError; TJITReaderErrorEvent = procedure(Sender: TObject; ErrorType: TJITFormError; var Action: TModalResult) of object; TJITPropertyNotFoundEvent = procedure(Sender: TObject; Reader: TReader; Instance: TPersistent; var PropName: string; IsPath: boolean; var Handled, Skip: Boolean) of object; { TJITComponentList } TJITCompListFlag = ( jclAutoRenameComponents ); TJITCompListFlags = set of TJITCompListFlag; TJITComponentList = class(TPersistentWithTemplates) private FComponentPrefix: string; FCurUnknownClass: string; FCurUnknownProperty: string; FOnPropertyNotFound: TJITPropertyNotFoundEvent; procedure SetComponentPrefix(const AValue: string); protected FCurReadErrorMsg: string; FCurReadJITComponent:TComponent; FCurReadClass:TClass; FCurReadChild: TComponent; FCurReadChildClass: TComponentClass; FOnReaderError: TJITReaderErrorEvent; FJITComponents: TList; FFlags: TJITCompListFlags; // jit procedures function CreateNewJITClass(ParentClass: 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); // TReader events procedure ReaderFindMethod(Reader: TReader; const FindMethodName: Ansistring; var Address: Pointer; var Error: Boolean); {$IFNDEF VER1_0} 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); {$ENDIF} 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 GetClassNameFromStream(s:TStream):shortstring; function OnFindGlobalComponent(const AName:AnsiString):TComponent; procedure InitReading(BinStream: TStream; var Reader: TReader; DestroyDriver: Boolean); virtual; function DoCreateJITComponent(const NewComponentName, NewClassName, NewUnitName: shortstring; ParentClass: TClass):integer; procedure DoFinishReading; virtual; public constructor Create; destructor Destroy; override; property Items[Index: integer]: TComponent read GetItem; default; function Count: integer; function AddNewJITComponent(const NewUnitName: shortstring; ParentClass: TClass): integer; function AddJITComponentFromStream(BinStream: TStream; ParentClass: TClass; const NewUnitName: ShortString; Interactive: Boolean):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 FindComponentByName(const AName: shortstring): integer; procedure GetUnusedNames(var ComponentName, ComponentClassName: shortstring); procedure AddNewMethod(JITComponent: TComponent; const AName: 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); // child components function AddJITChildComponentFromStream(JITOwnerComponent: TComponent; BinStream: TStream; ComponentClass: TComponentClass; ParentControl: TWinControl): TComponent; public property OnReaderError: TJITReaderErrorEvent read FOnReaderError write FOnReaderError; property OnPropertyNotFound: TJITPropertyNotFoundEvent read FOnPropertyNotFound write FOnPropertyNotFound; property CurReadJITComponent:TComponent read FCurReadJITComponent; property CurReadClass:TClass read FCurReadClass; 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 ComponentPrefix: string read FComponentPrefix write SetComponentPrefix; end; { TJITForms } TJITForms = class(TJITComponentList) private function GetItem(Index: integer): TForm; public constructor Create; function IsJITForm(AComponent: TComponent): boolean; property Items[Index:integer]: TForm read GetItem; default; end; { TJITNonFormComponents } TJITNonFormComponents = class(TJITComponentList) public constructor Create; function IsJITNonForm(AComponent: TComponent): boolean; end; function ClassAsString(AClass: TClass): string; function ClassMethodTableAsString(AClass: TClass): string; function ClassTypeInfoAsString(AClass: TClass): string; function ClassFieldTableAsString(AClass: TClass): string; 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; procedure TComponentWithOverrideValidateRename.ValidateRename( AComponent: TComponent; const CurName, NewName: string); var Designer: TIDesigner; begin //debugln('TComponentWithOverrideValidateRename.ValidateRename ',DbgSName(Self)); inherited ValidateRename(AComponent, CurName, NewName); Designer:=FindRootDesigner(Self); if Designer <> nil then Designer.ValidateRename(AComponent, CurName, NewName); end; {$IFDEF VER1_0} type TMyComponent = class(TComponent) function GetValidateRenameAddress: pointer; end; { TMyComponent } class function TMyComponent.GetValidateRenameAddress: pointer; begin Result := @TComponent.ValidateRename; end; {$ENDIF} function GetTComponentValidateRenameVMTOffset: integer; begin Result:=GetVMTVirtualMethodOffset(TComponent, {$IFNDEF VER1_0}@TComponent.ValidateRename {$ELSE}TMyComponent.GetValidateRenameAddress{$ENDIF}, 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 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:=(@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; 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 := @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; //------------------------------------------------------------------------------ { TJITComponentList } constructor TJITComponentList.Create; begin inherited Create; FComponentPrefix:='Form'; FJITComponents:=TList.Create; end; destructor TJITComponentList.Destroy; begin while FJITComponents.Count>0 do DestroyJITComponent(FJITComponents.Count-1); FJITComponents.Free; 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; begin OldClass:=Items[Index].ClassType; Items[Index].Free; FreeJITClass(OldClass); FJITComponents.Delete(Index); end; function TJITComponentList.FindComponentByClassName( const AClassName:shortstring):integer; begin Result:=FJITComponents.Count-1; while (Result>=0) and (AnsiCompareText(Items[Result].ClassName,AClassName)<>0) do dec(Result); end; function TJITComponentList.FindComponentByName(const AName:shortstring):integer; begin Result:=FJITComponents.Count-1; while (Result>=0) and (AnsiCompareText(Items[Result].Name,AName)<>0) do dec(Result); end; procedure TJITComponentList.GetUnusedNames( var ComponentName,ComponentClassName:shortstring); var a:integer; begin a:=1; repeat ComponentName:=ComponentPrefix+IntToStr(a); ComponentClassName:='T'+ComponentPrefix+IntToStr(a); inc(a); until (FindComponentByName(ComponentName)<0) and (FindComponentByClassName(ComponentClassName)<0); end; function TJITComponentList.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); if (NameLen and $f0) = $f0 then begin { Skip Flag Byte } s.Read(NameLen,1); end; // read classname if NameLen>0 then begin SetLength(Result,NameLen); s.Read(Result[1],NameLen); end; s.Position:=0; end; function TJITComponentList.AddNewJITComponent(const NewUnitName: shortstring; ParentClass: TClass): integer; var NewComponentName, NewClassName: shortstring; begin {$IFDEF VerboseJITForms} debugln('[TJITComponentList] AddNewJITComponent'); {$ENDIF} GetUnusedNames(NewComponentName,NewClassName); {$IFDEF VerboseJITForms} debugln('TJITComponentList.AddNewJITComponent NewComponentName=',NewComponentName,' NewClassName=',NewClassName, ' NewUnitName=',NewUnitName,' ParentClass=',ParentClass.ClassName); {$ENDIF} Result:=DoCreateJITComponent(NewComponentName,NewClassName,NewUnitName, ParentClass); end; function TJITComponentList.AddJITComponentFromStream(BinStream: TStream; ParentClass: TClass; const NewUnitName: ShortString; Interactive: Boolean ):integer; // returns new index // -1 = invalid stream var Reader:TReader; NewClassName: shortstring; NewName: string; DestroyDriver: Boolean; begin Result:=-1; NewClassName:=GetClassNameFromStream(BinStream); if NewClassName='' then begin MessageDlg('No classname in stream found.',mtError,[mbOK],0); exit; end; {$IFDEF VerboseJITForms} writeln('[TJITComponentList.AddJITComponentFromStream] Create ...'); {$ENDIF} try Result:=DoCreateJITComponent('',NewClassName,NewUnitName,ParentClass); {$IFDEF VerboseJITForms} writeln('[TJITComponentList.AddJITComponentFromStream] InitReading ...'); {$ENDIF} DestroyDriver:=false; InitReading(BinStream,Reader,DestroyDriver); {$IFDEF VerboseJITForms} writeln('[TJITComponentList.AddJITComponentFromStream] Read ...'); {$ENDIF} try Reader.ReadRootComponent(FCurReadJITComponent); if FCurReadJITComponent.Name='' then begin NewName:=FCurReadJITComponent.ClassName; if NewName[1] in ['T','t'] then System.Delete(NewName,1,1); FCurReadJITComponent.Name:=NewName; end; {$IFDEF VerboseJITForms} writeln('[TJITComponentList.AddJITComponentFromStream] Finish Reading ...'); {$ENDIF} DoFinishReading; finally UnregisterFindGlobalComponentProc(@MyFindGlobalComponent); if DestroyDriver then Reader.Driver.Free; Reader.Free; end; except on E: Exception do begin DebugLn('[TJITComponentList.AddJITChildComponentFromStream] ERROR reading form stream' +' of Class ''',NewClassName,''' Error: ',E.Message); Result:=-1; end; end; end; function TJITComponentList.OnFindGlobalComponent( const AName: AnsiString): TComponent; begin Result:=Application.FindComponent(AName); end; procedure TJITComponentList.InitReading(BinStream: TStream; var Reader: TReader; DestroyDriver: Boolean); begin FFlags:=FFlags-[jclAutoRenameComponents]; DestroyDriver:=false; Reader:=CreateLRSReader(BinStream,DestroyDriver); MyFindGlobalComponentProc:=@OnFindGlobalComponent; RegisterFindGlobalComponentProc(@MyFindGlobalComponent); {$IFDEF VerboseJITForms} writeln('[TJITComponentList.InitReading] A'); {$ENDIF} // connect TReader events Reader.OnError:=@ReaderError; Reader.OnFindMethod:=@ReaderFindMethod; {$IFNDEF VER1_0} Reader.OnPropertyNotFound:=@ReaderPropertyNotFound; Reader.OnSetMethodProperty:=@ReaderSetMethodProperty; {$ENDIF} Reader.OnSetName:=@ReaderSetName; Reader.OnReferenceName:=@ReaderReferenceName; Reader.OnAncestorNotFound:=@ReaderAncestorNotFound; Reader.OnCreateComponent:=@ReaderCreateComponent; Reader.OnFindComponentClass:=@ReaderFindComponentClass; {$IFDEF VerboseJITForms} writeln('[TJITComponentList.InitReading] B'); {$ENDIF} FCurReadChildClass:=nil; FCurReadChild:=nil; FCurReadErrorMsg:=''; end; function TJITComponentList.DoCreateJITComponent( const NewComponentName, NewClassName, NewUnitName: shortstring; ParentClass: TClass):integer; var Instance:TComponent; ok: boolean; begin Result:=-1; // create new class and an instance //debugln('[TJITForms.DoCreateJITComponent] Creating new JIT class '''+NewClassName+''' ...'); Pointer(FCurReadClass):=CreateNewJITClass(ParentClass,NewClassName, NewUnitName); //debugln('[TJITForms.DoCreateJITComponent] Creating an instance of JIT class "'+NewClassName+'" = class('+ParentClass.ClassName+') ...'); Instance:=TComponent(FCurReadClass.NewInstance); //debugln('[TJITForms.DoCreateJITComponent] Initializing new instance ... ',DbgS(Instance)); TComponent(FCurReadJITComponent):=Instance; ok:=false; try // set into design mode SetComponentDesignMode(Instance,true); // 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'); end; end; Result:=FJITComponents.Add(FCurReadJITComponent); end; procedure TJITComponentList.DoFinishReading; begin end; procedure TJITComponentList.AddNewMethod(JITComponent:TComponent; const AName:ShortString); begin CreateNewmethod(JITComponent,AName); end; procedure TJITComponentList.RemoveMethod(JITComponent:TComponent; const AName:ShortString); var OldCode:Pointer; begin {$IFDEF VerboseJITForms} writeln('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+'"'); OldCode:=nil; DoRemoveMethod(JITComponent.ClassType,AName,OldCode); FreeMem(OldCode); end; procedure TJITComponentList.RenameMethod(JITComponent:TComponent; const OldName,NewName:ShortString); begin {$IFDEF VerboseJITForms} writeln('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+'"'); DoRenameMethod(JITComponent.ClassType,OldName,NewName); end; procedure TJITComponentList.RenameComponentClass(JITComponent:TComponent; const NewName:ShortString); begin {$IFDEF VerboseJITForms} writeln('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; function TJITComponentList.AddJITChildComponentFromStream( JITOwnerComponent: TComponent; BinStream: TStream; ComponentClass: TComponentClass; ParentControl: TWinControl): TComponent; var Reader: TReader; NewComponent: TComponent; DestroyDriver: Boolean; begin Result:=nil; NewComponent:=nil; if IndexOf(JITOwnerComponent)<0 then RaiseException('TJITComponentList.AddJITChildComponentFromStream'); {$IFDEF VerboseJITForms} writeln('[TJITComponentList.AddJITChildComponentFromStream] A'); {$ENDIF} try DestroyDriver:=false; InitReading(BinStream,Reader,DestroyDriver); {$IFDEF VerboseJITForms} writeln('[TJITComponentList.AddJITChildComponentFromStream] B'); {$ENDIF} try FCurReadJITComponent:=JITOwnerComponent; FCurReadClass:=JITOwnerComponent.ClassType; FFlags:=FFlags+[jclAutoRenameComponents]; {$IFDEF VerboseJITForms} writeln('[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} writeln('[TJITComponentList.AddJITChildComponentFromStream] D'); {$ENDIF} DoFinishReading; finally UnregisterFindGlobalComponentProc(@MyFindGlobalComponent); if DestroyDriver then Reader.Driver.Free; Reader.Free; end; except on E: Exception do begin DebugLn('[TJITComponentList.AddJITChildComponentFromStream] ERROR reading form stream' +' of Class ''',ComponentClass.ClassName,''' Error: ',E.Message); end; end; Result:=NewComponent; end; function TJITComponentList.CreateNewMethod(JITComponent: TComponent; const AName: ShortString): TMethod; var CodeTemplate,NewCode:Pointer; CodeSize:integer; OldCode: Pointer; begin {$IFDEF VerboseJITForms} writeln('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 Result.Data:=JITComponent; 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(JITComponent.ClassType,AName,NewCode); Result.Data:=JITComponent; Result.Code:=NewCode; end; procedure TJITComponentList.SetComponentPrefix(const AValue: string); begin if FComponentPrefix=AValue then exit; FComponentPrefix:=AValue; end; function TJITComponentList.CreateNewJITClass(ParentClass: TClass; const NewClassName, NewUnitName: ShortString): TClass; // Create a new class (vmt, virtual method table, field table and typeinfo) // that descends from ParentClass. // The new class will have no new variables, now new methods and no new fields. var NewVMT: Pointer; ClassNamePShortString: Pointer; NewFieldTable: PFieldTable; NewClassTable: PFieldClassTable; NewTypeInfo: PTypeInfo; NewTypeData: PTypeData; TypeInfoSize: Integer; TypeDataSize: Integer; AddedPropCount: PWord; vmtSize: Integer; vmtTailSize: Integer; begin if ParentClass=nil then raise Exception.Create('CreateNewClass ParentClass=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(ParentClass); vmtTailSize:=vmtSize-vmtMethodStart; GetMem(NewVMT,vmtSize); FillChar(NewVMT^,vmtSize,0); // set vmtInstanceSize PPtrInt(NewVMT+vmtInstanceSize)^:=ParentClass.InstanceSize; PPtrInt(NewVMT+vmtInstanceSizeNeg)^:=-ParentClass.InstanceSize; // set vmtParent TClass(Pointer(NewVMT+vmtParent)^):=ParentClass; // 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 TypeDataSize := SizeOf(TTypeData) + 2; // TTypeData + one word for new prop count {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} if TypeDataSize and (SizeOf(Pointer) - 1) <> 0 then Inc(TypeDataSize, SizeOf(Pointer)); // a few bytes to much, but atleast enough {$endif} TypeInfoSize := SizeOf(TTypeKind) + 1 + length(NewClassName) + TypeDataSize; {$warnings off} if SizeOf(TTypeKind)<>1 then raise Exception.Create('CreateNewClass SizeOf(TTypeInfo^.Kind)<>1'); {$warnings on} 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) NewTypeData^.ClassType:=TClass(NewVMT); NewTypeData^.ParentInfo:=ParentClass.ClassInfo; NewTypeData^.PropCount:=GetTypeData(NewTypeData^.ParentInfo)^.PropCount; NewTypeData^.UnitName:=NewUnitName; AddedPropCount:=PWord(@(NewTypeData^.UnitName)+Length(NewTypeData^.UnitName)+1); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} AddedPropCount := Align(AddedPropCount, SizeOf(Pointer)); {$endif} AddedPropCount^:=0; // copy the standard methods System.Move(Pointer(Pointer(ParentClass)+vmtMethodStart)^, Pointer(NewVMT+vmtMethodStart)^, vmtTailSize); // override 'ValidateRename' for TComponent descendents if ParentClass.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 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 //writeln('[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 // writeln(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 // writeln(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} writeln('[TJITComponentList.DoRemoveMethod] '''+JITClass.ClassName+'.'+AName+''''); {$ENDIF} AName:=uppercase(AName); OldMethodTable:=PMethodNameTable((Pointer(JITClass)+vmtMethodTable)^); OldCode:=nil; if Assigned(OldMethodTable) then begin a:=0; while a0 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} writeln('[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} writeln('[TJITComponentList.DoRenameClass] OldName='''+JITClass.ClassName +''' NewName='''+NewName+''' '); {$ENDIF} PShortString((Pointer(JITClass)+vmtClassName)^)^:=NewName; 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 it at runtime (just-in-time). } procedure TJITComponentList.ReaderFindMethod(Reader: TReader; const FindMethodName: Ansistring; var Address: Pointer; var Error: Boolean); var NewMethod: TMethod; begin {$IFDEF IDE_DEBUG} writeln('[TJITComponentList.ReaderFindMethod] A "'+FindMethodName+'" Address=',DbgS(Address)); {$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(FCurReadJITComponent,FindMethodName); Address:=NewMethod.Code; Error:=false; end; end; {$IFNDEF VER1_0} 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); begin //writeln('TJITComponentList.ReaderSetMethodProperty ',PropInfo^.Name,':=',TheMethodName); end; {$ENDIF} procedure TJITComponentList.ReaderSetName(Reader: TReader; Component: TComponent; var NewName: Ansistring); var CurName: String; i: Integer; begin // writeln('[TJITComponentList.ReaderSetName] OldName="'+Component.Name+'" NewName="'+NewName+'"'); if jclAutoRenameComponents in FFlags then begin while (NewName<>'') and (NewName[length(NewName)] in ['0'..'9']) do System.Delete(NewName,length(NewName),1); if NewName='' then NewName:=Component.ClassName; i:=0; repeat inc(i); CurName:=NewName+IntToStr(i); until FCurReadJITComponent.FindComponent(CurName)=nil; NewName:=CurName; end; end; procedure TJITComponentList.ReaderReferenceName(Reader: TReader; var RefName: Ansistring); begin // writeln('[TJITComponentList.ReaderReferenceName] Name='''+RefName+''''); end; procedure TJITComponentList.ReaderAncestorNotFound(Reader: TReader; const ComponentName: Ansistring; ComponentClass: TPersistentClass; var Component: TComponent); begin // ToDo: this is for custom form templates // writeln('[TJITComponentList.ReaderAncestorNotFound] ComponentName='''+ComponentName // +''' Component='''+Component.Name+''''); 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; 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 Assigned(OnReaderError) then OnReaderError(Self,ErrorType,Action); Handled:=Action in [mrIgnore]; FCurUnknownProperty:=''; DebugLn('>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>'); DebugLn('[TJITComponentList.ReaderError] "'+ErrorMsg+'" ignoring=',BoolToStr(Handled)); DebugLn('<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'); end; procedure TJITComponentList.ReaderFindComponentClass(Reader: TReader; const FindClassName: Ansistring; var ComponentClass: TComponentClass); var RegComp: TRegisteredComponent; begin fCurReadChild:=nil; fCurReadChildClass:=ComponentClass; FCurUnknownClass:=FindClassName; if ComponentClass=nil then begin {$IFDEF DisablePkgs} RegComp:=FRegCompList.FindComponentClassByName(FindClassName); {$ELSE} RegComp:=IDEComponentPalette.FindComponent(FindClassName); {$ENDIF} if RegComp<>nil then begin //writeln('[TJITComponentList.ReaderFindComponentClass] '''+FindClassName // +''' is registered'); ComponentClass:=RegComp.ComponentClass; end else 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; // writeln('[TJITComponentList.ReaderCreateComponent] Class='''+ComponentClass.ClassName+''''); end; procedure TJITComponentList.ReaderReadComponent(Component: TComponent); begin DebugLn('TJITComponentList.ReaderReadComponent A ',Component.Name,':',Component.ClassName); end; //============================================================================== { TJITForms } constructor TJITForms.Create; begin inherited Create; FComponentPrefix:='Form'; end; 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 } constructor TJITNonFormComponents.Create; begin inherited Create; FComponentPrefix:='DataModule'; end; function TJITNonFormComponents.IsJITNonForm(AComponent: TComponent): boolean; begin Result:=(AComponent<>nil) and (not (AComponent is TForm)) and (IndexOf(AComponent)>=0); end; Initialization TComponentValidateRenameOffset:=GetTComponentValidateRenameVMTOffset; end.