paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-17 19:19:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

implemented creating classes at run time from any TComponent descendant

Browse Source 
git-svn-id: trunk@6272 -
This commit is contained in:
mattias 2004-11-20 11:20:06 +00:00
parent d4c88e8afe
commit d2d3030a60
27 changed files with 1076 additions and 577 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
components/synedit/synedit.pp
View File

@ -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

4
designer/designer.pp
View File

@ -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;

50
designer/jitform/jitform.pas
View File

@ -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
@ -74,6 +70,8 @@ type
TJITClass = class of TPersistent;
procedure SetComponentDesignMode(AComponent: TComponent; Value: Boolean);
implementation
// Define a dummy component to set the csDesigning flag which can not be set
@ -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.

304
designer/jitforms.pp
View File

@ -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.

121
designer/noncontrolforms.pas
View File

@ -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.

87
ide/customformeditor.pp
View File

@ -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<JITFormList.Count then
Result:=JITFormList[Index].Designer
else begin
AForm:=GetDesignerForm(JITDataModuleList[Index-JITFormList.Count]);
AForm:=GetDesignerForm(JITNonFormList[Index-JITFormList.Count]);
Result:=TIDesigner(AForm.Designer);
end;
end;
@ -1254,12 +1255,13 @@ Begin
end;
end;
end else begin
// create a toplevel control -> 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

3
ide/editoroptions.pp
View File

@ -100,7 +100,8 @@ const
);
const
SynEditDefaultOptions = SYNEDIT_DEFAULT_OPTIONS - [eoShowScrollHint];
SynEditDefaultOptions = SYNEDIT_DEFAULT_OPTIONS - [eoShowScrollHint]
+ [eoHalfPageScroll];
type
{ TEditOptLanguageInfo stores lazarus IDE additional information

4
ide/formeditor.pp
View File

@ -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

87
ide/main.pp
View File

@ -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.

4
ide/mainintf.pas
View File

@ -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,

508
ide/newdialog.pas
View File

@ -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,46 +126,98 @@ 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;
//----------------------------------------------------------------------------
// standard categories for new dialog
{ TNewIDEItemCategoryFile }
TNewIDEItemCategoryFile = class(TNewIDEItemCategory)
public
function LocalizedName: string; override;
function Description: string; override;
end;
{ TNewIDEItemCategoryProject }
{ TNewIDEItem }
TNewIDEItemCategoryProject = class(TNewIDEItemCategory)
public
function LocalizedName: string; override;
function Description: string; override;
end;
TNewIDEItem = class
{ 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 }
@ -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:='';
Result:='<Description not set>';
end;
niiCustom:
Result:='';
function TNewIDEItemTemplate.CreateCopy: TNewIDEItemTemplate;
begin
Result:=TNewIDEItemTemplateClass(ClassType).Create(
Name,DefaultFlag,AllowedFlags);
Result.Assign(Self);
end;
niiUnit:
Result:=lisNewDlgCreateANewPascalUnit;
niiForm:
Result:=lisNewDlgCreateANewUnitWithALCLForm;
niiDataModule:
Result:=lisNewDlgCreateANewUnitWithADataModule;
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.

5
ide/project.pp
View File

@ -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

1
ide/projectdefs.pas
View File

@ -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;

5
ideintf/formeditingintf.pas
View File

@ -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;

93
ideintf/packageintf.pas
View File

@ -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;

8
ideintf/projectintf.pas
View File

@ -245,6 +245,7 @@ type
property CustomOptions: string read fCustomOptions write SetCustomOptions;
end;
{ TLazProjectFile }
TLazProjectFile = class(TPersistent)
@ -262,6 +263,7 @@ type
property Filename: string read GetFilename;
end;
{ TProjectFileDescriptor }
TProjectFileDescriptor = class(TPersistent)
@ -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;

2
lcl/forms.pp
View File

@ -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;

37
lcl/graphics.pp
View File

@ -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

16
lcl/include/customform.inc
View File

@ -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.

35
lcl/interfaces/gtk/gtkobject.inc
View File

@ -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<AvgTxtLen then UseWidthHeuristic;
//TextMetric.tmAscent := TextMetric.tmHeight - TextMetric.tmDescent;
TextMetric.tmAveCharWidth := Width div AvgTxtLen;
if TextMetric.tmAveCharWidth<1 then TextMetric.tmAveCharWidth:=1;
@ -6942,6 +6968,9 @@ end;
{ =============================================================================
$Log$
Revision 1.609 2004/11/20 11:20:06 mattias
implemented creating classes at run time from any TComponent descendant
Revision 1.608 2004/11/08 19:11:55 mattias
disabled hardly used gtk FillScreenFont, this should be only done on demand, improved getting default font family for gtk

4
lcl/interfaces/gtk/gtkproc.inc
View File

@ -7183,7 +7183,6 @@ var
NewColor: TGdkColor;
MainWidget: PGtkWidget;
FontHandle: HFONT;
i: Integer;
FreeFontName: boolean;
FreeFontSetName: boolean;
@ -7879,6 +7878,9 @@ end;
{ =============================================================================
$Log$
Revision 1.321 2004/11/20 11:20:06 mattias
implemented creating classes at run time from any TComponent descendant
Revision 1.320 2004/11/17 07:46:32 mattias
fixed postcript printer TextOut/TextEntend from Olivier

26
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -1574,12 +1574,15 @@ begin
else AverageWidth := InttoStr(lfWidth * 10);
end;
// CharSetRegistry := '*';
// TODO: Match charset.
// CharSetCoding := '*';
if CharSetCoding = '*' then begin
{if lfCharset=fcsISO_8859_2 then begin
CharSetRegistry:='iso8859';
CharSetCoding:='2';
end;}
end;
end;
{$IFDEF VerboseFonts}
write('CreateFontIndirect->');
{$ENDIF}
@ -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

60
lcl/interfaces/gtk/gtkwsbuttons.pp
View File

@ -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

2
lcl/lclclasses.pp
View File

@ -19,6 +19,8 @@
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Defines the base class for all LCL TComponents including controls.
}
unit LCLClasses;

4
lcl/lcltype.pp
View File

@ -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)

168
packager/pkgmanager.pas
View File

@ -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 }
@ -1569,6 +1605,9 @@ begin
CodeToolBoss.DefineTree.MacroFunctions.AddExtended(
'PKGINCPATH',nil,@MacroFunctionPkgIncPath);
LazPackageDescriptors:=TLazPackageDescriptors.Create;
LazPackageDescriptors.AddDefaultPackageDescriptors;
// idle handler
Application.AddOnIdleHandler(@OnApplicationIdle,true);
end;
@ -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.

4
tools/install/fpcsrc.spec
View File

@ -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