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

adding events for properties of method types of indirect units implemented issue #1990

Browse Source 
git-svn-id: trunk@9600 -
This commit is contained in:
mattias 2006-07-13 22:06:24 +00:00
parent d7bb813f84
commit 54775b843e
18 changed files with 364 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -60,6 +60,8 @@ components/codetools/customcodetool.pas svneol=native#text/pascal
components/codetools/definetemplates.pas svneol=native#text/pascal
components/codetools/directorycacher.pas svneol=native#text/plain
components/codetools/eventcodetool.pas svneol=native#text/pascal
components/codetools/examples/addeventmethod.lpi svneol=native#text/plain
components/codetools/examples/addeventmethod.lpr svneol=native#text/plain
components/codetools/examples/addmethod.lpi svneol=native#text/plain
components/codetools/examples/addmethod.lpr svneol=native#text/plain
components/codetools/examples/codecompletion.lpi svneol=native#text/plain
@ -73,6 +75,7 @@ components/codetools/examples/getcontext.lpr svneol=native#text/plain
components/codetools/examples/methodjumping.lpi svneol=native#text/plain
components/codetools/examples/methodjumping.pas svneol=native#text/plain
components/codetools/examples/scanexamples/BigLettersUnit.pas svneol=native#text/plain
components/codetools/examples/scanexamples/addeventexample.pas svneol=native#text/plain
components/codetools/examples/scanexamples/brokenfilenames.pas svneol=native#text/plain
components/codetools/examples/scanexamples/brokenincfiles.inc svneol=native#text/plain
components/codetools/examples/scanexamples/completion1.pas svneol=native#text/plain

98
components/codetools/codecompletiontool.pas
View File

