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

Fix StandardCodeTool.HasInterfaceRegisterProc. Simplify code for checking added unit files.

Browse Source 
git-svn-id: trunk@64156 -
This commit is contained in:
juha 2020-11-23 10:26:46 +00:00
parent 7e68563f75
commit edc2cc5dbb
9 changed files with 84 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
components/codetools/codetoolmanager.pas
View File

@ -511,8 +511,7 @@ type
out CodeContexts: TCodeContextInfo): boolean;
function ExtractProcedureHeader(Code: TCodeBuffer; X,Y: integer;
Attributes: TProcHeadAttributes; out ProcHead: string): boolean;
function HasInterfaceRegisterProc(Code: TCodeBuffer;
out HasRegisterProc: boolean): boolean;
function HasInterfaceRegisterProc(Code: TCodeBuffer): boolean;
// gather identifiers (i.e. all visible)
function GatherUnitNames(Code: TCodeBuffer): Boolean;
@ -2435,17 +2434,15 @@ begin
{$ENDIF}
end;
function TCodeToolManager.HasInterfaceRegisterProc(Code: TCodeBuffer;
out HasRegisterProc: boolean): boolean;
function TCodeToolManager.HasInterfaceRegisterProc(Code: TCodeBuffer): boolean;
begin
Result:=false;
HasRegisterProc:=false;
{$IFDEF CTDEBUG}
DebugLn('TCodeToolManager.HasInterfaceRegisterProc A ',Code.Filename);
{$ENDIF}
if not InitCurCodeTool(Code) then exit;
try
Result:=FCurCodeTool.HasInterfaceRegisterProc(HasRegisterProc);
Result:=FCurCodeTool.HasInterfaceRegisterProc;
except
on e: Exception do Result:=HandleException(e);
end;

42
components/codetools/stdcodetools.pas
View File

