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

IDE: Move sub-functions into private methods in TLazarusBuilder.

Browse Source 
git-svn-id: trunk@44046 -
This commit is contained in:
juha 2014-02-13 15:54:09 +00:00
parent d7ac5727f1
commit 4b8ccdafdb
1 changed files with 160 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

316
ide/buildlazdialog.pas
View File

@ -161,8 +161,16 @@ type
fOutputDirRedirected: boolean; fOutputDirRedirected: boolean;
fTargetFilename: string; fTargetFilename: string;
fProfileChanged: boolean; fProfileChanged: boolean;
// Methods used by MakeLazarus :
procedure ApplyCleanOnce;
function CheckDirectoryWritable(Dir: string): boolean;
procedure CleanLazarusSrcDir(Dir: string; Recursive: boolean = true);
procedure CheckRevisionInc;
procedure RestoreBackup;
// Method used by SaveIDEMakeOptions :
function BreakExtraOptions: string;
// This is used by MakeLazarus, IsWriteProtected and SaveIDEMakeOptions
function CreateIDEMakeOptions(Profile: TBuildLazarusProfile; Flags: TBuildLazarusFlags): TModalResult; function CreateIDEMakeOptions(Profile: TBuildLazarusProfile; Flags: TBuildLazarusFlags): TModalResult;
function IsWriteProtected(Profile: TBuildLazarusProfile): Boolean;
public public
{$IFNDEF EnableNewExtTools} {$IFNDEF EnableNewExtTools}
ExternalTools: TBaseExternalToolList; ExternalTools: TBaseExternalToolList;
@ -170,6 +178,7 @@ type
constructor Create; constructor Create;
function ShowConfigureBuildLazarusDlg(AProfiles: TBuildLazarusProfiles): TModalResult; function ShowConfigureBuildLazarusDlg(AProfiles: TBuildLazarusProfiles): TModalResult;
function MakeLazarus(Profile: TBuildLazarusProfile; Flags: TBuildLazarusFlags): TModalResult; function MakeLazarus(Profile: TBuildLazarusProfile; Flags: TBuildLazarusFlags): TModalResult;
function IsWriteProtected(Profile: TBuildLazarusProfile): Boolean;
function SaveIDEMakeOptions(Profile: TBuildLazarusProfile; Flags: TBuildLazarusFlags): TModalResult; function SaveIDEMakeOptions(Profile: TBuildLazarusProfile; Flags: TBuildLazarusFlags): TModalResult;
public public
property PackageOptions: string read fPackageOptions write fPackageOptions; property PackageOptions: string read fPackageOptions write fPackageOptions;
@ -226,110 +235,107 @@ begin
end; end;
end; end;
procedure TLazarusBuilder.ApplyCleanOnce;
begin
if not fProfile.CleanOnce then exit;
if fProfile.IdeBuildMode=bmBuild then exit;
fProfile.IdeBuildMode:=bmBuild;
fProfileChanged:=true;
end;
function TLazarusBuilder.CheckDirectoryWritable(Dir: string): boolean;
begin
if DirectoryIsWritableCached(Dir) then exit(true);
Result:=false;
IDEMessageDialog(lisBuildingLazarusFailed,
Format(lisThisSetOfOptionsToBuildLazarusIsNotSupportedByThis,
[LineEnding, '"', Dir, '"', LineEnding]),
mtError,[mbCancel]);
end;
procedure TLazarusBuilder.CleanLazarusSrcDir(Dir: string; Recursive: boolean = true);
var
FileInfo: TSearchRec;
Ext: String;
Filename: TFilename;
begin
Dir:=AppendPathDelim(TrimFilename(Dir));
if FindFirstUTF8(Dir+AllFilesMask,faAnyFile,FileInfo)=0 then begin
repeat
if (FileInfo.Name='') or (FileInfo.Name='.') or (FileInfo.Name='..')
or (FileInfo.Name='.svn') or (FileInfo.Name='.git')
then
continue;
Filename:=Dir+FileInfo.Name;
if faDirectory and FileInfo.Attr>0 then
begin
if Recursive then
CleanLazarusSrcDir(Filename)
end
else begin
Ext:=LowerCase(ExtractFileExt(FileInfo.Name));
if (Ext='.ppu') or (Ext='.o') or (Ext='.rst') or (Ext='.rsj') then begin
if not DeleteFileUTF8(Filename) then
debugln(['CleanLazarusSrcDir failed to delete file "',Filename,'"']);
end;
end;
until FindNextUTF8(FileInfo)<>0;
end;
FindCloseUTF8(FileInfo);
end;
procedure TLazarusBuilder.CheckRevisionInc;
var
RevisionIncFile: String;
sl: TStringList;
begin
RevisionIncFile:=AppendPathDelim(EnvironmentOptions.GetParsedLazarusDirectory)+'ide'+PathDelim+'revision.inc';
if not FileExistsUTF8(RevisionIncFile) then begin
debugln(['Note: revision.inc file missing: ',RevisionIncFile]);
sl:=TStringList.Create;
sl.Add('// Created by lazbuild');
sl.Add('const RevisionStr = '''+LazarusVersionStr+''';');
try
sl.SaveToFile(RevisionIncFile);
except
on E: Exception do begin
debugln(['Note: can not write ',RevisionIncFile,': ',E.Message]);
end;
end;
sl.Free;
end;
end;
procedure TLazarusBuilder.RestoreBackup;
var
BackupFilename: String;
begin
if FileExistsUTF8(fTargetFilename) then begin
if not DeleteFileUTF8(fTargetFilename) then begin
debugln(['Building IDE failed. Can not delete "',fTargetFilename,'"']);
exit;
end;
end;
BackupFilename:=GetBackupExeFilename(fTargetFilename);
if FileExistsUTF8(BackupFilename) then begin
if not RenameFileUTF8(BackupFilename,fTargetFilename) then begin
debugln(['Building IDE failed. Can not restore backup file "',BackupFilename,'" to "',fTargetFilename,'"']);
end;
end;
end;
function TLazarusBuilder.MakeLazarus(Profile: TBuildLazarusProfile; function TLazarusBuilder.MakeLazarus(Profile: TBuildLazarusProfile;
Flags: TBuildLazarusFlags): TModalResult; Flags: TBuildLazarusFlags): TModalResult;
procedure ApplyCleanOnce;
begin
if not Profile.CleanOnce then exit;
if Profile.IdeBuildMode=bmBuild then exit;
Profile.IdeBuildMode:=bmBuild;
fProfileChanged:=true;
end;
function CheckDirectoryWritable(Dir: string): boolean;
begin
if DirectoryIsWritableCached(Dir) then exit(true);
Result:=false;
IDEMessageDialog(lisBuildingLazarusFailed,
Format(lisThisSetOfOptionsToBuildLazarusIsNotSupportedByThis,
[LineEnding, '"', Dir, '"', LineEnding]),
mtError,[mbCancel]);
end;
procedure CleanLazarusSrcDir(Dir: string; Recursive: boolean = true);
var
FileInfo: TSearchRec;
Ext: String;
Filename: TFilename;
begin
Dir:=AppendPathDelim(TrimFilename(Dir));
if FindFirstUTF8(Dir+AllFilesMask,faAnyFile,FileInfo)=0 then begin
repeat
if (FileInfo.Name='') or (FileInfo.Name='.') or (FileInfo.Name='..')
or (FileInfo.Name='.svn') or (FileInfo.Name='.git')
then
continue;
Filename:=Dir+FileInfo.Name;
if faDirectory and FileInfo.Attr>0 then
begin
if Recursive then
CleanLazarusSrcDir(Filename)
end
else begin
Ext:=LowerCase(ExtractFileExt(FileInfo.Name));
if (Ext='.ppu') or (Ext='.o') or (Ext='.rst') or (Ext='.rsj') then begin
if not DeleteFileUTF8(Filename) then
debugln(['CleanLazarusSrcDir failed to delete file "',Filename,'"']);
end;
end;
until FindNextUTF8(FileInfo)<>0;
end;
FindCloseUTF8(FileInfo);
end;
procedure CheckRevisionInc;
var
RevisionIncFile: String;
sl: TStringList;
begin
RevisionIncFile:=AppendPathDelim(EnvironmentOptions.GetParsedLazarusDirectory)+'ide'+PathDelim+'revision.inc';
if not FileExistsUTF8(RevisionIncFile) then begin
debugln(['Note: revision.inc file missing: ',RevisionIncFile]);
sl:=TStringList.Create;
sl.Add('// Created by lazbuild');
sl.Add('const RevisionStr = '''+LazarusVersionStr+''';');
try
sl.SaveToFile(RevisionIncFile);
except
on E: Exception do begin
debugln(['Note: can not write ',RevisionIncFile,': ',E.Message]);
end;
end;
sl.Free;
end;
end;
procedure RestoreBackup(LazExeFilename: string);
var
BackupFilename: String;
begin
if FileExistsUTF8(LazExeFilename) then begin
if not DeleteFileUTF8(LazExeFilename) then begin
debugln(['Building IDE failed. Can not delete "',LazExeFilename,'"']);
exit;
end;
end;
BackupFilename:=GetBackupExeFilename(LazExeFilename);
if FileExistsUTF8(BackupFilename) then begin
if not RenameFileUTF8(BackupFilename,LazExeFilename) then begin
debugln(['Building IDE failed. Can not restore backup file "',BackupFilename,'" to "',LazExeFilename,'"']);
end;
end;
end;
var var
{$IFDEF EnableNewExtTools} {$IFDEF EnableNewExtTools}
Tool: TAbstractExternalTool; Tool: TAbstractExternalTool;
{$ELSE} {$ELSE}
Tool: TExternalToolOptions; Tool: TExternalToolOptions;
{$ENDIF} {$ENDIF}
WorkingDirectory: String; WorkingDirectory, Executable, CmdLineParams, Cmd: String;
Executable: String;
EnvironmentOverrides: TStringList; EnvironmentOverrides: TStringList;
CmdLineParams: String;
function Run(CurTitle, Cmd: string): TModalResult; function Run(CurTitle: string): TModalResult;
var var
Params: String; Params: String;
begin begin
@ -370,8 +376,7 @@ var
var var
IdeBuildMode: TIdeBuildMode; IdeBuildMode: TIdeBuildMode;
Dir: String; s: String;
Cmd: String;
begin begin
Result:=mrCancel; Result:=mrCancel;
@ -385,9 +390,9 @@ begin
// setup external tool // setup external tool
EnvironmentOverrides.Values['LCL_PLATFORM']:=LCLPlatformDirNames[Profile.TargetPlatform]; EnvironmentOverrides.Values['LCL_PLATFORM']:=LCLPlatformDirNames[Profile.TargetPlatform];
EnvironmentOverrides.Values['LANG']:= 'en_US'; EnvironmentOverrides.Values['LANG']:= 'en_US';
Dir:=EnvironmentOptions.GetParsedCompilerFilename; s:=EnvironmentOptions.GetParsedCompilerFilename;
if Dir<>'' then if s<>'' then
EnvironmentOverrides.Values['PP']:=Dir; EnvironmentOverrides.Values['PP']:=s;
Executable:=EnvironmentOptions.GetParsedMakeFilename; Executable:=EnvironmentOptions.GetParsedMakeFilename;
if (Executable<>'') and (not FileExistsUTF8(Executable)) then if (Executable<>'') and (not FileExistsUTF8(Executable)) then
@ -437,9 +442,9 @@ begin
// clean custom target directory // clean custom target directory
if Profile.TargetDirectory<>'' then begin if Profile.TargetDirectory<>'' then begin
Dir:=Profile.GetParsedTargetDirectory(fMacros); s:=Profile.GetParsedTargetDirectory(fMacros);
if (Dir<>'') and DirPathExists(Dir) then if (s<>'') and DirPathExists(s) then
CleanLazarusSrcDir(Dir); CleanLazarusSrcDir(s);
end; end;
end; end;
@ -448,7 +453,7 @@ begin
Cmd:='cleanide' Cmd:='cleanide'
else else
Cmd:='cleanlaz'; Cmd:='cleanlaz';
Result:=Run(lisCleanLazarusSource,Cmd); Result:=Run(lisCleanLazarusSource);
if Result<>mrOk then exit; if Result<>mrOk then exit;
ApplyCleanOnce; ApplyCleanOnce;
@ -478,13 +483,13 @@ begin
EnvironmentOverrides.Values['USESVN2REVISIONINC'] := '0'; EnvironmentOverrides.Values['USESVN2REVISIONINC'] := '0';
end; end;
// run // run
Result:=Run(lisIDE,Cmd); Result:=Run(lisIDE);
// clean only once. If building failed the user must first fix the error // clean only once. If building failed the user must first fix the error
// before a clean build is needed. // before a clean build is needed.
ApplyCleanOnce; ApplyCleanOnce;
if Result<>mrOk then begin if Result<>mrOk then begin
// build failed: restore backup of lazarus.exe // build failed: restore backup of lazarus.exe
RestoreBackup(fTargetFilename); RestoreBackup;
exit; exit;
end; end;
end; end;
@ -812,57 +817,56 @@ begin
Result:=True; Result:=True;
end; end;
function TLazarusBuilder.BreakExtraOptions: string;
var
StartPos: Integer;
EndPos: Integer;
c: Char;
CurLine: String;
begin
Result:='';
// write each option into a line of its own
StartPos:=1;
repeat
while (StartPos<=length(fExtraOptions)) and (fExtraOptions[StartPos]=' ') do
inc(StartPos);
EndPos:=StartPos;
while EndPos<=length(fExtraOptions) do begin
c:=fExtraOptions[EndPos];
case c of
' ': break;
'''','"','`':
begin
repeat
inc(EndPos);
if (fExtraOptions[EndPos]=c) then begin
inc(EndPos);
break;
end;
until (EndPos>length(fExtraOptions));
end;
else
inc(EndPos);
end;
end;
if (EndPos>StartPos) then begin
CurLine:=Trim(copy(fExtraOptions,StartPos,EndPos-StartPos));
if (length(CurLine)>2) and (CurLine[1] in ['''','"','`'])
and (CurLine[1]=CurLine[length(CurLine)]) then begin
// whole line enclosed in quotation marks
// in fpc config this is forbidden and gladfully unncessary
CurLine:=copy(CurLine,2,length(CurLine)-2);
end;
Result:=Result+CurLine+LineEnding;
end;
StartPos:=EndPos;
until StartPos>length(fExtraOptions);
end;
function TLazarusBuilder.SaveIDEMakeOptions(Profile: TBuildLazarusProfile; function TLazarusBuilder.SaveIDEMakeOptions(Profile: TBuildLazarusProfile;
Flags: TBuildLazarusFlags): TModalResult; Flags: TBuildLazarusFlags): TModalResult;
function BreakOptions(const OptionString: string): string;
var
StartPos: Integer;
EndPos: Integer;
c: Char;
CurLine: String;
begin
Result:='';
// write each option into a line of its own
StartPos:=1;
repeat
while (StartPos<=length(OptionString)) and (OptionString[StartPos]=' ') do
inc(StartPos);
EndPos:=StartPos;
while EndPos<=length(OptionString) do begin
c:=OptionString[EndPos];
case c of
' ': break;
'''','"','`':
begin
repeat
inc(EndPos);
if (OptionString[EndPos]=c) then begin
inc(EndPos);
break;
end;
until (EndPos>length(OptionString));
end;
else
inc(EndPos);
end;
end;
if (EndPos>StartPos) then begin
CurLine:=Trim(copy(OptionString,StartPos,EndPos-StartPos));
if (length(CurLine)>2) and (CurLine[1] in ['''','"','`'])
and (CurLine[1]=CurLine[length(CurLine)]) then begin
// whole line enclosed in quotation marks
// in fpc config this is forbidden and gladfully unncessary
CurLine:=copy(CurLine,2,length(CurLine)-2);
end;
Result:=Result+CurLine+LineEnding;
end;
StartPos:=EndPos;
until StartPos>length(OptionString);
end;
var var
Filename: String; Filename: String;
fs: TFileStreamUTF8; fs: TFileStreamUTF8;
@ -877,7 +881,7 @@ begin
fs:=TFileStreamUTF8.Create(Filename,fmCreate); fs:=TFileStreamUTF8.Create(Filename,fmCreate);
try try
if fExtraOptions<>'' then begin if fExtraOptions<>'' then begin
OptionsAsText:=BreakOptions(fExtraOptions); OptionsAsText:=BreakExtraOptions;
fs.Write(OptionsAsText[1],length(OptionsAsText)); fs.Write(OptionsAsText[1],length(OptionsAsText));
end; end;
finally finally