@ -123,7 +123,8 @@ type
JumpToProcName: string;
NewClassSectionIndent: array[TPascalClassSection] of integer;
NewClassSectionInsertPos: array[TPascalClassSection] of integer;
FullTopLvlName: string;
fFullTopLvlName: string;// used by OnTopLvlIdentifierFound
fNewMainUsesSectionUnits: TAVLTree; // tree of PChar
procedure AddNewPropertyAccessMethodsToClassProcs(ClassProcs: TAVLTree;
const TheClassName: string);
procedure CheckForOverrideAndAddInheritedCode(ClassProcs: TAVLTree);
@ -137,6 +138,7 @@ type
procedure InsertNewClassParts(PartType: TNewClassPart);
function InsertAllNewClassParts: boolean;
function InsertClassHeaderComment: boolean;
function InsertAllNewUnitsToMainUsesSection: boolean;
function CreateMissingProcBodies: boolean;
function NodeExtIsVariable(ANodeExt: TCodeTreeNodeExtension): boolean;
function NodeExtHasVisibilty(ANodeExt: TCodeTreeNodeExtension;
@ -159,6 +161,7 @@ type
const VariableName, NewType: string;
out NewPos: TCodeXYPosition; out NewTopLine: integer;
SourceChangeCache: TSourceChangeCache): boolean;
procedure AddNeededUnitToMainUsesSection(AnUnitName: PChar);
function CompleteLocalVariableAssignment(CleanCursorPos,
OldTopLine: integer; CursorNode: TCodeTreeNode;
var NewPos: TCodeXYPosition; var NewTopLine: integer;
@ -275,7 +278,7 @@ begin
TrimmedIdentifier:=GetIdentifier(Params.Identifier);
end;
end;
FullTopLvlName:=FullTopLvlName+TrimmedIdentifier;
fFullTopLvlName:=fFullTopLvlName+TrimmedIdentifier;
Result:=ifrSuccess;
end;
@ -378,6 +381,7 @@ begin
FirstInsert:=FirstInsert.Next;
NodeExtMemManager.DisposeNode(ANodeExt);
end;
FreeAndNil(fNewMainUsesSectionUnits);
end;
function TCodeCompletionCodeTool.NodeExtIsVariable(
@ -801,6 +805,17 @@ begin
RaiseException('CompleteLocalVariableAssignment Internal error: AddLocalVariable');
end;
procedure TCodeCompletionCodeTool.AddNeededUnitToMainUsesSection(
AnUnitName: PChar);
begin
if fNewMainUsesSectionUnits=nil then
fNewMainUsesSectionUnits:=
TAVLTree.Create(TListSortCompare(@CompareIdentifiers));
//DebugLn(['TCodeCompletionCodeTool.AddNeededUnitToMainUsesSection AnUnitName="',AnUnitName,'"']);
if fNewMainUsesSectionUnits.Find(AnUnitName)<>nil then exit;
fNewMainUsesSectionUnits.Add(AnUnitName);
end;
function TCodeCompletionCodeTool.CompleteLocalVariableAssignment(
CleanCursorPos, OldTopLine: integer;
CursorNode: TCodeTreeNode;
@ -1949,6 +1964,81 @@ begin
InsertPos,InsertPos,Code);
end;
function TCodeCompletionCodeTool.InsertAllNewUnitsToMainUsesSection: boolean;
var
UsesNode: TCodeTreeNode;
AVLNode: TAVLTreeNode;
CurSourceName: String;
SectionNode: TCodeTreeNode;
NewUsesTerm: String;
NewUnitName: String;
InsertPos: LongInt;
begin
Result:=true;
if (fNewMainUsesSectionUnits=nil) then exit;
//DebugLn(['TCodeCompletionCodeTool.InsertAllNewUnitsToMainUsesSection ']);
UsesNode:=FindMainUsesSection;
// remove units, that are already in the uses section
CurSourceName:=GetSourceName(false);
fNewMainUsesSectionUnits.Remove(PChar(CurSourceName)); // the unit itself
if UsesNode<>nil then begin
MoveCursorToNodeStart(UsesNode);
ReadNextAtom; // read 'uses'
repeat
ReadNextAtom; // read name
if AtomIsChar(';') then break;
fNewMainUsesSectionUnits.Remove(@Src[CurPos.StartPos]);
ReadNextAtom;
if UpAtomIs('IN') then begin
ReadNextAtom;
ReadNextAtom;
end;
if AtomIsChar(';') then break;
if not AtomIsChar(',') then break;
until (CurPos.StartPos>SrcLen);;
if (fNewMainUsesSectionUnits.Count=0) then exit;
end;
// add units
NewUsesTerm:='';
AVLNode:=fNewMainUsesSectionUnits.FindLowest;
while AVLNode<>nil do begin
if NewUsesTerm<>'' then
NewUsesTerm:=NewUsesTerm+', ';
NewUnitName:=GetIdentifier(PChar(AVLNode.Data));
NewUsesTerm:=NewUsesTerm+NewUnitName;
AVLNode:=fNewMainUsesSectionUnits.FindSuccessor(AVLNode);
end;
if UsesNode<>nil then begin
// add unit to existing uses section
MoveCursorToNodeStart(UsesNode); // for nice error position
InsertPos:=UsesNode.EndPos-1; // position of semicolon at end of uses section
NewUsesTerm:=', '+NewUsesTerm;
if not ASourceChangeCache.Replace(gtNone,gtNone,InsertPos,InsertPos,
NewUsesTerm) then exit;
end else begin
// create a new uses section
if Tree.Root=nil then exit;
SectionNode:=Tree.Root;
MoveCursorToNodeStart(SectionNode);
ReadNextAtom;
if UpAtomIs('UNIT') then begin
// search interface
SectionNode:=SectionNode.NextBrother;
if (SectionNode=nil) or (SectionNode.Desc<>ctnInterface) then exit;
MoveCursorToNodeStart(SectionNode);
ReadNextAtom;
end;
InsertPos:=CurPos.EndPos;
NewUsesTerm:=ASourceChangeCache.BeautifyCodeOptions.BeautifyKeyWord('uses')
+' '+NewUsesTerm+';';
if not ASourceChangeCache.Replace(gtEmptyLine,gtEmptyLine,
InsertPos,InsertPos,NewUsesTerm) then exit;
end;
end;
procedure TCodeCompletionCodeTool.AddNewPropertyAccessMethodsToClassProcs(
ClassProcs: TAVLTree; const TheClassName: string);
var ANodeExt: TCodeTreeNodeExtension;
@ -2702,7 +2792,7 @@ var CleanCursorPos, Indent, insertPos: integer;
Params.ContextNode:=CursorNode;
MoveCursorToCleanPos(PropertyAtom.StartPos);
Params.SetIdentifier(Self,@Src[CurPos.StartPos],nil);
FullTopLvlName:='';
fFullTopLvlName:='';
Params.OnTopLvlIdentifierFound:=@OnTopLvlIdentifierFound;
Params.Flags:=[fdfSearchInParentNodes,fdfSearchInAncestors,
fdfTopLvlResolving,fdfFindVariable];
@ -2736,7 +2826,7 @@ var CleanCursorPos, Indent, insertPos: integer;
l: integer;
begin
if UserEventAtom.StartPos=UserEventAtom.EndPos then begin
Result:=FullTopLvlName;
Result:=fFullTopLvlName;
l:=PropertyAtom.EndPos-PropertyAtom.StartPos;
PropertyName:=copy(Src,PropertyAtom.StartPos,l);
if AnsiCompareText(PropertyName,RightStr(Result,l))<>0 then

18
components/codetools/codetoolmanager.pas
View File

@ -558,12 +558,14 @@ type
NewMethodName: string): boolean;
function CreatePublishedMethod(Code: TCodeBuffer; const AClassName,
NewMethodName: string; ATypeInfo: PTypeInfo;
UseTypeInfoForParameters: boolean = false): boolean;
UseTypeInfoForParameters: boolean = false;
const ATypeUnitName: string = ''): boolean;
// private class parts
function CreatePrivateMethod(Code: TCodeBuffer; const AClassName,
NewMethodName: string; ATypeInfo: PTypeInfo;
UseTypeInfoForParameters: boolean = false): boolean;
UseTypeInfoForParameters: boolean = false;
const ATypeUnitName: string = ''): boolean;
// IDE % directives
function GetIDEDirectives(Code: TCodeBuffer;
@ -2521,7 +2523,7 @@ end;
function TCodeToolManager.CreatePublishedMethod(Code: TCodeBuffer;
const AClassName, NewMethodName: string; ATypeInfo: PTypeInfo;
UseTypeInfoForParameters: boolean): boolean;
UseTypeInfoForParameters: boolean; const ATypeUnitName: string): boolean;
begin
{$IFDEF CTDEBUG}
DebugLn('TCodeToolManager.CreatePublishedMethod A');
@ -2531,8 +2533,8 @@ begin
try
SourceChangeCache.Clear;
Result:=FCurCodeTool.CreateMethod(UpperCaseStr(AClassName),
NewMethodName,ATypeInfo,SourceChangeCache,UseTypeInfoForParameters,
pcsPublished);
NewMethodName,ATypeInfo,ATypeUnitName,SourceChangeCache,
UseTypeInfoForParameters,pcsPublished);
except
on e: Exception do Result:=HandleException(e);
end;
@ -2540,7 +2542,7 @@ end;
function TCodeToolManager.CreatePrivateMethod(Code: TCodeBuffer;
const AClassName, NewMethodName: string; ATypeInfo: PTypeInfo;
UseTypeInfoForParameters: boolean): boolean;
UseTypeInfoForParameters: boolean; const ATypeUnitName: string): boolean;
begin
{$IFDEF CTDEBUG}
DebugLn('TCodeToolManager.CreatePrivateMethod A');
@ -2550,8 +2552,8 @@ begin
try
SourceChangeCache.Clear;
Result:=FCurCodeTool.CreateMethod(UpperCaseStr(AClassName),
NewMethodName,ATypeInfo,SourceChangeCache,UseTypeInfoForParameters,
pcsPrivate);
NewMethodName,ATypeInfo,ATypeUnitName,SourceChangeCache,
UseTypeInfoForParameters,pcsPrivate);
except
on e: Exception do Result:=HandleException(e);
end;