@ -360,7 +360,7 @@ type
out StartInStringConst, EndInStringConst: boolean): boolean;
// register procedure
function HasInterfaceRegisterProc(out HasRegisterProc: boolean): boolean;
function HasInterfaceRegisterProc: boolean;
// Delphi to Lazarus conversion
function ConvertDelphiToLazarusSource(AddLRSCode: boolean;
@ -3952,42 +3952,22 @@ begin
FormatParameters,StartInStringConst,EndInStringConst);
end;
function TStandardCodeTool.HasInterfaceRegisterProc(out HasRegisterProc: boolean
): boolean;
function IsRegisterProc(ANode: TCodeTreeNode): boolean;
begin
Result:=false;
if ANode=nil then exit;
if ANode.Desc=ctnProcedureHead then
ANode:=Anode.Parent;
if (ANode.Desc<>ctnProcedure) then exit;
MoveCursorToNodeStart(ANode);
if not ReadNextUpAtomIs('PROCEDURE') then exit;
if not ReadNextUpAtomIs('REGISTER') then exit;
if CurPos.Flag<>cafSemicolon then exit;
HasRegisterProc:=true;
Result:=true;
end;
function TStandardCodeTool.HasInterfaceRegisterProc: boolean;
var
InterfaceNode: TCodeTreeNode;
ANode: TCodeTreeNode;
begin
Result:=false;
HasRegisterProc:=false;
ANode:=FindDeclarationNodeInInterface('Register',true);
if ANode=nil then exit;
if IsRegisterProc(ANode) then
exit(true);
// there may be multiple register
InterfaceNode:=FindInterfaceNode;
ANode:=InterfaceNode.FirstChild;
while ANode<>nil do begin
if IsRegisterProc(ANode) then
exit(true);
ANode:=ANode.NextBrother;
end;
if ANode.Desc=ctnProcedureHead then
ANode:=Anode.Parent;
if (ANode.Desc<>ctnProcedure) then exit;
MoveCursorToNodeStart(ANode);
if not ReadNextUpAtomIs('PROCEDURE') then exit;
if not ReadNextUpAtomIs('REGISTER') then exit;
ReadNextAtom;
if CurPos.Flag<>cafSemicolon then exit;
Result:=true;
end;
function TStandardCodeTool.ConvertDelphiToLazarusSource(AddLRSCode: boolean;

13
converter/convertdelphi.pas
View File

@ -1887,13 +1887,12 @@ begin
// Check if the unit has a Register procedure.
// ToDo: Optimize. The source is read again during unit conversion.
CodeBuffer:=CodeToolBoss.LoadFile(AFilename, true, false);
if CodeBuffer<>nil then
if CodeToolBoss.HasInterfaceRegisterProc(CodeBuffer, HasRegisterProc) then
if HasRegisterProc then begin
Include(Flags, pffHasRegisterProc);
fSettings.AddLogLine(mluNote, Format(lisConvAddingFlagForRegister,[PureUnitName]),
fLazPMainFilename);
end;
if (CodeBuffer<>nil) and CodeToolBoss.HasInterfaceRegisterProc(CodeBuffer) then
begin
Include(Flags, pffHasRegisterProc);
fSettings.AddLogLine(mluNote, Format(lisConvAddingFlagForRegister,[PureUnitName]),
fLazPMainFilename);
end;
// Add new unit to package
LazPackage.AddFile(AFileName, PureUnitName, pftUnit, Flags, cpNormal);
end;

5
ide/addtoprojectdlg.pas
View File

@ -42,7 +42,7 @@ uses
// IDEIntf
IDEWindowIntf,
// IDE
LazarusIDEStrConsts, IDEDialogs, Project, PackageEditor, ProjPackChecks;
LazarusIDEStrConsts, IDEDialogs, Project, ProjPackChecks;
type
{ TAddToProjectDialog }
@ -125,8 +125,7 @@ begin
NewFilename:=AddFileListView.Items[i].Caption;
if not FilenameIsAbsolute(NewFilename) then // expand filename
NewFilename:=TrimFilename(fProject.Directory+PathDelim+NewFilename);
case TPrjFileCheck.AddingFile(fProject, NewFilename,
PackageEditors.OnGetUnitRegisterInfo) of
case TPrjFileCheck.AddingFile(fProject, NewFilename) of
mrOk: begin
// check if unitname already exists in selection
if FilenameIsPascalUnit(NewFilename) then

10
ide/projectinspector.pas
View File

@ -68,10 +68,9 @@ uses
// IDEIntf
IDEHelpIntf, IDECommands, IDEDialogs, IDEImagesIntf, LazIDEIntf, ToolBarIntf,
// IDE
LazarusIDEStrConsts, IDEProcs, DialogProcs, IDEOptionDefs,
PackageDefs, PackageEditor, Project, InputHistory, MainBase, EnvironmentOpts,
AddToProjectDlg, AddPkgDependencyDlg, AddFPMakeDependencyDlg, ProjPackChecks,
ProjPackEditing, ProjPackFilePropGui, PackageSystem, BuildManager;
LazarusIDEStrConsts, MainBase, IDEProcs, DialogProcs, IDEOptionDefs, Project, InputHistory,
EnvironmentOpts, AddToProjectDlg, AddPkgDependencyDlg, AddFPMakeDependencyDlg,
ProjPackChecks, ProjPackEditing, ProjPackFilePropGui, PackageDefs, PackageSystem, BuildManager;
type
TOnAddUnitToProject =
@ -387,8 +386,7 @@ begin
for i:=0 to OpenDialog.Files.Count-1 do
begin
NewFilename := OpenDialog.Files[i];
case TPrjFileCheck.AddingFile(LazProject, NewFilename,
PackageEditors.OnGetUnitRegisterInfo) of
case TPrjFileCheck.AddingFile(LazProject, NewFilename) of
mrOk: if not (AddOneFile(NewFilename) in [mrOk, mrIgnore]) then
break;
mrIgnore: continue;

5
packager/packagedefs.pas
View File

@ -3371,7 +3371,6 @@ function TLazPackage.AddFileByName(aFilename: string;
var
NewFileType: TPkgFileType;
NewUnitName: String;
HasRegister: Boolean;
NewFlags: TPkgFileFlags;
Code: TCodeBuffer;
CurDir: String;
@ -3383,7 +3382,6 @@ begin
if FindPkgFile(aFilename,true,false)<>nil then Exit(False);
NewFileType:=FileNameToPkgFileType(aFilename);
NewFlags:=[];
HasRegister:=false;
NewUnitName:='';
if (NewFileType=pftUnit) then begin
Code:=CodeToolBoss.LoadFile(aFilename,true,false);
@ -3392,8 +3390,7 @@ begin
//if NewUnitName='' then NewUnitName:=ExtractFileNameOnly(aFilename);
if FindUsedUnit(NewUnitName)=nil then
Include(NewFlags,pffAddToPkgUsesSection);
CodeToolBoss.HasInterfaceRegisterProc(Code,HasRegister);
if HasRegister then
if CodeToolBoss.HasInterfaceRegisterProc(Code) then
Include(NewFlags,pffHasRegisterProc);
end;
AddFile(aFilename,NewUnitName,NewFileType,NewFlags,cpNormal);

67
packager/packageeditor.pas
View File

@ -607,8 +607,7 @@ begin
PkgFile:=TPkgFile(Item);
AFilename:=PkgFile.GetFullFilename;
if TPkgFileCheck.ReAddingUnit(LazPackage, PkgFile.FileType, AFilename,
PackageEditors.OnGetIDEFileInfo,
PackageEditors.OnGetUnitRegisterInfo)<>mrOk then exit;
PackageEditors.OnGetIDEFileInfo)<>mrOk then exit;
//PkgFile.Filename:=AFilename;
Assert(PkgFile.Filename=AFilename, 'TPackageEditorForm.ReAddMenuItemClick: Unexpected Filename.');
LazPackage.UnremovePkgFile(PkgFile);
@ -1365,7 +1364,7 @@ procedure TPackageEditorForm.FormDropFiles(Sender: TObject;
const FileNames: array of String);
var
i: Integer;
NewUnitPaths, NewIncPaths: String;
NewFilename, NewUnitPaths, NewIncPaths: String;
begin
{$IFDEF VerbosePkgEditDrag}
debugln(['TPackageEditorForm.FormDropFiles ',length(FileNames)]);
@ -1376,7 +1375,12 @@ begin
NewUnitPaths:='';
NewIncPaths:='';
for i:=0 to high(Filenames) do
LazPackage.AddFileByName(FileNames[i], NewUnitPaths, NewIncPaths);
begin
NewFilename:=FileNames[i];
if TPkgFileCheck.AddingUnit(LazPackage, NewFilename,
PackageEditors.OnGetIDEFileInfo)=mrOK then
LazPackage.AddFileByName(NewFilename, NewUnitPaths, NewIncPaths);
end;
//UpdateAll(false);
// extend unit and include search path
if not LazPackage.ExtendUnitSearchPath(NewUnitPaths) then exit;
@ -1477,8 +1481,7 @@ begin
begin
NewFilename:=OpenDialog.Files[i];
if TPkgFileCheck.AddingUnit(LazPackage, NewFilename,
PackageEditors.OnGetIDEFileInfo,
PackageEditors.OnGetUnitRegisterInfo)=mrOK then
PackageEditors.OnGetIDEFileInfo)=mrOK then
LazPackage.AddFileByName(NewFilename, NewUnitPaths, NewIncPaths);
end;
//UpdateAll(false);
@ -1916,41 +1919,35 @@ end;
procedure TPackageEditorForm.DoAddNewFile(NewItem: TNewIDEItemTemplate);
var
NewFilename: String;
DummyResult: TModalResult;
NewFileType: TPkgFileType;
NewPkgFileFlags: TPkgFileFlags;
NewFlags: TPkgFileFlags;
Desc: TProjectFileDescriptor;
NewUnitName: String;
HasRegisterProc: Boolean;
HasRegProc: Boolean;
begin
if NewItem is TNewItemProjectFile then begin
// create new file
Desc:=TNewItemProjectFile(NewItem).Descriptor;
NewFilename:='';
DummyResult:=LazarusIDE.DoNewFile(Desc,NewFilename,'',
[nfOpenInEditor,nfCreateDefaultSrc,nfIsNotPartOfProject],LazPackage);
if DummyResult=mrOk then begin
// success -> now add it to package
NewUnitName:='';
NewFileType:=FileNameToPkgFileType(NewFilename);
NewPkgFileFlags:=[];
if (NewFileType in PkgFileUnitTypes) then begin
Include(NewPkgFileFlags,pffAddToPkgUsesSection);
NewUnitName:=ExtractFilenameOnly(NewFilename);
if Assigned(PackageEditors.OnGetUnitRegisterInfo) then begin
HasRegisterProc:=false;
PackageEditors.OnGetUnitRegisterInfo(Self,NewFilename,
NewUnitName,HasRegisterProc);
if HasRegisterProc then
Include(NewPkgFileFlags,pffHasRegisterProc);
end;
end;
LazPackage.AddFile(NewFilename,NewUnitName,NewFileType,
NewPkgFileFlags, cpNormal);
FreeAndNil(FNextSelectedPart);
FNextSelectedPart:=TPENodeData.Create(penFile,NewFilename,false);
if not (NewItem is TNewItemProjectFile) then exit;
// create new file
Desc:=TNewItemProjectFile(NewItem).Descriptor;
NewFilename:='';
if LazarusIDE.DoNewFile(Desc,NewFilename,'',
[nfOpenInEditor,nfCreateDefaultSrc,nfIsNotPartOfProject],LazPackage)<>mrOk
then exit;
// success -> now add it to package
NewUnitName:='';
NewFileType:=FileNameToPkgFileType(NewFilename);
NewFlags:=[];
if (NewFileType in PkgFileUnitTypes) then begin
Include(NewFlags,pffAddToPkgUsesSection);
NewUnitName:=ExtractFilenameOnly(NewFilename);
if Assigned(PackageEditors.OnGetUnitRegisterInfo) then begin
PackageEditors.OnGetUnitRegisterInfo(Self,NewFilename,NewUnitName,HasRegProc);
if HasRegProc then
Include(NewFlags,pffHasRegisterProc);
end;
end;
LazPackage.AddFile(NewFilename,NewUnitName,NewFileType,NewFlags,cpNormal);
FreeAndNil(FNextSelectedPart);
FNextSelectedPart:=TPENodeData.Create(penFile,NewFilename,false);
end;
function TPackageEditorForm.ShowNewCompDialog: TModalResult;

