From d2d3030a60dbf93e610415b9cc98377753be023f Mon Sep 17 00:00:00 2001 From: mattias Date: Sat, 20 Nov 2004 11:20:06 +0000 Subject: [PATCH] implemented creating classes at run time from any TComponent descendant git-svn-id: trunk@6272 - --- components/synedit/synedit.pp | 5 +- designer/designer.pp | 4 +- designer/jitform/jitform.pas | 50 +-- designer/jitforms.pp | 304 ++++++++--------- designer/noncontrolforms.pas | 121 +++---- ide/customformeditor.pp | 87 ++--- ide/editoroptions.pp | 3 +- ide/formeditor.pp | 4 +- ide/main.pp | 87 +++-- ide/mainintf.pas | 4 +- ide/newdialog.pas | 512 ++++++++++++++++++++--------- ide/project.pp | 5 +- ide/projectdefs.pas | 1 + ideintf/formeditingintf.pas | 5 +- ideintf/packageintf.pas | 93 ++++++ ideintf/projectintf.pas | 8 +- lcl/forms.pp | 2 - lcl/graphics.pp | 37 ++- lcl/include/customform.inc | 16 +- lcl/interfaces/gtk/gtkobject.inc | 35 +- lcl/interfaces/gtk/gtkproc.inc | 4 +- lcl/interfaces/gtk/gtkwinapi.inc | 26 +- lcl/interfaces/gtk/gtkwsbuttons.pp | 62 ++-- lcl/lclclasses.pp | 2 + lcl/lcltype.pp | 4 +- packager/pkgmanager.pas | 168 +++++++++- tools/install/fpcsrc.spec | 4 + 27 files changed, 1076 insertions(+), 577 deletions(-) diff --git a/components/synedit/synedit.pp b/components/synedit/synedit.pp index 39a9f81c56..039daf1a44 100644 --- a/components/synedit/synedit.pp +++ b/components/synedit/synedit.pp @@ -1944,11 +1944,14 @@ begin if not (sfIgnoreNextChar in fStateFlags) then begin {$IFDEF SYN_LAZARUS} if Assigned(OnUTF8KeyPress) then OnUTF8KeyPress(Self, Key); + {$IFDEF VerboseKeyboard} + DebugLn('TCustomSynEdit.UTF8KeyPress ',DbgSName(Self),' Key="',DbgStr(Key),'" UseUTF8=',dbgs(UseUTF8)); + {$ENDIF} {$ELSE} if Assigned(OnKeyPress) then OnKeyPress(Self, Key); {$ENDIF} CommandProcessor(ecChar, Key, nil); - //Key was handled, any way, so eat it! + // Key was handled anyway, so eat it! Key:=''; end else // don't ignore further keys diff --git a/designer/designer.pp b/designer/designer.pp index 90b22a5782..29d02c7b2f 100644 --- a/designer/designer.pp +++ b/designer/designer.pp @@ -326,8 +326,8 @@ constructor TDesigner.Create(TheDesignerForm: TCustomForm; begin inherited Create; FForm := TheDesignerForm; - if FForm is TNonControlForm then - FLookupRoot:=TNonControlForm(FForm).LookupRoot + if FForm is TNonFormDesignerForm then + FLookupRoot:=TNonFormDesignerForm(FForm).LookupRoot else FLookupRoot:=FForm; diff --git a/designer/jitform/jitform.pas b/designer/jitform/jitform.pas index 969c716915..940ab20dc7 100644 --- a/designer/jitform/jitform.pas +++ b/designer/jitform/jitform.pas @@ -43,9 +43,8 @@ uses type // TJITForm is a template TForm descendent class that can be altered at // runtime - TJITForm = class(TForm) - protected - class function NewInstance: TObject; override; + // OBSOLETE: + {TJITForm = class(TForm) public end; @@ -54,15 +53,12 @@ type // TJITDataModule is a template TDataModule descendent class that can be // altered at runtime + // OBSOLETE: TJITDataModule = class(TDataModule) - protected - class function NewInstance: TObject; override; - procedure ValidateRename(AComponent: TComponent; - const CurName, NewName: string); override; public end; - TJITDataModuleClass = class of TJITDataModule; + TJITDataModuleClass = class of TJITDataModule;} // TPersistentWithTemplates @@ -73,6 +69,8 @@ type end; TJITClass = class of TPersistent; + +procedure SetComponentDesignMode(AComponent: TComponent; Value: Boolean); implementation @@ -81,10 +79,15 @@ implementation type TSetDesigningComponent = class(TComponent) public - class procedure SetDesigningOfControl(AComponent: TComponent; Value: Boolean); + class procedure SetDesigningOfComponent(AComponent: TComponent; Value: Boolean); end; -procedure TSetDesigningComponent.SetDesigningOfControl( +procedure SetComponentDesignMode(AComponent: TComponent; Value: Boolean); +begin + TSetDesigningComponent.SetDesigningOfComponent(AComponent,true); +end; + +procedure TSetDesigningComponent.SetDesigningOfComponent( AComponent: TComponent; Value: Boolean); begin AComponent.SetDesigning(Value); @@ -100,32 +103,5 @@ begin end; {$IFDEF StackCheckOn}{$S+}{$ENDIF} -{ TJITForm } - -function TJITForm.NewInstance: TObject; -begin - Result:=inherited NewInstance; - TSetDesigningComponent.SetDesigningOfControl(TComponent(Result),true); -end; - -{ TJITDataModule } - -function TJITDataModule.NewInstance: TObject; -begin - Result:=inherited NewInstance; - TSetDesigningComponent.SetDesigningOfControl(TComponent(Result),true); -end; - -procedure TJITDataModule.ValidateRename(AComponent: TComponent; const CurName, - NewName: string); -var - Designer: TIDesigner; -begin - inherited ValidateRename(AComponent, CurName, NewName); - Designer:=FindRootDesigner(Self); - if Designer <> nil then - Designer.ValidateRename(AComponent, CurName, NewName); -end; - end. diff --git a/designer/jitforms.pp b/designer/jitforms.pp index c9386a7074..f5169ce6e2 100644 --- a/designer/jitforms.pp +++ b/designer/jitforms.pp @@ -95,15 +95,9 @@ type FJITComponents: TList; FFlags: TJITCompListFlags; // jit procedures - {$IFDEF UseJITClasses} function CreateNewJITClass(ParentClass: TClass; const NewClassName, NewUnitName: ShortString): TClass; procedure FreeJITClass(var AClass: TClass); - {$ELSE} - function CreateVMTCopy(SourceClass: TClass; - const NewClassName: ShortString): Pointer; - procedure FreevmtCopy(vmtCopy: Pointer); - {$ENDIF} procedure DoAddNewMethod(JITClass: TClass; const AName: ShortString; ACode: Pointer); // Note: AddNewMethod does not check if method already exists procedure DoRemoveMethod(JITClass: TClass; AName: ShortString; @@ -138,38 +132,39 @@ type function OnFindGlobalComponent(const AName:AnsiString):TComponent; procedure InitReading(BinStream: TStream; var Reader: TReader; DestroyDriver: Boolean); virtual; - function DoCreateJITComponent(NewComponentName,NewClassName:shortstring - ):integer; + function DoCreateJITComponent(const NewComponentName, NewClassName, + NewUnitName: shortstring; ParentClass: TClass):integer; procedure DoFinishReading; virtual; - function CreateDefaultVMTCopy: Pointer; virtual; abstract; public constructor Create; destructor Destroy; override; - property Items[Index:integer]: TComponent read GetItem; default; - function Count:integer; - function AddNewJITComponent:integer; - function AddJITComponentFromStream(BinStream:TStream; + 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 FindComponentByClassName(const AClassName:shortstring):integer; - function FindComponentByName(const AName:shortstring):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); + 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 - BaseJITClass: TJITClass; property OnReaderError: TJITReaderErrorEvent read FOnReaderError write FOnReaderError; property OnPropertyNotFound: TJITPropertyNotFoundEvent @@ -191,8 +186,6 @@ type TJITForms = class(TJITComponentList) private function GetItem(Index: integer): TForm; - protected - function CreateDefaultVMTCopy: Pointer; override; public constructor Create; function IsJITForm(AComponent: TComponent): boolean; @@ -200,17 +193,12 @@ type end; - { TJITDataModules } + { TJITNonFormComponents } - TJITDataModules = class(TJITComponentList) - private - function GetItem(Index: integer): TDataModule; - protected - function CreateDefaultVMTCopy: Pointer; override; + TJITNonFormComponents = class(TJITComponentList) public constructor Create; - function IsJITDataModule(AComponent: TComponent): boolean; - property Items[Index:integer]: TDataModule read GetItem; default; + function IsJITNonForm(AComponent: TComponent): boolean; end; @@ -219,6 +207,9 @@ function ClassMethodTableAsString(AClass: TClass): string; function ClassTypeInfoAsString(AClass: TClass): string; function ClassFieldTableAsString(AClass: TClass): string; +const + DefaultJITUnitName = 'VirtualUnitForJITClasses'; + implementation @@ -265,6 +256,70 @@ type // Fields: array[Word] of TFieldInfo; Elements have variant size! end; +function FindVMTMethodOffset(AClass: TClass; MethodPointer: Pointer): integer; +var + i: Integer; +begin + for i:=0 to 1000 do begin + if PPointer(AClass)[i]=MethodPointer then begin + Result:=i*SizeOf(Pointer); + exit; + end; + 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; + +function GetTComponentValidateRenameVMTOffset: integer; +begin + Result:=GetVMTVirtualMethodOffset(TComponent,@TComponent.ValidateRename, + TComponentWithOverrideValidateRename, + @TComponentWithOverrideValidateRename.ValidateRename); +end; + var MyFindGlobalComponentProc:function(const AName:AnsiString):TComponent of object; @@ -438,6 +493,11 @@ begin 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 @@ -456,11 +516,7 @@ var begin OldClass:=Items[Index].ClassType; Items[Index].Free; - {$IFDEF UseJITClasses} FreeJITClass(OldClass); - {$ELSE} - FreevmtCopy(OldClass); - {$ENDIF} FJITComponents.Delete(Index); end; @@ -514,26 +570,31 @@ begin s.Position:=0; end; -function TJITComponentList.AddNewJITComponent:integer; -var NewComponentName,NewClassName:shortstring; +function TJITComponentList.AddNewJITComponent(const NewUnitName: shortstring; + ParentClass: TClass): integer; +var + NewComponentName, NewClassName: shortstring; begin {$IFDEF VerboseJITForms} - Writeln('[TJITComponentList] AddNewJITComponent'); + debugln('[TJITComponentList] AddNewJITComponent'); {$ENDIF} GetUnusedNames(NewComponentName,NewClassName); {$IFDEF VerboseJITForms} - Writeln('NewComponentName is ',NewComponentName,', NewClassName is ',NewClassName); + debugln('TJITComponentList.AddNewJITComponent NewComponentName=',NewComponentName,' NewClassName=',NewClassName, + ' NewUnitName=',NewUnitName,' ParentClass=',ParentClass.ClassName); {$ENDIF} - Result:=DoCreateJITComponent(NewComponentName,NewClassName); + Result:=DoCreateJITComponent(NewComponentName,NewClassName,NewUnitName, + ParentClass); end; -function TJITComponentList.AddJITComponentFromStream(BinStream:TStream; - Interactive: Boolean):integer; +function TJITComponentList.AddJITComponentFromStream(BinStream: TStream; + ParentClass: TClass; const NewUnitName: ShortString; Interactive: Boolean + ):integer; // returns new index // -1 = invalid stream var Reader:TReader; - NewClassName:shortstring; + NewClassName: shortstring; NewName: string; DestroyDriver: Boolean; begin @@ -547,7 +608,7 @@ begin writeln('[TJITComponentList.AddJITComponentFromStream] Create ...'); {$ENDIF} try - Result:=DoCreateJITComponent('',NewClassName); + Result:=DoCreateJITComponent('',NewClassName,NewUnitName,ParentClass); {$IFDEF VerboseJITForms} writeln('[TJITComponentList.AddJITComponentFromStream] InitReading ...'); {$ENDIF} @@ -625,27 +686,32 @@ begin end; function TJITComponentList.DoCreateJITComponent( - NewComponentName,NewClassName:shortstring):integer; + const NewComponentName, NewClassName, NewUnitName: shortstring; + ParentClass: TClass):integer; var Instance:TComponent; ok: boolean; begin Result:=-1; // create new class and an instance - //writeln('[TJITForms.DoCreateJITComponent] Creating new JIT class '''+NewClassName+''' ...'); - Pointer(FCurReadClass):=CreateDefaultVMTCopy; - //writeln('[TJITForms.DoCreateJITComponent] Creating an instance of JIT class '''+NewClassName+''' ...'); + //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); - //writeln('[TJITForms.DoCreateJITComponent] Initializing new instance ...'); + //debugln('[TJITForms.DoCreateJITComponent] Initializing new instance ... ',HexStr(Cardinal(Instance),8)); 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; - //writeln('[TJITForms.DoCreateJITComponent] Initialization was successful! FormName="',NewFormName,'"'); + //debugln('[TJITForms.DoCreateJITComponent] Initialization was successful! FormName="',NewFormName,'"'); finally if not ok then begin TComponent(FCurReadJITComponent):=nil; @@ -814,7 +880,6 @@ begin FComponentPrefix:=AValue; end; -{$IFDEF UseJITClasses} function TJITComponentList.CreateNewJITClass(ParentClass: TClass; const NewClassName, NewUnitName: ShortString): TClass; // Create a new class (vmt, virtual method table, field table and typeinfo) @@ -841,6 +906,10 @@ begin 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 @@ -900,6 +969,12 @@ begin 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; @@ -951,86 +1026,6 @@ begin FreeMem(OldVMT); AClass:=nil; end; -{$ELSE UseJITClasses} -function TJITComponentList.CreateVMTCopy(SourceClass:TClass; - const NewClassName:ShortString):Pointer; -const - vmtSize:integer=5000; //XXX how big is the vmt of class TJITForm ? -var MethodTable, NewMethodTable: PMethodNameTable; - MethodTableSize: integer; - ClassNamePtr, ClassNamePShortString: Pointer; -begin -//writeln('[TJITComponentList.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 TJITComponentList.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(BaseJITClass)+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 - {$IFDEF VerboseJITForms} - writeln('[TJITComponentList.FreevmtCopy] ClassName='''+TClass(vmtCopy).ClassName+''''); - {$ENDIF} - 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; -{$ENDIF UseJITClasses} procedure TJITComponentList.DoAddNewMethod(JITClass:TClass; const AName:ShortString; ACode:Pointer); @@ -1301,7 +1296,6 @@ constructor TJITForms.Create; begin inherited Create; FComponentPrefix:='Form'; - BaseJITClass:=TJITForm; end; function TJITForms.IsJITForm(AComponent: TComponent): boolean; @@ -1315,44 +1309,22 @@ begin Result:=TForm(inherited Items[Index]); end; -function TJITForms.CreateDefaultVMTCopy: Pointer; -begin - {$IFDEF UseJITClasses} - Result:=CreateNewJITClass(TForm,'TJITForm','JITUnit'); - {$ELSE} - Result:=CreateVMTCopy(TJITForm,'TJITForm'); - {$ENDIF} -end; +{ TJITNonFormComponents } - -{ TJITDataModules } - -function TJITDataModules.GetItem(Index: integer): TDataModule; -begin - Result:=TDataModule(inherited Items[Index]); -end; - -function TJITDataModules.CreateDefaultVMTCopy: Pointer; -begin - {$IFDEF UseJITClasses} - Result:=CreateNewJITClass(TDataModule,'TJITDataModule','JITUnit'); - {$ELSE} - Result:=CreateVMTCopy(TJITForm,'TJITForm'); - {$ENDIF} -end; - -constructor TJITDataModules.Create; +constructor TJITNonFormComponents.Create; begin inherited Create; FComponentPrefix:='DataModule'; - BaseJITClass:=TJITDataModule; end; -function TJITDataModules.IsJITDataModule(AComponent: TComponent): boolean; +function TJITNonFormComponents.IsJITNonForm(AComponent: TComponent): boolean; begin - Result:=(AComponent<>nil) and (AComponent is TDataModule) + Result:=(AComponent<>nil) and (not (AComponent is TForm)) and (IndexOf(AComponent)>=0); end; +Initialization + TComponentValidateRenameOffset:=GetTComponentValidateRenameVMTOffset; + end. diff --git a/designer/noncontrolforms.pas b/designer/noncontrolforms.pas index 97d3f9d677..3b1b7d3903 100644 --- a/designer/noncontrolforms.pas +++ b/designer/noncontrolforms.pas @@ -32,13 +32,14 @@ unit NonControlForms; interface uses - Classes, SysUtils, Graphics, GraphType, Forms, Controls, IDEProcs; + Classes, SysUtils, Math, LCLProc, Graphics, GraphType, Forms, Controls, + IDEProcs; type - { TNonControlForm } + { TNonFormDesignerForm } - TNonControlForm = class(TForm) + TNonFormDesignerForm = class(TForm) private FFrameWidth: integer; FLookupRoot: TComponent; @@ -61,21 +62,6 @@ type end; - { TDataModuleForm } - - TDataModuleForm = class(TNonControlForm) - private - function GetDataModule: TDataModule; - procedure SetDataModule(const AValue: TDataModule); - protected - procedure SetLookupRoot(const AValue: TComponent); override; - public - procedure DoLoadBounds; override; - procedure DoSaveBounds; override; - public - property DataModule: TDataModule read GetDataModule write SetDataModule; - end; - function CompareNonControlForms(Data1, Data2: Pointer): integer; function CompareLookupRootAndNonControlForm(Key, Data: Pointer): integer; @@ -84,27 +70,27 @@ implementation function CompareNonControlForms(Data1, Data2: Pointer): integer; var - Form1: TNonControlForm; - Form2: TNonControlForm; + Form1: TNonFormDesignerForm; + Form2: TNonFormDesignerForm; begin - Form1:=TNonControlForm(Data1); - Form2:=TNonControlForm(Data2); + Form1:=TNonFormDesignerForm(Data1); + Form2:=TNonFormDesignerForm(Data2); Result:=integer(Form1.LookupRoot)-integer(Form2.LookupRoot); end; function CompareLookupRootAndNonControlForm(Key, Data: Pointer): integer; var LookupRoot: TComponent; - Form: TNonControlForm; + Form: TNonFormDesignerForm; begin LookupRoot:=TComponent(Key); - Form:=TNonControlForm(Data); + Form:=TNonFormDesignerForm(Data); Result:=integer(LookupRoot)-integer(Form.LookupRoot); end; -{ TNonControlForm } +{ TNonFormDesignerForm } -procedure TNonControlForm.SetLookupRoot(const AValue: TComponent); +procedure TNonFormDesignerForm.SetLookupRoot(const AValue: TComponent); begin if FLookupRoot=AValue then exit; DoSaveBounds; @@ -115,26 +101,26 @@ begin DoLoadBounds; end; -procedure TNonControlForm.SetFrameWidth(const AValue: integer); +procedure TNonFormDesignerForm.SetFrameWidth(const AValue: integer); begin if FFrameWidth=AValue then exit; FFrameWidth:=AValue; Invalidate; end; -constructor TNonControlForm.Create(TheOwner: TComponent); +constructor TNonFormDesignerForm.Create(TheOwner: TComponent); begin inherited Create(TheOwner); FFrameWidth:=1; ControlStyle:=ControlStyle-[csAcceptsControls]; end; -destructor TNonControlForm.Destroy; +destructor TNonFormDesignerForm.Destroy; begin inherited Destroy; end; -procedure TNonControlForm.Paint; +procedure TNonFormDesignerForm.Paint; var ARect: TRect; begin @@ -150,38 +136,22 @@ begin end; end; -procedure TNonControlForm.DoLoadBounds; -begin - if Assigned(OnLoadBounds) then OnLoadBounds(Self); -end; +procedure TNonFormDesignerForm.DoLoadBounds; -procedure TNonControlForm.DoSaveBounds; -begin - if Assigned(OnSaveBounds) then OnSaveBounds(Self); -end; + procedure SetNewBounds(NewLeft, NewTop, NewWidth, NewHeight: integer); + begin + if NewWidth<=0 then NewWidth:=Width; + if NewHeight<=0 then NewHeight:=Height; -{ TDataModuleForm } + NewWidth:=Max(20,Min(NewWidth,Screen.Width-50)); + NewHeight:=Max(20,Min(NewHeight,Screen.Height-50)); + NewLeft:=Max(0,Min(NewLeft,Screen.Width-NewWidth-50)); + NewTop:=Max(0,Min(NewTop,Screen.Height-NewHeight-50)); -procedure TDataModuleForm.SetDataModule(const AValue: TDataModule); -begin - LookupRoot:=AValue; -end; + //debugln('TNonFormDesignerForm.DoLoadBounds (TDataModule) ',dbgsName(LookupRoot),' ',dbgs(NewLeft),',',dbgs(NewTop),',',dbgs(NewWidth),',',dbgs(NewHeight)); + SetBounds(NewLeft,NewTop,Max(20,NewWidth),Max(NewHeight,20)); + end; -function TDataModuleForm.GetDataModule: TDataModule; -begin - Result:=TDataModule(LookupRoot); -end; - -procedure TDataModuleForm.SetLookupRoot(const AValue: TComponent); -begin - if AValue=LookupRoot then exit; - if (AValue<>nil) and (not (AValue is TDataModule)) then - RaiseException('TDataModuleForm.SetLookupRoot AValue.ClassName=' - +AValue.ClassName); - inherited SetLookupRoot(AValue); -end; - -procedure TDataModuleForm.DoLoadBounds; var CurDataModule: TDataModule; NewLeft: Integer; @@ -189,29 +159,36 @@ var NewWidth: Integer; NewHeight: Integer; begin - inherited DoLoadBounds; - CurDataModule:=DataModule; - if CurDataModule<>nil then begin + if Assigned(OnLoadBounds) then OnLoadBounds(Self); + if LookupRoot is TDataModule then begin + CurDataModule:=TDataModule(LookupRoot); NewLeft:=CurDataModule.DesignOffset.X; NewTop:=CurDataModule.DesignOffset.Y; NewWidth:=CurDataModule.DesignSize.X; NewHeight:=CurDataModule.DesignSize.Y; - SetBounds(NewLeft,NewTop,NewWidth,NewHeight); + + SetNewBounds(NewLeft,NewTop,NewWidth,NewHeight); + end else if LookupRoot<>nil then begin + NewLeft:=LongRec(LookupRoot.DesignInfo).Lo; + NewTop:=LongRec(LookupRoot.DesignInfo).Hi; + SetNewBounds(NewLeft,NewTop,Width,Height); end; end; -procedure TDataModuleForm.DoSaveBounds; -var - CurDataModule: TDataModule; +procedure TNonFormDesignerForm.DoSaveBounds; begin - CurDataModule:=DataModule; - if CurDataModule<>nil then begin - CurDataModule.DesignOffset.X:=Left; - CurDataModule.DesignOffset.Y:=Top; - CurDataModule.DesignSize.X:=Width; - CurDataModule.DesignSize.Y:=Height; + if LookupRoot is TDataModule then begin + with TDataModule(LookupRoot) do begin + DesignOffset:=Point(Left,Top); + DesignSize:=Point(Width,Height); + //debugln('TNonFormDesignerForm.DoSaveBounds (TDataModule) ',dbgsName(LookupRoot),' ',dbgs(DesignOffset.X),',',dbgs(DesignOffset.Y)); + end; + end else if LookupRoot<>nil then begin + //debugln('TNonFormDesignerForm.DoSaveBounds ',dbgsName(LookupRoot),' ',dbgs(Left),',',dbgs(Top)); + LongRec(LookupRoot.DesignInfo).Lo:=Left; + LongRec(LookupRoot.DesignInfo).Hi:=Top; end; - inherited DoSaveBounds; + if Assigned(OnSaveBounds) then OnSaveBounds(Self); end; end. diff --git a/ide/customformeditor.pp b/ide/customformeditor.pp index 739d536b23..e21cdf1e0b 100644 --- a/ide/customformeditor.pp +++ b/ide/customformeditor.pp @@ -123,7 +123,7 @@ each control that's dropped onto the form FDefineProperties: TAVLTree; function GetPropertyEditorHook: TPropertyEditorHook; protected - FNonControlForms: TAVLTree; // tree of TNonControlForm sorted for LookupRoot + FNonControlForms: TAVLTree; // tree of TNonFormDesignerForm sorted for LookupRoot procedure SetSelection(const ASelection: TPersistentSelectionList); procedure OnObjectInspectorModified(Sender: TObject); procedure SetObj_Inspector(AnObjectInspector: TObjectInspector); virtual; @@ -137,7 +137,7 @@ each control that's dropped onto the form function FindNonControlFormNode(LookupRoot: TComponent): TAVLTreeNode; public JITFormList: TJITForms;// designed forms - JITDataModuleList: TJITDataModules;// designed data modules + JITNonFormList: TJITNonFormComponents;// designed data modules constructor Create; destructor Destroy; override; @@ -165,8 +165,8 @@ each control that's dropped onto the form function FindJITListByClassName(const AComponentClassName: string ): TJITComponentList; function GetDesignerForm(AComponent: TComponent): TCustomForm; override; - function FindNonControlForm(LookupRoot: TComponent): TNonControlForm; - function CreateNonControlForm(LookupRoot: TComponent): TNonControlForm; + function FindNonControlForm(LookupRoot: TComponent): TNonFormDesignerForm; + function CreateNonControlForm(LookupRoot: TComponent): TNonFormDesignerForm; procedure RenameJITComponent(AComponent: TComponent; const NewName: shortstring); procedure UpdateDesignerFormName(AComponent: TComponent); @@ -198,6 +198,7 @@ each control that's dropped onto the form X,Y,W,H : Integer): TIComponentInterface; override; Function CreateComponentFromStream(BinStream: TStream; AncestorType: TComponentClass; + const NewUnitName: ShortString; Interactive: boolean): TIComponentInterface; override; Function CreateChildComponentFromStream(BinStream: TStream; ComponentClass: TComponentClass; Root: TComponent; @@ -747,9 +748,9 @@ begin JITFormList.OnReaderError:=@JITListReaderError; JITFormList.OnPropertyNotFound:=@JITListPropertyNotFound; - JITDataModuleList := TJITDataModules.Create; - JITDataModuleList.OnReaderError:=@JITListReaderError; - JITDataModuleList.OnPropertyNotFound:=@JITListPropertyNotFound; + JITNonFormList := TJITNonFormComponents.Create; + JITNonFormList.OnReaderError:=@JITListReaderError; + JITNonFormList.OnPropertyNotFound:=@JITListPropertyNotFound; DesignerMenuItemClick:=@OnDesignerMenuItemClick; OnGetDesignerForm:=@GetDesignerForm; @@ -765,7 +766,7 @@ begin FreeAndNil(FDefineProperties); end; FreeAndNil(JITFormList); - FreeAndNil(JITDataModuleList); + FreeAndNil(JITNonFormList); FreeAndNil(FComponentInterfaces); FreeAndNil(FSelection); FreeAndNil(FNonControlForms); @@ -818,15 +819,15 @@ Begin if JITFormList.IsJITForm(AComponent) then // free a form component JITFormList.DestroyJITComponent(AComponent) - else if JITDataModuleList.IsJITDataModule(AComponent) then begin - // free a datamodule and its designer form + else if JITNonFormList.IsJITNonForm(AComponent) then begin + // free a non form component and its designer form AForm:=GetDesignerForm(AComponent); - if not (AForm is TNonControlForm) then - RaiseException('TCustomFormEditor.DeleteControl Where is the TNonControlForm? '+AComponent.ClassName); + if not (AForm is TNonFormDesignerForm) then + RaiseException('TCustomFormEditor.DeleteControl Where is the TNonFormDesignerForm? '+AComponent.ClassName); FNonControlForms.Remove(AForm); - TNonControlForm(AForm).LookupRoot:=nil; + TNonFormDesignerForm(AForm).LookupRoot:=nil; AForm.Free; - JITDataModuleList.DestroyJITComponent(AComponent); + JITNonFormList.DestroyJITComponent(AComponent); end else RaiseException('TCustomFormEditor.DeleteControl '+AComponent.ClassName); end; @@ -993,7 +994,7 @@ end; function TCustomFormEditor.IsJITComponent(AComponent: TComponent): boolean; begin Result:=JITFormList.IsJITForm(AComponent) - or JITDataModuleList.IsJITDataModule(AComponent); + or JITNonFormList.IsJITNonForm(AComponent); end; function TCustomFormEditor.GetJITListOfType(AncestorType: TComponentClass @@ -1001,8 +1002,8 @@ function TCustomFormEditor.GetJITListOfType(AncestorType: TComponentClass begin if AncestorType.InheritsFrom(TForm) then Result:=JITFormList - else if AncestorType.InheritsFrom(TDataModule) then - Result:=JITDataModuleList + else if AncestorType.InheritsFrom(TComponent) then + Result:=JITNonFormList else Result:=nil; end; @@ -1012,8 +1013,8 @@ function TCustomFormEditor.FindJITList(AComponent: TComponent begin if JITFormList.IndexOf(AComponent)>=0 then Result:=JITFormList - else if JITDataModuleList.IndexOf(AComponent)>=0 then - Result:=JITDataModuleList + else if JITNonFormList.IndexOf(AComponent)>=0 then + Result:=JITNonFormList else Result:=nil; end; @@ -1023,8 +1024,8 @@ function TCustomFormEditor.FindJITListByClassName( begin if JITFormList.FindComponentByClassName(AComponentClassName)>=0 then Result:=JITFormList - else if JITDataModuleList.FindComponentByClassName(AComponentClassName)>=0 then - Result:=JITDataModuleList + else if JITNonFormList.FindComponentByClassName(AComponentClassName)>=0 then + Result:=JITNonFormList else Result:=nil; end; @@ -1045,24 +1046,24 @@ begin end; function TCustomFormEditor.FindNonControlForm(LookupRoot: TComponent - ): TNonControlForm; + ): TNonFormDesignerForm; var AVLNode: TAVLTreeNode; begin AVLNode:=FindNonControlFormNode(LookupRoot); if AVLNode<>nil then - Result:=TNonControlForm(AVLNode.Data) + Result:=TNonFormDesignerForm(AVLNode.Data) else Result:=nil; end; function TCustomFormEditor.CreateNonControlForm(LookupRoot: TComponent - ): TNonControlForm; + ): TNonFormDesignerForm; begin if FindNonControlFormNode(LookupRoot)<>nil then RaiseException('TCustomFormEditor.CreateNonControlForm exists already'); - if LookupRoot is TDataModule then begin - Result:=TDataModuleForm.Create(nil); + if LookupRoot is TComponent then begin + Result:=TNonFormDesignerForm.Create(nil); Result.LookupRoot:=LookupRoot; FNonControlForms.Add(Result); end else @@ -1083,7 +1084,7 @@ end; procedure TCustomFormEditor.UpdateDesignerFormName(AComponent: TComponent); var - ANonControlForm: TNonControlForm; + ANonControlForm: TNonFormDesignerForm; begin ANonControlForm:=FindNonControlForm(AComponent); DebugLn('TCustomFormEditor.UpdateDesignerFormName ', @@ -1117,7 +1118,7 @@ end; procedure TCustomFormEditor.SaveHiddenDesignerFormProperties( AComponent: TComponent); var - NonControlForm: TNonControlForm; + NonControlForm: TNonFormDesignerForm; begin NonControlForm:=FindNonControlForm(AComponent); if NonControlForm<>nil then @@ -1140,7 +1141,7 @@ end; function TCustomFormEditor.DesignerCount: integer; begin - Result:=JITFormList.Count+JITDataModuleList.Count; + Result:=JITFormList.Count+JITNonFormList.Count; end; function TCustomFormEditor.GetDesigner(Index: integer): TIDesigner; @@ -1150,7 +1151,7 @@ begin if Index a form or a datamodule + // create a toplevel component + // -> a form or a datamodule or a custom component ParentComponent:=nil; JITList:=GetJITListOfType(TypeClass); if JITList=nil then RaiseException('TCustomFormEditor.CreateComponent '+TypeClass.ClassName); - NewJITIndex := JITList.AddNewJITComponent; + NewJITIndex := JITList.AddNewJITComponent(DefaultJITUnitName,TypeClass); if NewJITIndex >= 0 then begin // create component interface Temp := TComponentInterface.Create; @@ -1321,10 +1323,9 @@ Begin CompLeft:=Max(1,Min(250,Screen.Width-CompWidth-50)); if CompTop<0 then CompTop:=Max(1,Min(250,Screen.Height-CompHeight-50)); - DesignOffset.X:=CompLeft; - DesignOffset.Y:=CompTop; - DesignSize.X:=CompWidth; - DesignSize.Y:=CompHeight; + DesignOffset:=Point(CompLeft,CompTop); + DesignSize:=Point(CompWidth,CompHeight); + //debugln('TCustomFormEditor.CreateComponent TDataModule Bounds ',dbgsName(Temp.Component),' ',dbgs(DesignOffset.X),',',dbgs(DesignOffset.Y),' ',HexStr(Cardinal(Temp.Component),8),' ',HexStr(Cardinal(@DesignOffset),8)); end; end else begin @@ -1377,7 +1378,7 @@ end; Function TCustomFormEditor.CreateComponentFromStream( BinStream: TStream; AncestorType: TComponentClass; - Interactive: boolean): TIComponentInterface; + const NewUnitName: ShortString; Interactive: boolean): TIComponentInterface; var NewJITIndex: integer; NewComponent: TComponent; @@ -1388,7 +1389,8 @@ begin if JITList=nil then RaiseException('TCustomFormEditor.CreateComponentFromStream ClassName='+ AncestorType.ClassName); - NewJITIndex := JITList.AddJITComponentFromStream(BinStream,Interactive); + NewJITIndex := JITList.AddJITComponentFromStream(BinStream,AncestorType, + NewUnitName,Interactive); if NewJITIndex < 0 then begin Result:=nil; exit; @@ -1479,12 +1481,13 @@ var APersistentClass: TPersistentClass; begin Result:=false; + // try to find the AClassName in the registered components if APersistent=nil then begin CacheItem.RegisteredComponent:=IDEComponentPalette.FindComponent(AClassname); if (CacheItem.RegisteredComponent<>nil) and (CacheItem.RegisteredComponent.ComponentClass<>nil) then begin - debugln('TCustomFormEditor.GetDefineProperties Component is registered'); + debugln('TCustomFormEditor.GetDefineProperties ComponentClass ',AClassName,' is registered'); if not CreateTempPersistent(CacheItem.RegisteredComponent.ComponentClass) then exit; end; @@ -1494,7 +1497,7 @@ var if APersistent=nil then begin APersistentClass:=Classes.GetClass(AClassName); if APersistentClass<>nil then begin - debugln('TCustomFormEditor.GetDefineProperties Persistent is registered'); + debugln('TCustomFormEditor.GetDefineProperties PersistentClass ',AClassName,' is registered'); if not CreateTempPersistent(APersistentClass) then exit; end; end; @@ -1503,7 +1506,9 @@ var // try to find the AClassName in the open forms/datamodules APersistent:=FindJITComponentByClassName(AClassName); if APersistent<>nil then - debugln('TCustomFormEditor.GetDefineProperties Component is a resource'); + debugln('TCustomFormEditor.GetDefineProperties ComponentClass ', + AClassName,' is a resource,' + +' but inheriting design is not yet implemented'); end; // try default classes diff --git a/ide/editoroptions.pp b/ide/editoroptions.pp index 4ef6490221..dbdbc63c99 100644 --- a/ide/editoroptions.pp +++ b/ide/editoroptions.pp @@ -100,7 +100,8 @@ const ); const - SynEditDefaultOptions = SYNEDIT_DEFAULT_OPTIONS - [eoShowScrollHint]; + SynEditDefaultOptions = SYNEDIT_DEFAULT_OPTIONS - [eoShowScrollHint] + + [eoHalfPageScroll]; type { TEditOptLanguageInfo stores lazarus IDE additional information diff --git a/ide/formeditor.pp b/ide/formeditor.pp index 25e237c5fd..d6e3593e56 100644 --- a/ide/formeditor.pp +++ b/ide/formeditor.pp @@ -82,8 +82,8 @@ begin ADesigner.DrawDesignerItems(true); end; end; - for i:=0 to JITDataModuleList.Count-1 do begin - AForm:=GetDesignerForm(JITDataModuleList[i]); + for i:=0 to JITNonFormList.Count-1 do begin + AForm:=GetDesignerForm(JITNonFormList[i]); if AForm=nil then continue; ADesigner:=TDesigner(AForm.Designer); if ADesigner<>nil then begin diff --git a/ide/main.pp b/ide/main.pp index a0bf5b945a..b28c6163bd 100644 --- a/ide/main.pp +++ b/ide/main.pp @@ -442,7 +442,7 @@ type // methods for start procedure LoadGlobalOptions; procedure SetupMainMenu; override; - procedure SetuptStandardProjectTypes; + procedure SetupStandardProjectTypes; procedure SetRecentFilesMenu; procedure SetRecentProjectFilesMenu; procedure SetupFileMenu; override; @@ -959,7 +959,8 @@ begin ConnectMainBarEvents; // create main IDE register items - SetuptStandardProjectTypes; + NewIDEItems:=TNewIDEItemCategories.Create; + SetupStandardProjectTypes; // initialize the other IDE managers DebugBoss:=TDebugManager.Create(nil); @@ -1042,6 +1043,7 @@ begin FreeThenNil(MacroList); FreeThenNil(LazProjectFileDescriptors); FreeThenNil(LazProjectDescriptors); + FreeThenNil(NewIDEItems); // IDE options objects FreeThenNil(CodeToolsOpts); FreeThenNil(MiscellaneousOptions); @@ -1545,7 +1547,7 @@ begin SetupHelpMenu; end; -procedure TMainIDE.SetuptStandardProjectTypes; +procedure TMainIDE.SetupStandardProjectTypes; var FileDescPascalUnit: TFileDescPascalUnit; FileDescPascalUnitWithForm: TFileDescPascalUnitWithForm; @@ -1555,6 +1557,11 @@ var ProjDescApplication: TProjectApplicationDescriptor; ProjDescProgram: TProjectProgramDescriptor; ProjDescCustomProgram: TProjectManualProgramDescriptor; + i: Integer; + NewItemFile: TNewItemProjectFile; + NewItemProject: TNewItemProject; + FileItem: TProjectFileDescriptor; + ProjectItem: TProjectDescriptor; begin // file descriptors ---------------------------------------------------------- LazProjectFileDescriptors:=TLazProjectFileDescriptors.Create; @@ -1585,6 +1592,25 @@ begin // custom program ProjDescCustomProgram:=TProjectManualProgramDescriptor.Create; LazProjectDescriptors.RegisterDescriptor(ProjDescCustomProgram); + + NewIDEItems.Add(TNewIDEItemCategoryFile.Create('File')); + NewIDEItems.Add(TNewIDEItemCategoryProject.Create('Project')); + + // TODO: move this mechanism to LazProjectFileDescriptors.RegisterFileDescriptor + for i:=0 to LazProjectFileDescriptors.Count-1 do begin + FileItem:=LazProjectFileDescriptors[i]; + if not FileItem.VisibleInNewDialog then continue; + NewItemFile:=TNewItemProjectFile.Create(FileItem.Name,niifCopy,[niifCopy]); + NewItemFile.Descriptor:=FileItem; + RegisterNewDialogItem('File',NewItemFile); + end; + for i:=0 to LazProjectDescriptors.Count-1 do begin + ProjectItem:=LazProjectDescriptors[i]; + if not ProjectItem.VisibleInNewDialog then continue; + NewItemProject:=TNewItemProject.Create(ProjectItem.Name,niifCopy,[niifCopy]); + NewItemProject.Descriptor:=ProjectItem; + RegisterNewDialogItem('Project',NewItemProject); + end; end; procedure TMainIDE.SetRecentFilesMenu; @@ -3858,6 +3884,7 @@ var DesignerForm: TCustomForm; NewClassName: String; NewAncestorName: String; + APersistentClass: TPersistentClass; begin CloseDesignerForm(AnUnitInfo); @@ -3894,12 +3921,23 @@ begin // find the ancestor type in the source NewAncestorName:=''; + AncestorType:=TForm; CodeToolBoss.FindFormAncestor(AnUnitInfo.Source,NewClassName, NewAncestorName,true); - if AnsiCompareText(NewAncestorName,'TDataModule')=0 then - AncestorType:=TDataModule - else - AncestorType:=TForm; + if NewAncestorName<>'' then begin + if AnsiCompareText(NewAncestorName,'TDataModule')=0 then begin + // use our TDataModule + // (some fpc versions have non designable TDataModule) + AncestorType:=TDataModule; + end else begin + APersistentClass:=Classes.GetClass(NewAncestorName); + if (APersistentClass<>nil) + and (APersistentClass.InheritsFrom(TComponent)) then begin + // ancestor type is a registered component class + AncestorType:=TComponentClass(APersistentClass); + end; + end; + end; DebugLn('TMainIDE.DoLoadLFM AncestorClassName=',NewAncestorName,' AncestorType=',AncestorType.ClassName); // convert text to binary format @@ -3932,7 +3970,7 @@ begin // create JIT component CInterface := TComponentInterface( FormEditor1.CreateComponentFromStream(BinLFMStream, - AncestorType,true)); + AncestorType,copy(AnUnitInfo.UnitName,1,255),true)); if CInterface=nil then begin // error streaming component -> examine lfm file DebugLn('ERROR: streaming failed lfm="',LFMBuf.Filename,'"'); @@ -4505,28 +4543,22 @@ end; function TMainIDE.DoNewOther: TModalResult; var - NewIDEItem: TNewIDEItem; + NewIDEItem: TNewIDEItemTemplate; begin Result:=ShowNewIDEItemDialog(NewIDEItem); try if Result<>mrOk then exit; - case NewIDEItem.TheType of - // files - niiText: Result:=DoNewEditorFile(FileDescriptorText,'','', - [nfOpenInEditor,nfCreateDefaultSrc]); - niiUnit: Result:=DoNewEditorFile(FileDescriptorUnit,'','', - [nfOpenInEditor,nfCreateDefaultSrc]); - niiForm: Result:=DoNewEditorFile(FileDescriptorForm,'','', - [nfOpenInEditor,nfCreateDefaultSrc]); - niiDataModule: Result:=DoNewEditorFile(FileDescriptorDatamodule,'','', - [nfOpenInEditor,nfCreateDefaultSrc]); - // projects - niiApplication: DoNewProject(ProjectDescriptorApplication); - niiFPCProject: DoNewProject(ProjectDescriptorProgram); - niiCustomProject: DoNewProject(ProjectDescriptorCustomProgram); - // packages - niiPackage: PkgBoss.DoNewPackage; - else + if NewIDEItem is TNewItemProjectFile then begin + // file + Result:=DoNewEditorFile(TNewItemProjectFile(NewIDEItem).Descriptor, + '','',[nfOpenInEditor,nfCreateDefaultSrc]); + end else if NewIDEItem is TNewItemProject then begin + // project + Result:=DoNewProject(TNewItemProject(NewIDEItem).Descriptor); + end else if NewIDEItem is TNewItemPackage then begin + // packages + PkgBoss.DoNewPackage; + end else begin MessageDlg(ueNotImplCap, lisSorryThisTypeIsNotYetImplemented, mtInformation,[mbOk],0); @@ -10974,6 +11006,9 @@ end. { ============================================================================= $Log$ + Revision 1.794 2004/11/20 11:20:05 mattias + implemented creating classes at run time from any TComponent descendant + Revision 1.793 2004/11/19 12:23:43 vincents fixed WaitForLazarus: close process handle after use. diff --git a/ide/mainintf.pas b/ide/mainintf.pas index 55bce110f3..5ab3878394 100644 --- a/ide/mainintf.pas +++ b/ide/mainintf.pas @@ -440,7 +440,9 @@ end; function TFileDescSimplePascalProgram.GetLocalizedDescription: string; begin - Result:='Custom Program'; + Result:='A simple Pascal Program file.'#13 + +'This can be used for quick and dirty testing.'#13 + +'Better create a new project.'; end; function TFileDescSimplePascalProgram.CreateSource(const Filename, SourceName, diff --git a/ide/newdialog.pas b/ide/newdialog.pas index 0f94f3c722..565a887149 100644 --- a/ide/newdialog.pas +++ b/ide/newdialog.pas @@ -40,24 +40,28 @@ unit NewDialog; interface uses - Classes, SysUtils, Forms, Controls, StdCtrls, Buttons, ComCtrls, - Dialogs, LResources, IDEOptionDefs, LazarusIDEStrConsts; + Classes, SysUtils, LCLProc, Forms, Controls, StdCtrls, Buttons, ComCtrls, + Dialogs, LResources, ProjectIntf, PackageIntf, + IDEOptionDefs, LazarusIDEStrConsts; type // Items that can be created in the IDE: - TNewIDEItemType = ( + {TNewIDEItemType = ( niiNone, niiCustom, // for experts (IDE plugins) + niiUnit, // pascal unit niiForm, // pascal unit with lcl form niiDataModule, // pascal nuit with datamodule niiText, // text file + niiApplication,// Project: Application niiFPCProject, // Project: with hidden main file niiCustomProject,// Project: pascal program without any specials + niiPackage // standard package ); - TNewIDEItemTypes = set of TNewIDEItemType; + TNewIDEItemTypes = set of TNewIDEItemType;} // Flags/Options for the items TNewIDEItemFlag = ( @@ -79,12 +83,15 @@ type function GetCount: integer; function GetItems(Index: integer): TNewIDEItemTemplate; public + constructor Create; constructor Create(const AName: string); destructor Destroy; override; procedure Clear; procedure Add(ATemplate: TNewIDEItemTemplate); - function LocalizedName: string; - function Description: string; + function LocalizedName: string; virtual; + function Description: string; virtual; + function IndexOfCategory(const CategoryName: string): integer; + function FindCategoryByName(const CategoryName: string): TNewIDEItemCategory; public property Count: integer read GetCount; property Items[Index: integer]: TNewIDEItemTemplate read GetItems; default; @@ -100,11 +107,17 @@ type function GetItems(Index: integer): TNewIDEItemCategory; procedure SetItems(Index: integer; const AValue: TNewIDEItemCategory); public - constructor CreateWithDefaults; + constructor Create; destructor Destroy; override; procedure Clear; procedure Add(ACategory: TNewIDEItemCategory); function Count: integer; + function IndexOf(const CategoryName: string): integer; + function FindByName(const CategoryName: string): TNewIDEItemCategory; + procedure RegisterItem(const Paths: string; NewItem: TNewIDEItemTemplate); + procedure UnregisterItem(NewItem: TNewIDEItemTemplate); + function FindCategoryByPath(const Path: string; + ErrorOnNotFound: boolean): TNewIDEItemCategory; public property Items[Index: integer]: TNewIDEItemCategory read GetItems write SetItems; default; @@ -113,47 +126,99 @@ type { TNewIDEItemTemplate } - TNewIDEItemTemplate = class + TNewIDEItemTemplate = class(TPersistent) private FAllowedFlags: TNewIDEItemFlags; FDefaultFlag: TNewIDEItemFlag; FName: string; fCategory: TNewIDEItemCategory; - FTheType: TNewIDEItemType; public - constructor Create(AType: TNewIDEItemType; const AName: string; - ADefaultFlag: TNewIDEItemFlag; + constructor Create(const AName: string; ADefaultFlag: TNewIDEItemFlag; TheAllowedFlags: TNewIDEItemFlags); - function LocalizedName: string; - function Description: string; + function LocalizedName: string; virtual; + function Description: string; virtual; + function CreateCopy: TNewIDEItemTemplate; virtual; + procedure Assign(Source: TPersistent); override; public - property TheType: TNewIDEItemType read FTheType; property DefaultFlag: TNewIDEItemFlag read FDefaultFlag; property AllowedFlags: TNewIDEItemFlags read FAllowedFlags; property Name: string read FName; - property Category: TNewIDEItemCategory read fCategory; + property Category: TNewIDEItemCategory read fCategory; // main category end; + TNewIDEItemTemplateClass = class of TNewIDEItemTemplate; - - { TNewIDEItem } + //---------------------------------------------------------------------------- + // standard categories for new dialog - TNewIDEItem = class + { TNewIDEItemCategoryFile } + + TNewIDEItemCategoryFile = class(TNewIDEItemCategory) + public + function LocalizedName: string; override; + function Description: string; override; + end; + + { TNewIDEItemCategoryProject } + + TNewIDEItemCategoryProject = class(TNewIDEItemCategory) + public + function LocalizedName: string; override; + function Description: string; override; + end; + + { TNewIDEItemCategoryPackage } + + TNewIDEItemCategoryPackage = class(TNewIDEItemCategory) + public + function LocalizedName: string; override; + function Description: string; override; + end; + + //---------------------------------------------------------------------------- + // standard items for new dialog + + { TNewItemProjectFile - a new item for project file descriptors } + + TNewItemProjectFile = class(TNewIDEItemTemplate) private - FFlag: TNewIDEItemFlag; - FTheType: TNewIDEItemType; - procedure SetFlag(const AValue: TNewIDEItemFlag); - procedure SetTheType(const AValue: TNewIDEItemType); + FDescriptor: TProjectFileDescriptor; public - constructor Create; - procedure Assign(Source: TNewIDEItem); - procedure Assign(Source: TNewIDEItemTemplate); - function CreateCopy: TNewIDEItem; + function LocalizedName: string; override; + function Description: string; override; + procedure Assign(Source: TPersistent); override; public - property TheType: TNewIDEItemType read FTheType write SetTheType; - property Flag: TNewIDEItemFlag read FFlag write SetFlag; + property Descriptor: TProjectFileDescriptor read FDescriptor write FDescriptor; end; - + { TNewItemProject - a new item for project descriptors } + + TNewItemProject = class(TNewIDEItemTemplate) + private + FDescriptor: TProjectDescriptor; + public + function LocalizedName: string; override; + function Description: string; override; + procedure Assign(Source: TPersistent); override; + public + property Descriptor: TProjectDescriptor read FDescriptor write FDescriptor; + end; + + { TNewItemPackage - a new item for package descriptors } + + TNewItemPackage = class(TNewIDEItemTemplate) + private + FDescriptor: TPackageDescriptor; + public + function LocalizedName: string; override; + function Description: string; override; + procedure Assign(Source: TPersistent); override; + public + property Descriptor: TPackageDescriptor read FDescriptor write FDescriptor; + end; + + //---------------------------------------------------------------------------- + + { TNewOtherDialog } TNewOtherDialog = class(TForm) @@ -167,49 +232,55 @@ type procedure NewOtherDialogResize(Sender: TObject); procedure OkButtonClick(Sender: TObject); private - FItemType: TNewIDEItem; procedure FillItemsTree; procedure SetupComponents; public constructor Create(TheOwner: TComponent); override; destructor Destroy; override; public - property ItemType: TNewIDEItem read FItemType; + function GetNewItem: TNewIDEItemTemplate; end; -function ShowNewIDEItemDialog(var ItemType: TNewIDEItem): TModalResult; -function NewIDEItems: TNewIDEItemCategories; +function ShowNewIDEItemDialog(var NewItem: TNewIDEItemTemplate): TModalResult; + +var + NewIDEItems: TNewIDEItemCategories;// will be set by the IDE + + +procedure RegisterNewDialogItem(const Paths: string; + NewItem: TNewIDEItemTemplate); +procedure UnregisterNewDialogItem(NewItem: TNewIDEItemTemplate); implementation -var - InternalNewIDEItems: TNewIDEItemCategories; -function ShowNewIDEItemDialog(var ItemType: TNewIDEItem): TModalResult; +function ShowNewIDEItemDialog(var NewItem: TNewIDEItemTemplate): TModalResult; var NewOtherDialog: TNewOtherDialog; begin - ItemType:=nil; + NewItem:=nil; NewOtherDialog:=TNewOtherDialog.Create(Application); Result:=NewOtherDialog.ShowModal; if Result=mrOk then begin - ItemType:=NewOtherDialog.ItemType.CreateCopy; + NewItem:=NewOtherDialog.GetNewItem; end; IDEDialogLayoutList.SaveLayout(NewOtherDialog); NewOtherDialog.Free; end; -function NewIDEItems: TNewIDEItemCategories; +procedure RegisterNewDialogItem(const Paths: string; + NewItem: TNewIDEItemTemplate); begin - if InternalNewIDEItems=nil then - InternalNewIDEItems:=TNewIDEItemCategories.CreateWithDefaults; - Result:=InternalNewIDEItems; + if NewIDEItems=nil then + raise Exception.Create('RegisterNewDialogItem NewIDEItems=nil'); + NewIDEItems.RegisterItem(Paths,NewItem); end; -procedure InternalFinal; +procedure UnregisterNewDialogItem(NewItem: TNewIDEItemTemplate); begin - InternalNewIDEItems.Free; - InternalNewIDEItems:=nil; + if NewIDEItems=nil then + raise Exception.Create('RegisterNewDialogItem NewIDEItems=nil'); + NewIDEItems.UnregisterItem(NewItem); end; { TNewOtherDialog } @@ -241,7 +312,6 @@ end; procedure TNewOtherDialog.OkButtonClick(Sender: TObject); var ANode: TTreeNode; - Template: TNewIDEItemTemplate; begin ANode:=ItemsTreeView.Selected; if (ANode=nil) or (ANode.Data=nil) @@ -251,8 +321,6 @@ begin lisNewDlgPleaseSelectAnItemFirst, mtInformation, [mbOk], 0); exit; end; - Template:=TNewIDEItemTemplate(ANode.Data); - FItemType.Assign(Template); ModalResult:=mrOk; end; @@ -265,6 +333,7 @@ var TemplateID: Integer; Template: TNewIDEItemTemplate; begin + ItemsTreeView.BeginUpdate; ItemsTreeView.Items.Clear; for CategoryID:=0 to NewIDEItems.Count-1 do begin Category:=NewIDEItems[CategoryID]; @@ -275,6 +344,7 @@ begin end; NewParentNode.Expand(true); end; + ItemsTreeView.EndUpdate; end; procedure TNewOtherDialog.CancelButtonClick(Sender: TObject); @@ -352,10 +422,9 @@ end; constructor TNewOtherDialog.Create(TheOwner: TComponent); begin inherited Create(TheOwner); - FItemType:=TNewIDEItem.Create; if LazarusResources.Find(Classname)=nil then begin Name:='NewOtherDialog'; - Caption := 'New ...'; + Caption := lisMenuNewOther; Width:=400; Height:=300; Position:=poScreenCenter; @@ -369,46 +438,18 @@ end; destructor TNewOtherDialog.Destroy; begin - FItemType.Free; inherited Destroy; end; -{ TNewIDEItem } - -procedure TNewIDEItem.SetTheType(const AValue: TNewIDEItemType); +function TNewOtherDialog.GetNewItem: TNewIDEItemTemplate; +var + ANode: TTreeNode; begin - if FTheType=AValue then exit; - FTheType:=AValue; -end; - -constructor TNewIDEItem.Create; -begin - FTheType:=niiNone; - FFlag:=niifCopy; -end; - -procedure TNewIDEItem.SetFlag(const AValue: TNewIDEItemFlag); -begin - if FFlag=AValue then exit; - FFlag:=AValue; -end; - -procedure TNewIDEItem.Assign(Source: TNewIDEItem); -begin - TheType:=Source.TheType; - Flag:=Source.Flag; -end; - -procedure TNewIDEItem.Assign(Source: TNewIDEItemTemplate); -begin - TheType:=Source.TheType; - Flag:=Source.DefaultFlag; -end; - -function TNewIDEItem.CreateCopy: TNewIDEItem; -begin - Result:=TNewIDEItem.Create; - Result.Assign(Self); + ANode:=ItemsTreeView.Selected; + if (ANode=nil) or (ANode.Data=nil) + or (not (TObject(ANode.Data) is TNewIDEItemTemplate)) + then exit; + Result:=TNewIDEItemTemplate(ANode.Data).CreateCopy; end; { TNewIDEItemCategory } @@ -423,10 +464,16 @@ begin Result:=TNewIDEItemTemplate(FItems[Index]); end; +constructor TNewIDEItemCategory.Create; +begin + raise Exception.Create('TNewIDEItemCategory.Create: call Create(Name) instead'); +end; + constructor TNewIDEItemCategory.Create(const AName: string); begin FItems:=TList.Create; FName:=AName; + //debugln('TNewIDEItemCategory.Create ',Name); end; destructor TNewIDEItemCategory.Destroy; @@ -446,6 +493,7 @@ end; procedure TNewIDEItemCategory.Add(ATemplate: TNewIDEItemTemplate); begin + //debugln('TNewIDEItemCategory.Add ',Name); FItems.Add(ATemplate); ATemplate.fCategory:=Self; end; @@ -466,13 +514,30 @@ begin Result:=''; end; +function TNewIDEItemCategory.IndexOfCategory(const CategoryName: string + ): integer; +begin + // TODO + Result:=-1; +end; + +function TNewIDEItemCategory.FindCategoryByName(const CategoryName: string + ): TNewIDEItemCategory; +var + i: LongInt; +begin + i:=IndexOfCategory(CategoryName); + if i>=0 then + Result:=nil // TODO + else + Result:=nil; +end; + { TNewIDEItemTemplate } -constructor TNewIDEItemTemplate.Create(AType: TNewIDEItemType; - const AName: string; ADefaultFlag: TNewIDEItemFlag; - TheAllowedFlags: TNewIDEItemFlags); +constructor TNewIDEItemTemplate.Create(const AName: string; + ADefaultFlag: TNewIDEItemFlag; TheAllowedFlags: TNewIDEItemFlags); begin - FTheType:=AType; FName:=AName; FDefaultFlag:=ADefaultFlag; FAllowedFlags:=TheAllowedFlags; @@ -481,49 +546,32 @@ end; function TNewIDEItemTemplate.LocalizedName: string; begin - // ToDo: translate Result:=Name; end; function TNewIDEItemTemplate.Description: string; begin - case TheType of - niiNone: - Result:=''; - - niiCustom: - Result:=''; - - niiUnit: - Result:=lisNewDlgCreateANewPascalUnit; - - niiForm: - Result:=lisNewDlgCreateANewUnitWithALCLForm; + Result:=''; +end; - niiDataModule: - Result:=lisNewDlgCreateANewUnitWithADataModule; +function TNewIDEItemTemplate.CreateCopy: TNewIDEItemTemplate; +begin + Result:=TNewIDEItemTemplateClass(ClassType).Create( + Name,DefaultFlag,AllowedFlags); + Result.Assign(Self); +end; - niiText: - Result:=lisNewDlgCreateANewEmptyTextFile; - - niiApplication: - Result:=Format( - lisNewDlgCreateANewGraphicalApplication, [#13#13]); - - niiFPCProject: - Result:=Format( - lisNewDlgCreateANewProgram, [#13#13]); - - niiCustomProject: - Result:=lisNewDlgCreateANewCustomProgram; - - niiPackage: - Result:=Format( - lisNewDlgCreateANewStandardPackageAPackageIsACollectionOfUn, [#13#13]); - - else - Result:='' - end; +procedure TNewIDEItemTemplate.Assign(Source: TPersistent); +var + Src: TNewIDEItemTemplate; +begin + if Source is TNewIDEItemTemplate then begin + Src:=TNewIDEItemTemplate(Source); + FName:=Src.Name; + FDefaultFlag:=Src.DefaultFlag; + FAllowedFlags:=Src.AllowedFlags; + end else + inherited Assign(Source); end; { TNewIDEItemCategories } @@ -539,36 +587,9 @@ begin FItems[Index]:=AValue; end; -constructor TNewIDEItemCategories.CreateWithDefaults; -var - NewCategory: TNewIDEItemCategory; +constructor TNewIDEItemCategories.Create; begin FItems:=TList.Create; - - // category file - NewCategory:=TNewIDEItemCategory.Create('File'); - Add(NewCategory); - NewCategory.Add(TNewIDEItemTemplate.Create(niiUnit,'Unit',niifCopy,[])); - NewCategory.Add(TNewIDEItemTemplate.Create(niiForm,'Form',niifCopy,[])); - NewCategory.Add(TNewIDEItemTemplate.Create(niiDataModule,'Data Module', - niifCopy,[])); - NewCategory.Add(TNewIDEItemTemplate.Create(niiText,'Text',niifCopy,[])); - - // category project - NewCategory:=TNewIDEItemCategory.Create('Project'); - Add(NewCategory); - NewCategory.Add( - TNewIDEItemTemplate.Create(niiApplication,'Application',niifCopy,[])); - NewCategory.Add( - TNewIDEItemTemplate.Create(niiFPCProject,'FPC Project',niifCopy,[])); - NewCategory.Add( - TNewIDEItemTemplate.Create(niiCustomProject,'Custom Project',niifCopy,[])); - - // category package - NewCategory:=TNewIDEItemCategory.Create('Package'); - Add(NewCategory); - NewCategory.Add( - TNewIDEItemTemplate.Create(niiPackage,'Standard Package',niifCopy,[])); end; destructor TNewIDEItemCategories.Destroy; @@ -596,8 +617,187 @@ begin Result:=FItems.Count; end; -finalization - InternalFinal; +function TNewIDEItemCategories.IndexOf(const CategoryName: string): integer; +begin + Result:=Count-1; + while (Result>=0) and (AnsiCompareText(CategoryName,Items[Result].Name)<>0) do + dec(Result); +end; + +function TNewIDEItemCategories.FindByName(const CategoryName: string + ): TNewIDEItemCategory; +var + i: LongInt; +begin + i:=IndexOf(CategoryName); + if i>=0 then + Result:=Items[i] + else + Result:=nil; +end; + +procedure TNewIDEItemCategories.RegisterItem(const Paths: string; + NewItem: TNewIDEItemTemplate); + + procedure AddToPath(const Path: string); + var + CurCategory: TNewIDEItemCategory; + begin + CurCategory:=FindCategoryByPath(Path,true); + CurCategory.Add(NewItem); + end; + +var + StartPos: Integer; + EndPos: Integer; + Path: String; +begin + // go through all paths + EndPos:=1; + while EndPos<=length(Paths) do begin + StartPos:=EndPos; + while (StartPos<=length(Paths)) and (Paths[StartPos]=';') do + inc(StartPos); + EndPos:=StartPos; + while (EndPos<=length(Paths)) and (Paths[EndPos]<>';') do + inc(EndPos); + if EndPos>StartPos then begin + Path:=copy(Paths,StartPos,EndPos-StartPos); + AddToPath(Path); + end; + end; +end; + +procedure TNewIDEItemCategories.UnregisterItem(NewItem: TNewIDEItemTemplate); +begin + raise Exception.Create('TODO TNewIDEItemCategories.UnregisterItem'); +end; + +function TNewIDEItemCategories.FindCategoryByPath(const Path: string; + ErrorOnNotFound: boolean): TNewIDEItemCategory; +var + StartPos: Integer; + EndPos: Integer; + CategoryName: String; +begin + Result:=nil; + EndPos:=1; + while EndPos<=length(Path) do begin + StartPos:=EndPos; + while (StartPos<=length(Path)) and (Path[StartPos]='/') do + inc(StartPos); + EndPos:=StartPos; + while (EndPos<=length(Path)) and (Path[EndPos]<>'/') do + inc(EndPos); + if EndPos>StartPos then begin + CategoryName:=copy(Path,StartPos,EndPos-StartPos); + if Result=nil then + Result:=FindByName(CategoryName) + else + Result:=Result.FindCategoryByName(CategoryName); + if (Result=nil) then begin + if ErrorOnNotFound then + raise Exception.Create( + 'Unknown category: '+CategoryName+' in Path '+Path) + else + exit; + end; + end; + end; +end; + +{ TNewItemProjectFile } + +function TNewItemProjectFile.LocalizedName: string; +begin + Result:=Descriptor.GetLocalizedName; +end; + +function TNewItemProjectFile.Description: string; +begin + Result:=Descriptor.GetLocalizedDescription; +end; + +procedure TNewItemProjectFile.Assign(Source: TPersistent); +begin + inherited Assign(Source); + if Source is TNewItemProjectFile then + FDescriptor:=TNewItemProjectFile(Source).Descriptor; +end; + +{ TNewItemProject } + +function TNewItemProject.LocalizedName: string; +begin + Result:=Descriptor.GetLocalizedName; +end; + +function TNewItemProject.Description: string; +begin + Result:=Descriptor.GetLocalizedDescription; +end; + +procedure TNewItemProject.Assign(Source: TPersistent); +begin + inherited Assign(Source); + if Source is TNewItemProject then + FDescriptor:=TNewItemProject(Source).Descriptor; +end; + +{ TNewItemPackage } + +function TNewItemPackage.LocalizedName: string; +begin + Result:=Descriptor.GetLocalizedName; +end; + +function TNewItemPackage.Description: string; +begin + Result:=Descriptor.GetLocalizedDescription; +end; + +procedure TNewItemPackage.Assign(Source: TPersistent); +begin + inherited Assign(Source); + if Source is TNewItemPackage then + FDescriptor:=TNewItemPackage(Source).Descriptor; +end; + +{ TNewIDEItemCategoryFile } + +function TNewIDEItemCategoryFile.LocalizedName: string; +begin + Result:='File'; +end; + +function TNewIDEItemCategoryFile.Description: string; +begin + Result:='Choose one of these items to create a new File'; +end; + +{ TNewIDEItemCategoryProject } + +function TNewIDEItemCategoryProject.LocalizedName: string; +begin + Result:='Project'; +end; + +function TNewIDEItemCategoryProject.Description: string; +begin + Result:='Choose one of these items to create a new Project'; +end; + +{ TNewIDEItemCategoryPackage } + +function TNewIDEItemCategoryPackage.LocalizedName: string; +begin + Result:='Package'; +end; + +function TNewIDEItemCategoryPackage.Description: string; +begin + Result:='Choose one of these items to create a new Package'; +end; end. diff --git a/ide/project.pp b/ide/project.pp index eaf36e1c03..3d96a9390f 100644 --- a/ide/project.pp +++ b/ide/project.pp @@ -86,7 +86,7 @@ type this attribute contains the component name, even if the unit is not loaded, or the designer form is not created. - A component can be a TForm or a TDataModule } + A component can be for example a TForm or a TDataModule } fComponentResourceName: string; FComponentLastBinStreamSize: TStreamSeekType; FComponentLastLFMStreamSize: TStreamSeekType; @@ -3130,6 +3130,9 @@ end. { $Log$ + Revision 1.170 2004/11/20 11:20:05 mattias + implemented creating classes at run time from any TComponent descendant + Revision 1.169 2004/10/12 08:23:20 mattias fixed compiler options interface double variables diff --git a/ide/projectdefs.pas b/ide/projectdefs.pas index 34e341075e..14fc912dda 100644 --- a/ide/projectdefs.pas +++ b/ide/projectdefs.pas @@ -83,6 +83,7 @@ type procedure RegisterFileDescriptor(FileDescriptor: TProjectFileDescriptor); override; procedure UnregisterFileDescriptor(FileDescriptor: TProjectFileDescriptor); override; procedure UpdateDefaultPascalFileExtensions; + public property DefaultPascalFileExt: string read FDefaultPascalFileExt write SetDefaultPascalFileExt; end; diff --git a/ideintf/formeditingintf.pas b/ideintf/formeditingintf.pas index 6ac3427479..d5daa1eb4a 100644 --- a/ideintf/formeditingintf.pas +++ b/ideintf/formeditingintf.pas @@ -91,8 +91,9 @@ type TypeClass : TComponentClass; X,Y,W,H : Integer): TIComponentInterface; virtual; abstract; Function CreateComponentFromStream(BinStream: TStream; - AncestorType: TComponentClass; Interactive: boolean - ): TIComponentInterface; virtual; abstract; + AncestorType: TComponentClass; + const NewUnitName: ShortString; + Interactive: boolean): TIComponentInterface; virtual; abstract; Function CreateChildComponentFromStream(BinStream: TStream; ComponentClass: TComponentClass; Root: TComponent; diff --git a/ideintf/packageintf.pas b/ideintf/packageintf.pas index f4d2da3162..4d9bb4806f 100644 --- a/ideintf/packageintf.pas +++ b/ideintf/packageintf.pas @@ -40,7 +40,12 @@ interface uses Classes, SysUtils, Forms; +const + PkgDescNameStandard = 'Standard Package'; + type + { TPackageEditingInterface } + TPackageEditingInterface = class(TComponent) public function AddUnitDependenciesForComponentClasses(const UnitFilename: string; @@ -53,8 +58,96 @@ type var PackageEditingInterface: TPackageEditingInterface; // will be set by the IDE + +type + { TPackageDescriptor } + + TPackageDescriptor = class(TPersistent) + private + FName: string; + FReferenceCount: integer; + FVisibleInNewDialog: boolean; + protected + procedure SetName(const AValue: string); virtual; + public + constructor Create; virtual; + function GetLocalizedName: string; virtual; + function GetLocalizedDescription: string; virtual; + procedure Release; + procedure Reference; + // TODO: procedure InitPackage(APackage: TLazPackage); virtual; + // TODO: procedure CreateStartFiles(APackage: TLazPackage); virtual; + public + property Name: string read FName write SetName; + property VisibleInNewDialog: boolean read FVisibleInNewDialog write FVisibleInNewDialog; + end; + + { TPackageDescriptors } + + TPackageDescriptors = class(TPersistent) + protected + function GetItems(Index: integer): TPackageDescriptor; virtual; abstract; + public + function Count: integer; virtual; abstract; + function GetUniqueName(const Name: string): string; virtual; abstract; + function IndexOf(const Name: string): integer; virtual; abstract; + function FindByName(const Name: string): TPackageDescriptor; virtual; abstract; + procedure RegisterDescriptor(Descriptor: TPackageDescriptor); virtual; abstract; + procedure UnregisterDescriptor(Descriptor: TPackageDescriptor); virtual; abstract; + public + property Items[Index: integer]: TPackageDescriptor read GetItems; default; + end; + +var + PackageDescriptors: TPackageDescriptors; // will be set by the IDE + +function PackageDescriptorStd: TPackageDescriptor; + implementation +function PackageDescriptorStd: TPackageDescriptor; +begin + Result:=PackageDescriptors.FindByName(PkgDescNameStandard); +end; + +{ TPackageDescriptor } + +procedure TPackageDescriptor.SetName(const AValue: string); +begin + if FName=AValue then exit; + FName:=AValue; +end; + +constructor TPackageDescriptor.Create; +begin + FReferenceCount:=1; + fVisibleInNewDialog:=true; +end; + +function TPackageDescriptor.GetLocalizedName: string; +begin + Result:=Name; +end; + +function TPackageDescriptor.GetLocalizedDescription: string; +begin + Result:=GetLocalizedName; +end; + +procedure TPackageDescriptor.Release; +begin + //debugln('TPackageDescriptor.Release A ',Name,' ',dbgs(FReferenceCount)); + if FReferenceCount=0 then + raise Exception.Create(''); + dec(FReferenceCount); + if FReferenceCount=0 then Free; +end; + +procedure TPackageDescriptor.Reference; +begin + inc(FReferenceCount); +end; + initialization PackageEditingInterface:=nil; diff --git a/ideintf/projectintf.pas b/ideintf/projectintf.pas index 936b95ae02..2656971b8a 100644 --- a/ideintf/projectintf.pas +++ b/ideintf/projectintf.pas @@ -244,6 +244,7 @@ type property ConfigFilePath: String read fConfigFilePath write fConfigFilePath; property CustomOptions: string read fCustomOptions write SetCustomOptions; end; + { TLazProjectFile } @@ -261,6 +262,7 @@ type write SetIsPartOfProject; property Filename: string read GetFilename; end; + { TProjectFileDescriptor } @@ -370,7 +372,7 @@ function FileDescriptorText: TProjectFileDescriptor; type TLazProject = class; - { TProjectDescriptor } + { TProjectDescriptor - Template for initializing new projects } TProjectFlag = ( pfSaveClosedUnits, // save info about closed files (not part of project) @@ -409,7 +411,7 @@ type end; - { TLazProject } + { TLazProject - interface class to a Lazarus project } TLazProject = class(TPersistent) private @@ -492,6 +494,7 @@ function ProjectFlagsToStr(Flags: TProjectFlags): string; implementation + function FileDescriptorUnit: TProjectFileDescriptor; begin Result:=ProjectFileDescriptors.FindByName(FileDescNamePascalUnit); @@ -600,6 +603,7 @@ begin FReferenceCount:=1; DefaultResFileExt:='.lrs'; AddToProject:=true; + VisibleInNewDialog:=true; end; function TProjectFileDescriptor.GetLocalizedName: string; diff --git a/lcl/forms.pp b/lcl/forms.pp index 2d207c1200..05c8a59f5c 100644 --- a/lcl/forms.pp +++ b/lcl/forms.pp @@ -430,8 +430,6 @@ type procedure UpdateShowing; override; procedure DoFirstShow; virtual; procedure UpdateWindowState; - procedure ValidateRename(AComponent: TComponent; - const CurName, NewName: string); override; procedure VisibleChanging; override; procedure WndProc(var TheMessage : TLMessage); override; function VisibleIsStored: boolean; diff --git a/lcl/graphics.pp b/lcl/graphics.pp index 60f6e4d59b..2b4b7e7dc1 100644 --- a/lcl/graphics.pp +++ b/lcl/graphics.pp @@ -52,11 +52,11 @@ type TFontPitch = (fpDefault, fpVariable, fpFixed); TFontName = string; - TFontCharSet = 0..255; TFontDataName = string[LF_FACESIZE -1]; TFontStyle = (fsBold, fsItalic, fsStrikeOut, fsUnderline); TFontStyles = set of TFontStyle; TFontStylesbase = set of TFontStyle; + TFontCharSet = 0..255; TFontData = record Handle: HFont; @@ -67,6 +67,21 @@ type Name: TFontDataName; end; +const + // New TFont instances are initialized with the values in this structure. + // About font default values: The default font is chosen by the interfaces + // depending on the context. For example, there can be a different default + // font for a button and a groupbox. + DefFontData: TFontData = ( + Handle: 0; + Height: 0; + Pitch: fpDefault; + Style: []; + Charset: DEFAULT_CHARSET; + Name: 'default' + ); + +type { Reflects text style when drawn in a rectangle } TTextLayout = (tlTop, tlCenter, tlBottom); @@ -340,21 +355,6 @@ const cmWhiteness = WHITENESS; -const - // New TFont instances are initialized with the values in this structure. - // About font default values: The default font is chosen by the interfaces - // depending on the context. For example, there can be a different default - // font for a button and a groupbox. - DefFontData: TFontData = ( - Handle: 0; - Height: 0; - Pitch: fpDefault; - Style: []; - Charset: DEFAULT_CHARSET; - Name: 'default' - ); - - type TCanvas = class; @@ -376,7 +376,7 @@ type private FOnChanging: TNotifyEvent; FOnChange: TNotifyEvent; - Procedure DoChange(var msg); message LM_CHANGED; + Procedure DoChange(var Msg); message LM_CHANGED; protected procedure Changing; dynamic; procedure Changed; dynamic; @@ -1784,6 +1784,9 @@ end. { ============================================================================= $Log$ + Revision 1.161 2004/11/20 11:20:06 mattias + implemented creating classes at run time from any TComponent descendant + Revision 1.160 2004/11/10 18:23:56 mattias impementing changing a TLabel.Font properties Size, Height, Name, Style - set only at Handle creation time diff --git a/lcl/include/customform.inc b/lcl/include/customform.inc index 93d75e3b47..7ee55ed665 100644 --- a/lcl/include/customform.inc +++ b/lcl/include/customform.inc @@ -748,19 +748,6 @@ Begin FDesigner := Value; end; -{------------------------------------------------------------------------------ - TCustomForm ValidateRename - - if AComponent is nil, then the name of Self is changed -------------------------------------------------------------------------------} -procedure TCustomForm.ValidateRename(AComponent: TComponent; - const CurName, NewName: String); -begin - inherited ValidateRename(AComponent, CurName, NewName); - if FDesigner <> nil then - FDesigner.ValidateRename(AComponent, CurName, NewName); -end; - {------------------------------------------------------------------------------ procedure TCustomForm.SetZOrder(Topmost: Boolean); ------------------------------------------------------------------------------} @@ -1833,6 +1820,9 @@ end; { ============================================================================= $Log$ + Revision 1.165 2004/11/20 11:20:06 mattias + implemented creating classes at run time from any TComponent descendant + Revision 1.164 2004/11/10 20:53:18 vincents Destroy menu handle, when destroying form handle. diff --git a/lcl/interfaces/gtk/gtkobject.inc b/lcl/interfaces/gtk/gtkobject.inc index c4affb5103..2bedd19981 100644 --- a/lcl/interfaces/gtk/gtkobject.inc +++ b/lcl/interfaces/gtk/gtkobject.inc @@ -1082,9 +1082,9 @@ begin gtk_label_set_text(ALabel, PChar(Caption)); -{$ifdef gtk1} + {$ifdef gtk1} gtk_label_set_pattern(ALabel, PChar(Pattern)); -{$endif gtk1} + {$endif gtk1} if AComponent = nil then Exit; if ASignalWidget = nil then Exit; @@ -6324,9 +6324,33 @@ const var UseFont : PGDKFont; UnRef : Boolean; + Width: LongInt; + + {procedure UseWidthHeuristic; + var + i: Integer; + l: Integer; + lBearing: LongInt; + rBearing: LongInt; + tmAscent: Longint; + tmDescent: Longint; + CurWidth: integer; + PC: PGdkWChar; + begin + l:=length(TestString[false]); + for i:=1 to l do begin + PC:=PGdkWChar(@TestString[true][i*2-1]); + gdk_text_extents_wc(UseFont, PC, + 2, @lBearing, @rBearing, @CurWidth, + @tmAscent, @tmDescent); + debugln('UseWidthHeuristic i=',dbgs(i),' lBearing=',dbgs(lBearing), + ' rBearing=',dbgs(rBearing),' CurWidth=',dbgs(CurWidth),' ',HexStr(ord(PC^),8)); + end; + end;} + +var AvgTxtLen: Integer; CachedFont: TGdkFontCacheItem; - width: LongInt; begin with TDeviceContext(DC) do begin if dcfTextMetricsValid in DCFlags then begin @@ -6358,6 +6382,7 @@ begin gdk_text_extents_wc(UseFont, PGdkWChar(TestString[IsDoubleByteChar]), AvgTxtLen*2, @lBearing, @rBearing, @Width, @TextMetric.tmAscent, @TextMetric.tmDescent); + //debugln('TGtkWidgetSet.UpdateDCTextMetric A IsDoubleByteChar=',dbgs(IsDoubleByteChar),' Width=',dbgs(Width),' AvgTxtLen=',dbgs(AvgTxtLen)); TextMetric.tmHeight := gdk_text_height(UseFont, PChar(TestString[IsDoubleByteChar]), AvgTxtLen*2) @@ -6371,6 +6396,7 @@ begin AvgTxtLen) {$IfNDef Win32} + TextMetric.tmdescent div 2{$EndIf}; end; + //if Width'); @@ -1632,8 +1635,16 @@ begin if LoadFont then exit; // try all spacings - Spacing := '*'; - if LoadFont then exit; + if spacing<>'*' then begin + Spacing := '*'; + if LoadFont then exit; + end; + + if charSetCoding<>'*' then begin + charsetCoding := '*'; + charSetRegistry:= '*'; + if LoadFont then exit; + end; if (Foundry<>'*') then begin // try all Families @@ -8729,6 +8740,9 @@ end; { ============================================================================= $Log$ + Revision 1.373 2004/11/20 11:20:06 mattias + implemented creating classes at run time from any TComponent descendant + Revision 1.372 2004/11/10 18:23:56 mattias impementing changing a TLabel.Font properties Size, Height, Name, Style - set only at Handle creation time diff --git a/lcl/interfaces/gtk/gtkwsbuttons.pp b/lcl/interfaces/gtk/gtkwsbuttons.pp index 8264b3c5c9..c5f44f5c19 100644 --- a/lcl/interfaces/gtk/gtkwsbuttons.pp +++ b/lcl/interfaces/gtk/gtkwsbuttons.pp @@ -209,16 +209,16 @@ end; The interiour of TBitBtn is created with a 4X4 table Depending in how the image and label are aligned, only a columns or rows are used (like a 4x1 or 1x4 table). - This wat the table doesn't have to be recreated on changes. + This way the table doesn't have to be recreated on changes. So there are 4 positions 0, 1, 2, 3. Positions 1 and 2 are used for the label and image. - Since this is always the case, spacing can be implenented + Since this is always the case, spacing can be implemented by setting the spacing of row/col 1 To get a margin, a gtkInvisible is needed for bottom and right, so the invisible is always in position 3. -} - -function TGtkWSBitBtn.CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): THandle; +} +function TGtkWSBitBtn.CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): THandle; var BitBtn: TCustomBitBtn; WidgetInfo: PWidgetInfo; @@ -245,7 +245,8 @@ begin gtk_container_add(BitBtnInfo^.AlignWidget, BitBtnInfo^.TableWidget); BitBtnInfo^.LabelWidget := gtk_label_new('bitbtn'); - gtk_table_attach(BitBtnInfo^.TableWidget, BitBtnInfo^.LabelWidget, 2, 3, 0, 4, 0, 0, 0, 0); + gtk_table_attach(BitBtnInfo^.TableWidget, BitBtnInfo^.LabelWidget, + 2, 3, 0, 4, 0, 0, 0, 0); BitBtnInfo^.SpaceWidget := nil; BitBtnInfo^.ImageWidget := nil; @@ -293,12 +294,14 @@ begin // check for image if BitBtnInfo^.ImageWidget = nil then begin - BitBtnInfo^.ImageWidget := gtk_pixmap_new(GDIObject^.GDIPixmapObject, GDIObject^.GDIBitmapMaskObject); + BitBtnInfo^.ImageWidget := + gtk_pixmap_new(GDIObject^.GDIPixmapObject, GDIObject^.GDIBitmapMaskObject); gtk_widget_show(BitBtnInfo^.ImageWidget); UpdateLayout(BitBtnInfo, ABitBtn.Layout, ABitBtn.Margin); end else begin - gtk_pixmap_set(BitBtnInfo^.ImageWidget, GDIObject^.GDIPixmapObject, GDIObject^.GDIBitmapMaskObject); + gtk_pixmap_set(BitBtnInfo^.ImageWidget, GDIObject^.GDIPixmapObject, + GDIObject^.GDIBitmapMaskObject); end; end; @@ -345,7 +348,8 @@ begin gtk_table_set_row_spacing(BitBtnInfo^.TableWidget, 1, AValue); end; -procedure TGtkWSBitBtn.SetText(const AWinControl: TWinControl; const AText: String); +procedure TGtkWSBitBtn.SetText(const AWinControl: TWinControl; + const AText: String); var WidgetInfo: PWidgetInfo; BitBtnInfo: PBitBtnWidgetInfo; @@ -357,10 +361,13 @@ begin BitBtnInfo := WidgetInfo^.UserData; if BitBtnInfo^.LabelWidget = nil then Exit; - GtkWidgetSet.SetLabelCaption(BitBtnInfo^.LabelWidget, AText, AWinControl, WidgetInfo^.CoreWidget, 'clicked'); + //debugln('TGtkWSBitBtn.SetText ',DbgStr(AText)); + GtkWidgetSet.SetLabelCaption(BitBtnInfo^.LabelWidget, AText, AWinControl, + WidgetInfo^.CoreWidget, 'clicked'); end; -procedure TGtkWSBitBtn.UpdateLayout(const AInfo: PBitBtnWidgetInfo; const ALayout: TButtonLayout; const AMargin: Integer); +procedure TGtkWSBitBtn.UpdateLayout(const AInfo: PBitBtnWidgetInfo; + const ALayout: TButtonLayout; const AMargin: Integer); begin if (AInfo^.ImageWidget = nil) and (AMargin < 0) @@ -385,27 +392,37 @@ begin case ALayout of blGlyphLeft: begin if AInfo^.ImageWidget <> nil - then gtk_table_attach(AInfo^.TableWidget, AInfo^.ImageWidget, 1, 2, 1, 3, 0, 0, 0, 0); - gtk_table_attach(AInfo^.TableWidget, AInfo^.LabelWidget, 2, 3, 1, 3, 0, 0, 0, 0); + then gtk_table_attach(AInfo^.TableWidget, AInfo^.ImageWidget, + 1, 2, 1, 3, 0, 0, 0, 0); + gtk_table_attach(AInfo^.TableWidget, AInfo^.LabelWidget, + 2, 3, 1, 3, 0, 0, 0, 0); end; blGlyphRight: begin - gtk_table_attach(AInfo^.TableWidget, AInfo^.LabelWidget, 1, 2, 1, 3, 0, 0, 0, 0); + gtk_table_attach(AInfo^.TableWidget, AInfo^.LabelWidget, + 1, 2, 1, 3, 0, 0, 0, 0); if AInfo^.ImageWidget <> nil - then gtk_table_attach(AInfo^.TableWidget, AInfo^.ImageWidget, 2, 3, 1, 3, 0, 0, 0, 0); + then gtk_table_attach(AInfo^.TableWidget, AInfo^.ImageWidget, + 2, 3, 1, 3, 0, 0, 0, 0); if AInfo^.SpaceWidget <> nil - then gtk_table_attach(AInfo^.TableWidget, AInfo^.SpaceWidget, 3, 4, 1, 3, 0, 0, 0, 0); + then gtk_table_attach(AInfo^.TableWidget, AInfo^.SpaceWidget, + 3, 4, 1, 3, 0, 0, 0, 0); end; blGlyphTop: begin if AInfo^.ImageWidget <> nil - then gtk_table_attach(AInfo^.TableWidget, AInfo^.ImageWidget, 1, 3, 1, 2, 0, 0, 0, 0); - gtk_table_attach(AInfo^.TableWidget, AInfo^.LabelWidget, 1, 3, 2, 3, 0, 0, 0, 0); + then gtk_table_attach(AInfo^.TableWidget, AInfo^.ImageWidget, + 1, 3, 1, 2, 0, 0, 0, 0); + gtk_table_attach(AInfo^.TableWidget, AInfo^.LabelWidget, + 1, 3, 2, 3, 0, 0, 0, 0); end; blGlyphBottom: begin - gtk_table_attach(AInfo^.TableWidget, AInfo^.LabelWidget, 1, 3, 1, 2, 0, 0, 0, 0); + gtk_table_attach(AInfo^.TableWidget, AInfo^.LabelWidget, + 1, 3, 1, 2, 0, 0, 0, 0); if AInfo^.ImageWidget <> nil - then gtk_table_attach(AInfo^.TableWidget, AInfo^.ImageWidget, 1, 3, 2, 3, 0, 0, 0, 0); + then gtk_table_attach(AInfo^.TableWidget, AInfo^.ImageWidget, + 1, 3, 2, 3, 0, 0, 0, 0); if AInfo^.SpaceWidget <> nil - then gtk_table_attach(AInfo^.TableWidget, AInfo^.SpaceWidget, 1, 3, 3, 4, 0, 0, 0, 0); + then gtk_table_attach(AInfo^.TableWidget, AInfo^.SpaceWidget, + 1, 3, 3, 4, 0, 0, 0, 0); end; end; @@ -420,7 +437,8 @@ begin then UpdateMargin(AInfo, ALayout, AMargin) end; -procedure TGtkWSBitBtn.UpdateMargin(const AInfo: PBitBtnWidgetInfo; const ALayout: TButtonLayout; const AMargin: Integer); +procedure TGtkWSBitBtn.UpdateMargin(const AInfo: PBitBtnWidgetInfo; + const ALayout: TButtonLayout; const AMargin: Integer); begin if AMargin < 0 then begin diff --git a/lcl/lclclasses.pp b/lcl/lclclasses.pp index 81ff0c91eb..9dcf6b0cca 100644 --- a/lcl/lclclasses.pp +++ b/lcl/lclclasses.pp @@ -19,6 +19,8 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** + + Defines the base class for all LCL TComponents including controls. } unit LCLClasses; diff --git a/lcl/lcltype.pp b/lcl/lcltype.pp index 42436c50d6..c2f70c0760 100644 --- a/lcl/lcltype.pp +++ b/lcl/lcltype.pp @@ -1170,7 +1170,6 @@ const EASTEUROPE_CHARSET = 238; OEM_CHARSET = 255; - //----------- // Font Sets //----------- @@ -2248,6 +2247,9 @@ end. { $Log$ + Revision 1.68 2004/11/20 11:20:06 mattias + implemented creating classes at run time from any TComponent descendant + Revision 1.67 2004/09/18 10:52:48 micha convert LM_SCREENINIT message to interface method (integrated with TWidgetSet.AppInit(var ScreenInfo) diff --git a/packager/pkgmanager.pas b/packager/pkgmanager.pas index 5c3ffa15c8..a861c8ccc3 100644 --- a/packager/pkgmanager.pas +++ b/packager/pkgmanager.pas @@ -49,14 +49,14 @@ uses // codetools CodeToolManager, CodeCache, BasicCodeTools, Laz_XMLCfg, OldAvLTree, // IDE Interface - ProjectIntf, LazIDEIntf, + ProjectIntf, PackageIntf, LazIDEIntf, // IDE LazConf, LazarusIDEStrConsts, IDEProcs, ObjectLists, DialogProcs, KeyMapping, EnvironmentOpts, MiscOptions, InputHistory, ProjectDefs, Project, ComponentReg, UComponentManMain, PackageEditor, AddToPackageDlg, PackageDefs, PackageLinks, PackageSystem, OpenInstalledPkgDlg, PkgGraphExplorer, BrokenDependenciesDlg, CompilerOptions, ExtToolEditDlg, - MsgView, BuildLazDialog, DefineTemplates, + MsgView, BuildLazDialog, DefineTemplates, NewDialog, ProjectInspector, ComponentPalette, UnitEditor, AddFileToAPackageDlg, LazarusPackageIntf, PublishProjectDlg, // bosses @@ -250,6 +250,42 @@ type ShowDialog: boolean): TModalResult; end; + + { TLazPackageDescriptors } + + TLazPackageDescriptors = class(TPackageDescriptors) + private + fDestroying: boolean; + fItems: TList; // list of TProjectDescriptor + protected + function GetItems(Index: integer): TPackageDescriptor; override; + public + constructor Create; + destructor Destroy; override; + function Count: integer; override; + function GetUniqueName(const Name: string): string; override; + function IndexOf(const Name: string): integer; override; + function FindByName(const Name: string): TPackageDescriptor; override; + procedure RegisterDescriptor(Descriptor: TPackageDescriptor); override; + procedure UnregisterDescriptor(Descriptor: TPackageDescriptor); override; + procedure AddDefaultPackageDescriptors; + public + property Items[Index: integer]: TPackageDescriptor read GetItems; default; + end; + + + { TPackageDescriptorStd } + + TPackageDescriptorStd = class(TPackageDescriptor) + public + constructor Create; override; + function GetLocalizedName: string; override; + function GetLocalizedDescription: string; override; + end; + +var + LazPackageDescriptors: TLazPackageDescriptors; + implementation { TPkgManager } @@ -1568,6 +1604,9 @@ begin 'PKGUNITPATH',nil,@MacroFunctionPkgUnitPath); CodeToolBoss.DefineTree.MacroFunctions.AddExtended( 'PKGINCPATH',nil,@MacroFunctionPkgIncPath); + + LazPackageDescriptors:=TLazPackageDescriptors.Create; + LazPackageDescriptors.AddDefaultPackageDescriptors; // idle handler Application.AddOnIdleHandler(@OnApplicationIdle,true); @@ -1577,6 +1616,7 @@ destructor TPkgManager.Destroy; var Dependency: TPkgDependency; begin + FreeThenNil(LazPackageDescriptors); while FirstAutoInstallDependency<>nil do begin Dependency:=FirstAutoInstallDependency; Dependency.RequiredPackage:=nil; @@ -3371,5 +3411,129 @@ begin Result:=mrOk; end; +{ TLazPackageDescriptors } + +function TLazPackageDescriptors.GetItems(Index: integer): TPackageDescriptor; +begin + Result:=TPackageDescriptor(FItems[Index]); +end; + +constructor TLazPackageDescriptors.Create; +begin + PackageDescriptors:=Self; + FItems:=TList.Create; +end; + +destructor TLazPackageDescriptors.Destroy; +var + i: Integer; +begin + fDestroying:=true; + for i:=Count-1 downto 0 do Items[i].Release; + FItems.Free; + FItems:=nil; + PackageDescriptors:=nil; + inherited Destroy; +end; + +function TLazPackageDescriptors.Count: integer; +begin + Result:=FItems.Count; +end; + +function TLazPackageDescriptors.GetUniqueName(const Name: string): string; +var + i: Integer; +begin + Result:=Name; + if IndexOf(Result)<0 then exit; + i:=0; + repeat + inc(i); + Result:=Name+IntToStr(i); + until IndexOf(Result)<0; +end; + +function TLazPackageDescriptors.IndexOf(const Name: string): integer; +begin + Result:=Count-1; + while (Result>=0) and (AnsiCompareText(Name,Items[Result].Name)<>0) do + dec(Result); +end; + +function TLazPackageDescriptors.FindByName(const Name: string + ): TPackageDescriptor; +var + i: LongInt; +begin + i:=IndexOf(Name); + if i>=0 then + Result:=Items[i] + else + Result:=nil; +end; + +procedure TLazPackageDescriptors.RegisterDescriptor( + Descriptor: TPackageDescriptor); +begin + if Descriptor.Name='' then + raise Exception.Create('TLazPackageDescriptors.RegisterDescriptor Descriptor.Name empty'); + Descriptor.Name:=GetUniqueName(Descriptor.Name); + FItems.Add(Descriptor); +end; + +procedure TLazPackageDescriptors.UnregisterDescriptor( + Descriptor: TPackageDescriptor); +var + i: LongInt; +begin + if fDestroying then exit; + i:=FItems.IndexOf(Descriptor); + if i<0 then + raise Exception.Create('TLazPackageDescriptors.UnregisterDescriptor'); + FItems.Delete(i); + Descriptor.Release; +end; + +procedure TLazPackageDescriptors.AddDefaultPackageDescriptors; +var + i: Integer; + NewItem: TNewItemPackage; + PkgItem: TPackageDescriptor; +begin + // standard package + RegisterDescriptor(TPackageDescriptorStd.Create); + + // register in new dialog: package category + NewIDEItems.Add(TNewIDEItemCategoryPackage.Create('Package')); + // register in new dialog: all package templates + for i:=0 to Count-1 do begin + PkgItem:=Items[i]; + if not PkgItem.VisibleInNewDialog then continue; + NewItem:=TNewItemPackage.Create(PkgItem.Name,niifCopy,[niifCopy]); + NewItem.Descriptor:=PkgItem; + RegisterNewDialogItem('Package',NewItem); + end; +end; + +{ TPackageDescriptorStd } + +constructor TPackageDescriptorStd.Create; +begin + inherited Create; + Name:=PkgDescNameStandard; +end; + +function TPackageDescriptorStd.GetLocalizedName: string; +begin + Result:='Package'; +end; + +function TPackageDescriptorStd.GetLocalizedDescription: string; +begin + Result:=Format(lisNewDlgCreateANewStandardPackageAPackageIsACollectionOfUn, + [#13]); +end; + end. diff --git a/tools/install/fpcsrc.spec b/tools/install/fpcsrc.spec index ce1b6269f2..1677fc4746 100644 --- a/tools/install/fpcsrc.spec +++ b/tools/install/fpcsrc.spec @@ -15,8 +15,12 @@ BuildRoot: %{_tmppath}/fpcsrc-build%{version} # The normal redhat rpm scripts tests every installed file for requirements. # We install only sources, so we don't need the requirements. # But it seems, RPM ignores these macros: + +# %define _use_internal_dependency_generator 0 %define __find_provides /tmp/do_nothing.sh %define __find_requires /tmp/do_nothing.sh +# %define __find_requires %{nil} +# AutoReq: 0 # The normal redhat rpm scripts do not recognize properly, what files to strip # Hook our own strip command