2
components/codetools/codetoolsconfig.pas
View File

@ -98,7 +98,7 @@ type
property Modified: boolean read FModified write SetModified;
// FPC
property FPCSrcDir: string read FFPCSrcDir write SetFPCSrcDir; // e.g. /usr/shar/fpcsrc
property FPCSrcDir: string read FFPCSrcDir write SetFPCSrcDir; // e.g. /usr/share/fpcsrc
property FPCPath: string read FFPCPath write SetFPCPath; // e.g. /usr/bin/ppc386
property FPCOptions: string read FFPCOptions write SetFPCOptions;
property TargetOS: string read FTargetOS write SetTargetOS;

1
components/codetools/codetoolsstrconsts.pas
View File

@ -148,6 +148,7 @@ ResourceString
ctsUnableToCompleteProperty = 'unable to complete property';
ctsErrorDuringInsertingNewClassParts = 'error during inserting new class parts';
ctsErrorDuringCreationOfNewProcBodies = 'error during creation of new proc bodies';
ctsErrorDuringInsertingNewUsesSection = 'error during inserting new units to the main uses section';
ctsUnableToApplyChanges = 'unable to apply changes';
ctsEndOfSourceNotFound = 'End of source not found';
ctsCursorPosOutsideOfCode = 'cursor pos outside of code';