11
packager/pkgmanager.pas
View File

@ -1530,7 +1530,7 @@ begin
if CodeBuffer<>nil then begin
TheUnitName:=CodeToolBoss.GetSourceName(CodeBuffer,false);
if not ErrorsHandled then exit;
CodeToolBoss.HasInterfaceRegisterProc(CodeBuffer,HasRegisterProc);
HasRegisterProc:=CodeToolBoss.HasInterfaceRegisterProc(CodeBuffer);
if not ErrorsHandled then exit;
end;
if TheUnitName='' then
@ -1598,8 +1598,7 @@ begin
end;
// load package
APackage:=LoadInstalledPackage(StaticPackage^.Name,KeepInstalledPackages,
Quiet);
APackage:=LoadInstalledPackage(StaticPackage^.Name,KeepInstalledPackages,Quiet);
PackageGraph.RegisterStaticPackage(APackage,StaticPackage^.RegisterProc);
end;
@ -2609,10 +2608,8 @@ var
NewAddToUses:=true;
if NewFileType=pftUnit then begin
Code:=CodeToolBoss.LoadFile(OldFilename,true,false);
if (Code<>nil) then begin
if TargetPackage<>nil then
CodeToolBoss.HasInterfaceRegisterProc(Code,NewHasRegisterProc);
end;
if (Code<>nil) and (TargetPackage<>nil) then
NewHasRegisterProc:=CodeToolBoss.HasInterfaceRegisterProc(Code);
end;
end;