1
components/codetools/codetoolsstructs.pas
View File

@ -121,6 +121,7 @@ function CompareStringToStringItemsI(Data1, Data2: Pointer): integer;
function CompareStringAndStringToStringTreeItem(Key, Data: Pointer): integer;
function CompareStringAndStringToStringTreeItemI(Key, Data: Pointer): integer;
implementation
function CompareStringToStringItems(Data1, Data2: Pointer): integer;

57
components/codetools/eventcodetool.pas
View File

@ -86,12 +86,13 @@ type
SourceChangeCache: TSourceChangeCache): boolean;
function CreateMethod(const UpperClassName,
AMethodName: string; ATypeInfo: PTypeInfo;
AMethodName: string; ATypeInfo: PTypeInfo; const ATypeUnitName: string;
SourceChangeCache: TSourceChangeCache;
UseTypeInfoForParameters: boolean = false;
Section: TPascalClassSection = pcsPublished): boolean;
function CreateMethod(ClassNode: TCodeTreeNode;
const AMethodName: string; ATypeInfo: PTypeInfo;
const AMethodName: string;
ATypeInfo: PTypeInfo; const ATypeUnitName: string;
SourceChangeCache: TSourceChangeCache;
UseTypeInfoForParameters: boolean = false;
Section: TPascalClassSection = pcsPublished): boolean;
@ -102,7 +103,8 @@ type
const UpperMethodName: string): TFindContext;
function FindMethodNodeInImplementation(const UpperClassName,
UpperMethodName: string; BuildTreeBefore: boolean): TCodeTreeNode;
function FindMethodTypeInfo(ATypeInfo: PTypeInfo): TFindContext;
function FindMethodTypeInfo(ATypeInfo: PTypeInfo;
const AStartUnitName: string = ''): TFindContext;
function MethodTypeDataToStr(TypeData: PTypeData;
Attr: TProcHeadAttributes): string;
end;
@ -357,12 +359,32 @@ begin
end;
end;
function TEventsCodeTool.FindMethodTypeInfo(ATypeInfo: PTypeInfo): TFindContext;
function TEventsCodeTool.FindMethodTypeInfo(ATypeInfo: PTypeInfo;
const AStartUnitName: string): TFindContext;
var
Tool: TFindDeclarationTool;
procedure RaiseTypeNotFound;
begin
RaiseException('type '+ATypeInfo^.Name+' not found, because tool is '+dbgsname(Tool));
end;
var TypeName: string;
Params: TFindDeclarationParams;
begin
if AStartUnitName<>'' then begin
// start searching in another unit
Tool:=FindCodeToolForUsedUnit(AStartUnitName,'',true);
if not (Tool is TEventsCodeTool) then
RaiseTypeNotFound;
TEventsCodeTool(Tool).BuildTree(true);
Result:=TEventsCodeTool(Tool).FindMethodTypeInfo(ATypeInfo,'');
exit;
end;
ActivateGlobalWriteLock;
try
// find method type declaration
TypeName:=ATypeInfo^.Name;
CheckDependsOnNodeCaches;
@ -574,7 +596,7 @@ begin
end;
function TEventsCodeTool.CreateMethod(const UpperClassName,
AMethodName: string; ATypeInfo: PTypeInfo;
AMethodName: string; ATypeInfo: PTypeInfo; const ATypeUnitName: string;
SourceChangeCache: TSourceChangeCache;
UseTypeInfoForParameters: boolean;
Section: TPascalClassSection): boolean;
@ -584,22 +606,33 @@ begin
BuildTree(false);
if not EndOfSourceFound then exit;
AClassNode:=FindClassNodeInInterface(UpperClassName,true,false,true);
Result:=CreateMethod(AClassNode,AMethodName,ATypeInfo,
Result:=CreateMethod(AClassNode,AMethodName,ATypeInfo,ATypeUnitName,
SourceChangeCache,UseTypeInfoForParameters,Section);
end;
function TEventsCodeTool.CreateMethod(ClassNode: TCodeTreeNode;
const AMethodName: string; ATypeInfo: PTypeInfo;
const AMethodName: string; ATypeInfo: PTypeInfo; const ATypeUnitName: string;
SourceChangeCache: TSourceChangeCache; UseTypeInfoForParameters: boolean;
Section: TPascalClassSection): boolean;
procedure AddNeededUnits(const AFindContext: TFindContext);
var
MethodUnitName: String;
begin
MethodUnitName:=AFindContext.Tool.GetSourceName(false);
AddNeededUnitToMainUsesSection(PChar(MethodUnitName));
// ToDo
// search every parameter type and collect units
end;
var
CleanMethodDefinition, MethodDefinition: string;
FindContext: TFindContext;
ATypeData: PTypeData;
NewSection: TNewClassPart;
begin
Result:=false;
try
Result:=false;
if (ClassNode=nil) or (ClassNode.Desc<>ctnClass) or (AMethodName='')
or (ATypeInfo=nil) or (SourceChangeCache=nil) or (Scanner=nil) then exit;
{$IFDEF CTDEBUG}
@ -611,7 +644,6 @@ begin
// check if method definition already exists in class
if UseTypeInfoForParameters then begin
// do not lookup the declaration in the source
ATypeData:=GetTypeData(ATypeInfo);
if ATypeData=nil then exit(false);
CleanMethodDefinition:=UpperCaseStr(AMethodName)
@ -619,7 +651,8 @@ begin
[phpWithoutClassName, phpWithoutName, phpInUpperCase]);
end else begin
// search typeinfo in source
FindContext:=FindMethodTypeInfo(ATypeInfo);
FindContext:=FindMethodTypeInfo(ATypeInfo,ATypeUnitName);
AddNeededUnits(FindContext);
CleanMethodDefinition:=UpperCaseStr(AMethodName)
+FindContext.Tool.ExtractProcHead(FindContext.Node,
[phpWithoutClassName, phpWithoutName, phpInUpperCase]);
@ -658,10 +691,10 @@ begin
{$ENDIF}
if not InsertAllNewClassParts then
RaiseException(ctsErrorDuringInsertingNewClassParts);
// insert all missing proc bodies
if not CreateMissingProcBodies then
RaiseException(ctsErrorDuringCreationOfNewProcBodies);
if not InsertAllNewUnitsToMainUsesSection then
RaiseException(ctsErrorDuringInsertingNewUsesSection);
// apply the changes
if not SourceChangeCache.Apply then