65
packager/projpackchecks.pas
View File

@ -10,6 +10,8 @@ uses
LCLProc, Forms, Dialogs,
// LazUtils
FileUtil, LazFileUtils, UITypes,
// Codetools
CodeToolManager, CodeCache,
// BuildIntf
PackageIntf, PackageDependencyIntf,
// IDEIntf
@ -21,8 +23,7 @@ type
TProjPackFileCheck = class
protected
class function UnitNameOk(const AFilename, AUnitFilename: string;
OnGetUnitRegisterInfo: TOnGetUnitRegisterInfo): TModalResult;
class function UnitNameOk(const AFilename, AUnitFilename: string): TModalResult;
public
end;
@ -39,12 +40,10 @@ type
public
class function ReadOnlyOk(LazPackage: TLazPackage): TModalResult;
class function AddingUnit(LazPackage: TLazPackage; const AFilename: string;
OnGetIDEFileInfo: TGetIDEFileStateEvent;
OnGetUnitRegisterInfo: TOnGetUnitRegisterInfo): TModalResult;
OnGetIDEFileInfo: TGetIDEFileStateEvent): TModalResult;
class function ReAddingUnit(LazPackage: TLazPackage;
FileTyp: TPkgFileType; const AFilename: string;
OnGetIDEFileInfo: TGetIDEFileStateEvent;
OnGetUnitRegisterInfo: TOnGetUnitRegisterInfo): TModalResult;
OnGetIDEFileInfo: TGetIDEFileStateEvent): TModalResult;
class function AddingDependency(LazPackage: TLazPackage;
NewDependency: TPkgDependency; WarnIfAlreadyThere: boolean): TModalResult;
end;
@ -54,10 +53,8 @@ type
TPrjFileCheck = class(TProjPackFileCheck)
private
public
class function AddingFile(AProject: TProject; const AFilename: string;
OnGetUnitRegisterInfo: TOnGetUnitRegisterInfo): TModalResult;
class function AddingDependency(AProject: TProject;
NewDependency: TPkgDependency): TModalResult;
class function AddingFile(AProject: TProject; const AFilename: string): TModalResult;
class function AddingDependency(AProject: TProject; NewDependency: TPkgDependency): TModalResult;
end;
// Project or Package using the common interface
@ -82,21 +79,19 @@ end;
{ TProjPackFileCheck }
class function TProjPackFileCheck.UnitNameOk(const AFilename, AUnitFilename: string;
OnGetUnitRegisterInfo: TOnGetUnitRegisterInfo): TModalResult;
class function TProjPackFileCheck.UnitNameOk(const AFilename, AUnitFilename: string): TModalResult;
// This is called only for Pascal units.
var
Unit_Name: string;
HasRegisterProc: boolean;
CodeBuffer: TCodeBuffer;
begin
Result:=mrCancel;
// valid unitname
if Assigned(OnGetUnitRegisterInfo) then
begin
OnGetUnitRegisterInfo(Nil, AFilename, Unit_Name, HasRegisterProc);
//if HasRegisterProc then
// Include(PkgFileFlags,pffHasRegisterProc);
end;
Unit_Name:='';
CodeBuffer:=CodeToolBoss.LoadFile(AFilename,true,false);
if CodeBuffer<>nil then
Unit_Name:=CodeToolBoss.GetSourceName(CodeBuffer,false);
Assert(Unit_Name<>'', 'TProjPackFileCheck.UnitNameOk: Unit_Name is empty.');
if CompareText(Unit_Name, AUnitFilename)<>0 then
if IDEMessageDialog(lisA2PInvalidUnitName,
Format(lisA2PTheUnitNameAndFilenameDiffer,[Unit_Name,LineEnding,AUnitFilename]),
@ -111,9 +106,6 @@ begin
end;
// Pascal extension
Assert(FilenameIsPascalUnit(AFilename), 'TPkgFileCheck.UnitNameOk: Wrong extension.');
//IDEMessageDialog(lisA2PFileNotUnit, lisA2PPascalUnitsMustHaveTheExtensionPPOrPas,
// mtWarning,[mbCancel]);
Result:=mrOK;
end;
@ -235,15 +227,11 @@ begin
end;
class function TPkgFileCheck.AddingUnit(LazPackage: TLazPackage;
const AFilename: string; OnGetIDEFileInfo: TGetIDEFileStateEvent;
OnGetUnitRegisterInfo: TOnGetUnitRegisterInfo): TModalResult;
const AFilename: string; OnGetIDEFileInfo: TGetIDEFileStateEvent): TModalResult;
var
NewFileType: TPkgFileType;
UnitFilename: String;
begin
// normalize filename
//Result:=NormalizeFN(LazPackage, AFilename);
//if Result<>mrOK then exit;
Assert(FilenameIsAbsolute(AFilename), 'TPkgFileCheck.AddingUnit: Not absolute Filename.');
// file exists
Result:=FileExistsOk(LazPackage, AFilename);
@ -252,12 +240,12 @@ begin
Result:=PartOfProjectOk(AFilename, OnGetIDEFileInfo);
if Result<>mrOK then exit;
NewFileType:=FileNameToPkgFileType(AFilename); //FilenameIsPascalUnit ExtractFileNameOnly
NewFileType:=FileNameToPkgFileType(AFilename);
if NewFileType<>pftUnit then
exit(mrOK); // Further checks only for Pascal units.
UnitFilename:=ExtractFileNameOnly(AFilename);
// unitname
Result:=UnitNameOk(AFilename, UnitFilename, OnGetUnitRegisterInfo);
Result:=UnitNameOk(AFilename, UnitFilename);
if Result<>mrOK then exit;
// unit is unique
Result:=UniqueUnitOk(LazPackage, UnitFilename);
@ -267,20 +255,10 @@ end;
class function TPkgFileCheck.ReAddingUnit(LazPackage: TLazPackage;
FileTyp: TPkgFileType; const AFilename: string;
OnGetIDEFileInfo: TGetIDEFileStateEvent;
OnGetUnitRegisterInfo: TOnGetUnitRegisterInfo): TModalResult;
OnGetIDEFileInfo: TGetIDEFileStateEvent): TModalResult;
var
UnitFilename: String;
begin
// is readonly
{ Result:=ReadOnlyOk(LazPackage);
if Result<>mrOK then exit;
// normalize filename
if AddFileType<>d2ptVirtualUnit then
begin
Result:=NormalizeFN(LazPackage, AFilename);
if Result<>mrOK then exit;
end; }
Assert(FilenameIsAbsolute(AFilename), 'TPkgFileCheck.ReAddingUnit: Not absolute Filename.');
// file exists
Result:=FileExistsOk(LazPackage, AFilename);
@ -292,7 +270,7 @@ begin
exit(mrOK); // Further checks only for Pascal units.
UnitFilename:=ExtractFileNameOnly(AFilename);
// unitname
Result:=UnitNameOk(AFilename, UnitFilename, OnGetUnitRegisterInfo);
Result:=UnitNameOk(AFilename, UnitFilename);
if Result<>mrOK then exit;
// unit is unique
Result:=UniqueUnitOk(LazPackage, UnitFilename);
@ -398,8 +376,7 @@ end;
{ TPrjFileCheck }
class function TPrjFileCheck.AddingFile(AProject: TProject; const AFilename: string;
OnGetUnitRegisterInfo: TOnGetUnitRegisterInfo): TModalResult;
class function TPrjFileCheck.AddingFile(AProject: TProject; const AFilename: string): TModalResult;
// Returns mrOk=can be added, mrCancel=do not add, mrIgnore=already there
var
NewFile: TUnitInfo;
@ -415,7 +392,7 @@ begin
if FilenameIsPascalUnit(AFilename) then
begin
UnitFilename:=ExtractFileNameOnly(AFilename);
Result:=UnitNameOk(AFilename, UnitFilename, OnGetUnitRegisterInfo);
Result:=UnitNameOk(AFilename, UnitFilename);
if Result<>mrOK then exit;
// check if unitname already exists in project
ConflictFile:=AProject.UnitWithUnitname(UnitFileName);