59
components/codetools/examples/addeventmethod.lpi Normal file
View File

@ -0,0 +1,59 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="5"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
<Title Value="addeventmethod"/>
</General>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="addeventmethod.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="AddEventMethod"/>
</Unit0>
<Unit1>
<Filename Value="scanexamples/simpleunit1.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="SimpleUnit1"/>
</Unit1>
<Unit2>
<Filename Value="scanexamples/addeventexample.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="AddEventExample"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<SearchPaths>
<OtherUnitFiles Value="$(LazarusDir)/components/codetools/units/$(TargetCPU)-$(TargetOS)/;scanexamples/"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

85
components/codetools/examples/addeventmethod.lpr Normal file
View File

@ -0,0 +1,85 @@
{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
Demonstrating, how to add a method to a class and extending the uses section.
}
program AddEventMethod;
{$mode objfpc}{$H+}
uses
Classes, SysUtils, CodeCache, CodeToolManager, SimpleUnit1, FileProcs,
CodeToolsConfig, CodeCompletionTool, ExtCtrls;
const
ConfigFilename = 'codetools.config';
var
Options: TCodeToolsOptions;
Filename: string;
Code: TCodeBuffer;
begin
// setup the Options
Options:=TCodeToolsOptions.Create;
// To not parse the FPC sources every time, the options are saved to a file.
if FileExists(ConfigFilename) then
Options.LoadFromFile(ConfigFilename);
// setup your paths
Options.FPCPath:='/usr/bin/ppc386';
Options.FPCSrcDir:=ExpandFileName('~/freepascal/fpc');
Options.LazarusSrcDir:=ExpandFileName('~/pascal/lazarus');
// optional: ProjectDir and TestPascalFile exists only to easily test some
// things.
Options.ProjectDir:=GetCurrentDir+'/scanexamples/';
Options.TestPascalFile:=Options.ProjectDir+'addeventexample.pas';
// init the codetools
if not Options.UnitLinkListValid then
writeln('Scanning FPC sources may take a while ...');
CodeToolBoss.Init(Options);
// save the options and the FPC unit links results.
Options.SaveToFile(ConfigFilename);
// load the file
Filename:=Options.TestPascalFile;
Code:=CodeToolBoss.LoadFile(Filename,false,false);
if Code=nil then
raise Exception.Create('loading failed '+Filename);
// Example 1: add a method compatible to TTabChangingEvent
// TTabChangingEvent is used in ComCtrls, but defined in ExtCtrls.
// The codetools will search TTabChangingEvent and will add ExtCtrls to the
// uses section.
if CodeToolBoss.CreatePublishedMethod(Code,'TForm1','NewMethod',
typeinfo(TTabChangingEvent),false,'ComCtrls') then
begin
writeln('Method added: ');
writeln(Code.Source);
end else begin
raise Exception.Create('Adding method failed');
end;
end.

2
components/codetools/examples/addmethod.lpr
View File

@ -82,7 +82,7 @@ begin
Tool.AddClassInsertion(CleanMethodDefinition, MethodDefinition, MethodName,
ncpPublishedProcs);
end;
if not Tool.ApplyClassCompletion then
raise Exception.Create('Explore failed');
writeln('Method added: ');

29
components/codetools/examples/scanexamples/addeventexample.pas Normal file
View File

@ -0,0 +1,29 @@
unit AddEventExample;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, ComCtrls;
type
TForm1 = class(TForm)
PageControl1: TPageControl;
procedure Button1Click(Sender: TObject);
procedure CheckBox1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
public
MyBitmap: TBitmap;
end;
TMyComponent = class(TComponent)
end;
implementation
end.

12
components/codetools/finddeclarationtool.pas
View File

@ -617,6 +617,8 @@ type
function FindCodeToolForUsedUnit(UnitNameAtom,
UnitInFileAtom: TAtomPosition;
ExceptionOnNotFound: boolean): TFindDeclarationTool;
function FindCodeToolForUsedUnit(const AnUnitName, AnUnitInFilename: string;
ExceptionOnNotFound: boolean): TFindDeclarationTool;
function FindIdentifierInInterface(AskingTool: TFindDeclarationTool;
Params: TFindDeclarationParams): boolean;
function CompareNodeIdentifier(Node: TCodeTreeNode;
@ -4301,7 +4303,6 @@ function TFindDeclarationTool.FindCodeToolForUsedUnit(UnitNameAtom,
UnitInFileAtom: TAtomPosition;
ExceptionOnNotFound: boolean): TFindDeclarationTool;
var AnUnitName, AnUnitInFilename: string;
NewCode: TCodeBuffer;
begin
Result:=nil;
if (UnitNameAtom.StartPos<1) or (UnitNameAtom.EndPos<=UnitNameAtom.StartPos)
@ -4320,6 +4321,15 @@ begin
UnitInFileAtom.EndPos-UnitInFileAtom.StartPos-2);
end else
AnUnitInFilename:='';
Result:=FindCodeToolForUsedUnit(AnUnitName,AnUnitInFilename,ExceptionOnNotFound);
end;
function TFindDeclarationTool.FindCodeToolForUsedUnit(const AnUnitName,
AnUnitInFilename: string; ExceptionOnNotFound: boolean): TFindDeclarationTool;
var
NewCode: TCodeBuffer;
begin
Result:=nil;
NewCode:=FindUnitSource(AnUnitName,AnUnitInFilename,ExceptionOnNotFound);
if (NewCode=nil) then begin
// no source found

8
ide/main.pp
View File

@ -361,7 +361,8 @@ type
var MethodIsCompatible, MethodIsPublished,
IdentIsMethod: boolean): boolean;
function OnPropHookCreateMethod(const AMethodName:ShortString;
ATypeInfo:PTypeInfo): TMethod;
ATypeInfo:PTypeInfo;
const ATypeUnitName: string): TMethod;
procedure OnPropHookShowMethod(const AMethodName:ShortString);
procedure OnPropHookRenameMethod(const CurName, NewName:ShortString);
function OnPropHookBeforeAddPersistent(Sender: TObject;
@ -12428,7 +12429,7 @@ begin
end;
function TMainIDE.OnPropHookCreateMethod(const AMethodName: ShortString;
ATypeInfo: PTypeInfo): TMethod;
ATypeInfo: PTypeInfo; const ATypeUnitName: string): TMethod;
var ActiveSrcEdit: TSourceEditor;
ActiveUnitInfo: TUnitInfo;
r: boolean;
@ -12445,7 +12446,8 @@ begin
try
// create published method
r:=CodeToolBoss.CreatePublishedMethod(ActiveUnitInfo.Source,
ActiveUnitInfo.Component.ClassName,AMethodName,ATypeInfo);
ActiveUnitInfo.Component.ClassName,AMethodName,ATypeInfo,true,
ATypeUnitName);
{$IFDEF IDE_DEBUG}
writeln('');
writeln('[TMainIDE.OnPropHookCreateMethod] ************2 ',r,' ',AMethodName);

9
ide/todolist.pp
View File

@ -289,24 +289,27 @@ begin
end;
//Find in comment the ToDo message
procedure TfrmTodo.ParseComment(const aFileName: string; const SComment, EComment: string;
procedure TfrmTodo.ParseComment(const aFileName: string;
const SComment, EComment: string;
const TokenString: string; LineNumber: Integer);
Var
N,J : Integer;
ParsingString : string;
CListItem : TListItem;
TodoFlag : string;
function IsTodoFlag(const Flag: string): boolean;
begin
TodoFLag := Flag;
Result := Pos(UpperCase(Flag),UpperCase(TokenString)) > 1;
end;
begin
if IsTodoFlag(cTodoFlag) or IsTodoFlag(cAltTodoFlag) then
if IsTodoFlag(cTodoFlag) or IsTodoFlag(cAltTodoFlag) then
begin
// We found a token that looks like a TODO comment. Now
// verify that it *is* one: either a white-space or the
// comment token need to be right in front of the TODO item
// comment token need to be in front of the TODO item
// Remove comment characters
ParsingString := TokenString;

13
ideintf/propedits.pp
View File

@ -297,7 +297,7 @@ type
function GetAttributes: TPropertyAttributes; virtual;
function IsReadOnly: boolean; virtual;
function GetComponent(Index: Integer): TPersistent;// for Delphi compatibility
function GetUnitName(Index: Integer): string;
function GetUnitName(Index: Integer = 0): string;
function GetEditLimit: Integer; virtual;
function GetName: shortstring; virtual;
procedure GetProperties(Proc: TGetPropEditProc); virtual;
@ -1096,7 +1096,7 @@ type
TPropHookChangeLookupRoot = procedure of object;
// methods
TPropHookCreateMethod = function(const Name:ShortString;
ATypeInfo:PTypeInfo): TMethod of object;
ATypeInfo:PTypeInfo; const ATypeUnitName: string): TMethod of object;
TPropHookGetMethodName = function(const Method:TMethod): ShortString of object;
TPropHookGetMethods = procedure(TypeData:PTypeData; Proc:TGetStringProc) of object;
TPropHookMethodExists = function(const Name:ShortString; TypeData: PTypeData;
@ -1190,7 +1190,8 @@ type
// lookup root
property LookupRoot: TPersistent read FLookupRoot write SetLookupRoot;
// methods
function CreateMethod(const Name:ShortString; ATypeInfo:PTypeInfo): TMethod;
function CreateMethod(const Name:ShortString; ATypeInfo:PTypeInfo;
const ATypeUnitName: string): TMethod;
function GetMethodName(const Method:TMethod): ShortString;
procedure GetMethods(TypeData:PTypeData; Proc:TGetStringProc);
function MethodExists(const Name:ShortString; TypeData: PTypeData;
@ -3848,7 +3849,7 @@ begin
//writeln('### TMethodPropertyEditor.SetValue E');
CreateNewMethod := IsValidIdent(NewValue) and not NewMethodExists;
//OldMethod := GetMethodValue;
SetMethodValue(PropertyHook.CreateMethod(NewValue,GetPropType));
SetMethodValue(PropertyHook.CreateMethod(NewValue,GetPropType,GetUnitName));
//writeln('### TMethodPropertyEditor.SetValue F NewValue=',GetValue);
if CreateNewMethod then begin
{if (PropCount = 1) and (OldMethod.Data <> nil) and (OldMethod.Code <> nil)
@ -4952,7 +4953,7 @@ end;
{ TPropertyEditorHook }
function TPropertyEditorHook.CreateMethod(const Name:Shortstring;
ATypeInfo:PTypeInfo): TMethod;
ATypeInfo:PTypeInfo; const ATypeUnitName: string): TMethod;
var
i: Integer;
Handler: TPropHookCreateMethod;
@ -4963,7 +4964,7 @@ begin
i:=GetHandlerCount(htCreateMethod);
while GetNextHandlerIndex(htCreateMethod,i) do begin
Handler:=TPropHookCreateMethod(FHandlers[htCreateMethod][i]);
Result:=Handler(Name,ATypeInfo);
Result:=Handler(Name,ATypeInfo,ATypeUnitName);
if Result.Code<>nil then exit;
end;
end;

3
lcl/forms.pp
View File

@ -807,8 +807,6 @@ type
TOnUserInputEvent = procedure(Sender: TObject; Msg: Cardinal) of object;
TDataEvent = procedure (Data: PtrInt) of object;
//TODO: move to LMessages ?
// application hint stuff
TCMHintShow = record
Msg: Cardinal;
@ -1398,7 +1396,6 @@ function IsAccel(VK: word; const Str: string): Boolean;
var
lPos: integer;
begin
// TODO: MBCS/UTF-8
lPos:=1;
while (lPos<length(Str)) do begin
if Str[lPos]<>'&' then begin

7
packager/packageeditor.pas
View File

@ -42,8 +42,9 @@ uses
Graphics, LCLType, LCLProc, Menus, Dialogs, FileUtil,
HelpIntfs, AVL_Tree, Laz_XMLCfg, LazIDEIntf, ProjectIntf, FormEditingIntf,
IDEProcs, LazConf, LazarusIDEStrConsts, IDEOptionDefs, IDEDefs,
CompilerOptions, CompilerOptionsDlg, ComponentReg, PackageDefs, PkgOptionsDlg,
AddToPackageDlg, PkgVirtualUnitEditor, PackageSystem;
IDEContextHelpEdit, CompilerOptions, CompilerOptionsDlg, ComponentReg,
PackageDefs, PkgOptionsDlg, AddToPackageDlg, PkgVirtualUnitEditor,
PackageSystem;
type
TOnCreatePkgMakefile =
@ -599,7 +600,7 @@ end;
procedure TPackageEditorForm.HelpBitBtnClick(Sender: TObject);
begin
Application.ShowHelpForObjecct(HelpBitBtn)
ShowContextHelpForIDE(HelpBitBtn);
end;
procedure TPackageEditorForm.InstallBitBtnClick(Sender: TObject);

2
packager/pkgoptionsdlg.pas
View File

@ -503,6 +503,7 @@ begin
Caption:=lisLazBuildOk;
Parent:=Self;
OnClick:=@OkButtonClick;
Default:=true;
end;
CancelButton:=TButton.Create(Self);
@ -511,6 +512,7 @@ begin
Parent:=Self;
Caption:=dlgCancel;
ModalResult:=mrCancel;
Cancel:=true;
end;
end;