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

Remove obsolete converter files. Code is moved to convertdelphi.pas + other files.

Browse Source 
git-svn-id: trunk@23744 -
This commit is contained in:
juha 2010-02-19 20:03:50 +00:00
parent ba7a0acf0f
commit f544798b1e
4 changed files with 0 additions and 949 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -2204,9 +2204,6 @@ converter/chgencodingdlg.pas svneol=native#text/plain
converter/convertdelphi.pas svneol=native#text/plain
converter/convertsettings.lfm svneol=native#text/plain
converter/convertsettings.pas svneol=native#text/plain
converter/delphiproject2laz.pas svneol=native#text/plain
converter/delphiunit2laz.lfm svneol=native#text/plain
converter/delphiunit2laz.pas svneol=native#text/pascal
converter/lazxmlforms.pas svneol=native#text/plain
converter/missingunitsunit.lfm svneol=native#text/plain
converter/missingunitsunit.pas svneol=native#text/plain

124
converter/delphiproject2laz.pas
View File

@ -1,124 +0,0 @@
{ $Id: delphiunit2laz.pas 8788 2006-02-20 23:48:13Z mattias $ }
{
/***************************************************************************
delphiunit2laz.pas
------------------
***************************************************************************/
***************************************************************************
* *
* 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:
Functions to convert delphi projects/packages to lazarus projects/packages.
The process of converting a delphi project/package/unit to lazarus contains
some monotone and boring work. These functions try to help here.
Because any conversion step can fail and can need manual fix before
continuing, the functions are written to recognize, what have been done.
So, you can call the delphi conversion, abort at any step, fix a few things,
and invoke it again.
}
unit DelphiProject2Laz;
{$mode objfpc}{$H+}
interface
uses ConvertDelphi,
// LCL+FCL
Classes, SysUtils, LCLProc, Forms, Controls, Dialogs, FileProcs, FileUtil;
// codetools
{ ExprEval, DefineTemplates, CodeCache, CodeToolManager, CodeToolsStructs,
LinkScanner,
// IDEIntf
SrcEditorIntf, ComponentReg, IDEMsgIntf, MainIntf, LazIDEIntf, PackageIntf,
ProjectIntf,
// IDE
IDEProcs, DelphiUnit2Laz, Project, DialogProcs, CheckLFMDlg,
EditorOptions, ProjectInspector, CompilerOptions, PackageDefs, PackageSystem,
PackageEditor,
BasePkgManager, PkgManager; }
const
SettingDelphiModeTemplName = 'Setting Delphi Mode';
type
TConvertDelphiToLazarusUnitFlag = (
cdtlufRenameLowercase, // rename the unit lowercase
cdtlufIsSubProc, // this is part of a big conversion -> add Abort button to all questions
cdtlufCheckLFM, // check and fix LFM
cdtlufIgnoreUsedUnits, // skip steps that require loading used units
cdtlufDoNotSetDelphiMode, // do not set delphi mode for project directories
cdtlufCanAbort // show 'Cancel all' button in error messages using mrAbort
);
TConvertDelphiToLazarusUnitFlags = set of TConvertDelphiToLazarusUnitFlag;
function ConvertDelphiToLazarusUnit(const DelphiFilename: string;
Flags: TConvertDelphiToLazarusUnitFlags): TModalResult;
function ConvertDelphiToLazarusProject(const ProjectFilename: string
): TModalResult;
function ConvertDelphiToLazarusPackage(const PackageFilename: string
): TModalResult;
implementation
function ConvertDelphiToLazarusUnit(const DelphiFilename: string;
Flags: TConvertDelphiToLazarusUnitFlags): TModalResult;
var
Converter: TConvertDelphiUnit;
begin
Converter := TConvertDelphiUnit.Create(nil, DelphiFilename, []);
try
Result:=Converter.Convert;
finally
Converter.Free;
end;
end;
function ConvertDelphiToLazarusProject(const ProjectFilename: string): TModalResult;
var
Converter: TConvertDelphiProject;
begin
Converter := TConvertDelphiProject.Create(ProjectFilename);
try
Result:=Converter.Convert;
finally
Converter.Free;
end;
end;
function ConvertDelphiToLazarusPackage(const PackageFilename: string): TModalResult;
var
Converter: TConvertDelphiPackage;
begin
Converter := TConvertDelphiPackage.Create(PackageFilename);
try
Result:=Converter.Convert;
finally
Converter.Free;
end;
end;
end.

11
converter/delphiunit2laz.lfm
View File

@ -1,11 +0,0 @@
object Delphi2LazarusDialog: TDelphi2LazarusDialog
Caption = 'Repair LFM'
ClientHeight = 341
ClientWidth = 410
HorzScrollBar.Page = 411
VertScrollBar.Page = 342
Left = 368
Height = 341
Top = 200
Width = 410
end

811
converter/delphiunit2laz.pas
View File

@ -1,811 +0,0 @@
{ $Id$ }
{
/***************************************************************************
delphiunit2laz.pas
------------------
***************************************************************************/
***************************************************************************
* *
* 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:
Functions to convert delphi units to lcl units.
}
unit DelphiUnit2Laz;
{$mode objfpc}{$H+}
interface
uses
// FCL+LCL
Classes, SysUtils, LCLProc, LResources, Forms, Controls, Graphics,
Dialogs, Buttons, StdCtrls, FileUtil, IniFiles,
// Components
SynEdit, CodeAtom, CodeCache, CodeToolManager, DefineTemplates,
// IDEIntf
LazIDEIntf, IDEMsgIntf,
// IDE
CompilerOptions,
PackageDefs, Project, DialogProcs, IDEProcs, LazarusIDEStrConsts;
type
TDelphi2LazarusDialog = class(TForm)
private
public
end;
var
Delphi2LazarusDialog: TDelphi2LazarusDialog;
function CheckDelphiFileExt(const Filename: string): TModalResult;
function CheckFilenameForLCLPaths(const Filename: string): TModalResult;
function ConvertDelphiToLazarusFilename(const DelphiFilename: string;
RenameLowercase: boolean): string;
function RenameDelphiUnitToLazarusUnit(const DelphiFilename: string;
RenameDFMFile, RenameLowercase: boolean;
var LazarusFilename, LFMFilename: string): TModalResult;
function FixMissingUnits(const LazarusUnitFilename: string;
IsSubProc, ShowAbort: boolean): TModalResult;
// dfm/lfm
function ConvertDFMToLFMFilename(const DFMFilename: string;
KeepCase: boolean): string;
function FindDFMFileForDelphiUnit(const DelphiFilename: string): string;
function ConvertDFMFileToLFMFile(const DFMFilename: string): TModalResult;
function ConvertDelphiSourceToLazarusSource(const LazarusUnitFilename: string;
AddLRSCode, ShowAbort: boolean): TModalResult;
function LoadUnitAndLFMFile(const UnitFileName: string;
var UnitCode, LFMCode: TCodeBuffer; LFMMustExist, ShowAbort: boolean): TModalResult;
function ConvertLFMtoLRSfile(const LFMFilename: string): TModalResult;
// projects
function CheckDelphiProjectExt(const Filename: string): TModalResult;
function CreateLPRFileForDPRFile(const DPRFilename, LPRFilename: string;
out LPRCode: TCodeBuffer; ShowAbort: boolean): TModalResult;
// packages
function ExtractOptionsFromDPK(const Filename: string;
APackage: TLazPackage): TModalResult;
// projects/packages
function FindDelphiDOF(const DelphiFilename: string): string;
function ExtractOptionsFromDOF(const DOFFilename: string;
AProjPkg: TObject): TModalResult;
function FindDelphiCFG(const DelphiFilename: string): string;
function ExtractOptionsFromCFG(const CFGFilename: string;
AProjPkg: TObject): TModalResult;
function ExtractOptionsFromDelphiSource(const Filename: string;
AProjPkg: TObject): TModalResult;
// file names / search paths
function ConvertDelphiAbsoluteToRelativeFile(const Filename: string;
AProject: TProject): string;
function ExpandDelphiFilename(const Filename: string; AProject: TProject): string;
function ExpandDelphiSearchPath(const SearchPath: string;
AProject: TProject): string;
implementation
{$R *.lfm}
function CheckDelphiFileExt(const Filename: string): TModalResult;
begin
if CompareFileExt(Filename,'.pas',false)<>0 then begin
Result:=QuestionDlg(lisNotADelphiUnit,
Format(lisTheFileIsNotADelphiUnit, ['"', Filename, '"']),
mtError,[mrCancel,'Skip this file',mbAbort,'Abort'],0);
exit;
end;
Result:=mrOk;
end;
function CheckFilenameForLCLPaths(const Filename: string): TModalResult;
// check if the unitpath of the directory of filename contains the path to the
// LCL
var
Directory: String;
UnitPath: String;
LazarusSrcDir: string;
LCLPath: String;
NextStartPos: Integer;
begin
// get directory of filename
Directory:=ExtractFilePath(Filename);
// get unitpath definition of directory
UnitPath:=CodeToolBoss.GetUnitPathForDirectory(Directory);
// get lazarus source directory
LazarusSrcDir:=
CodeToolBoss.GlobalValues.Variables[ExternalMacroStart+'LazarusDir'];
// create base path to LCL compiled units <LazarusSrcDir>/lcl/units/
LCLPath:=TrimFilename(LazarusSrcDir+SetDirSeparators('/lcl/units/'));
NextStartPos:=1;
//writeln('CheckFilenameForLCLPaths UnitPath="',UnitPath,'" LCLPath="',LCLPath,'"');
if GetNextUsedDirectoryInSearchPath(UnitPath,LCLPath,NextStartPos)='' then
begin
LCLPath:=LCLPath+'$(TargetCPU)-$(TargetOS)';
Result:=QuestionDlg(lisLCLUnitPathMissing,
Format(lisTheCurrentUnitPathForTheFileIsThePathToTheLCLUnits, [#13, '"',
Filename, '"', #13, '"', UnitPath, '"', #13, #13, '"', LCLPath, '"',
#13, #13, #13]),
mtError,[mrCancel,'Skip this step',mrAbort,'Abort'],0);
exit;
end;
Result:=mrOk;
end;
function ConvertDelphiToLazarusFilename(const DelphiFilename: string;
RenameLowercase: boolean): string;
begin
if RenameLowercase then
Result:=ExtractFilePath(DelphiFilename)
+lowercase(ExtractFileName(DelphiFilename))
else
Result:=DelphiFilename;
end;
function ConvertDFMToLFMFilename(const DFMFilename: string;
KeepCase: boolean): string;
begin
if DFMFilename<>'' then begin
// platform and fpc independent unitnames are lowercase, so are the lfm files
Result:=lowercase(ExtractFilenameOnly(DFMFilename));
if KeepCase then
Result:=ExtractFilenameOnly(DFMFilename);
Result:=ExtractFilePath(DFMFilename)+Result+'.lfm';
end else
Result:='';
end;
function FindDFMFileForDelphiUnit(const DelphiFilename: string): string;
begin
Result:=ChangeFileExt(DelphiFilename,'.dfm');
if FileExistsUTF8(Result) then exit;
Result:=ChangeFileExt(DelphiFilename,'.DFM');
if FileExistsUTF8(Result) then exit;
Result:=ChangeFileExt(DelphiFilename,'.xfm');
if FileExistsUTF8(Result) then exit;
Result:=ChangeFileExt(DelphiFilename,'.XFM');
if FileExistsUTF8(Result) then exit;
Result:='';
end;
function RenameDelphiUnitToLazarusUnit(const DelphiFilename: string;
RenameDFMFile, RenameLowercase: boolean;
var LazarusFilename, LFMFilename: string): TModalResult;
var
DFMFilename: String;
begin
LazarusFilename:=ConvertDelphiToLazarusFilename(DelphiFilename,RenameLowercase);
LFMFilename:='';
Result:=RenameFileWithErrorDialogs(DelphiFilename,LazarusFilename,[mbAbort]);
if Result<>mrOK then exit;
if RenameDFMFile then begin
DFMFilename:=FindDFMFileForDelphiUnit(DelphiFilename);
if (DFMFilename<>'') and (CompareFilenames(DFMFilename,LFMFilename)<>0) then
begin
LFMFilename:=ConvertDFMToLFMFilename(DFMFilename,not RenameLowercase);
if FileExistsUTF8(LFMFilename) then begin
if (FileAgeUTF8(LFMFilename)>=FileAgeUTF8(DFMFilename)) then begin
// .lfm is not older than .dfm -> keep .lfm
// beware: it could be the same file
end else begin
// .lfm is older than .dfm -> remove .lfm
DeleteFileUTF8(LFMFilename);
end;
end;
if not FileExistsUTF8(LFMFilename) then begin
// TODO: update project
Result:=RenameFileWithErrorDialogs(DFMFilename,LFMFilename,[mbAbort]);
if Result<>mrOK then exit;
end;
end;
end;
Result:=mrOk;
end;
function ConvertDFMFileToLFMFile(const DFMFilename: string): TModalResult;
var
DFMStream, LFMStream: TMemoryStream;
LFMFilename: string;
begin
Result:=mrOk;
DFMStream:=TMemoryStream.Create;
LFMStream:=TMemoryStream.Create;
try
try
DFMStream.LoadFromFile(UTF8ToSys(DFMFilename));
except
on E: Exception do begin
Result:=QuestionDlg(lisCodeToolsDefsReadError, Format(
lisUnableToReadFileError, ['"', DFMFilename, '"', #13, E.Message]),
mtError,[mrIgnore,mrAbort],0);
exit;
end;
end;
try
FormDataToText(DFMStream,LFMStream);
except
on E: Exception do begin
Result:=QuestionDlg(lisFormatError,
Format(lisUnableToConvertFileError, ['"', DFMFilename, '"', #13,
E.Message]),
mtError,[mrIgnore,mrAbort],0);
exit;
end;
end;
// converting dfm file, without renaming unit -> keep case
LFMFilename:=ConvertDFMToLFMFilename(DFMFilename,true);
try
LFMStream.SaveToFile(UTF8ToSys(LFMFilename));
except
on E: Exception do begin
Result:=MessageDlg(lisCodeToolsDefsWriteError,
Format(lisUnableToWriteFileError, ['"', LFMFilename, '"', #13,
E.Message]),
mtError,[mbIgnore,mbAbort],0);
exit;
end;
end;
finally
LFMSTream.Free;
DFMStream.Free;
end;
end;
function ConvertDelphiSourceToLazarusSource(const LazarusUnitFilename: string;
AddLRSCode, ShowAbort: boolean): TModalResult;
var
LazUnitCode: TCodeBuffer;
CTResult: Boolean;
begin
Result:=LoadCodeBuffer(LazUnitCode,LazarusUnitFilename,
[lbfCheckIfText,lbfUpdateFromDisk],ShowAbort);
if Result<>mrOk then exit;
CTResult:=CodeToolBoss.ConvertDelphiToLazarusSource(LazUnitCode,AddLRSCode);
if not CTResult then begin
DebugLn('ConvertDelphiSourceToLazarusSource Failed');
Result:=mrCancel;
exit;
end;
Result:=mrOk;
end;
function FixMissingUnits(const LazarusUnitFilename: string;
IsSubProc, ShowAbort: boolean): TModalResult;
function MissingUnitNameToMessage(CodeBuf: TCodeBuffer;
const MissingUnit: string): string;
var
p: Integer;
NamePos, InPos: Integer;
Line, Col: Integer;
ShortFilename: String;
AnUnitName: String;
begin
ShortFilename:=ExtractFileName(CodeBuf.Filename);
AnUnitName:=MissingUnit;
// cut 'in' extension
p:=System.Pos(' ',AnUnitName);
if p>0 then
AnUnitName:=copy(AnUnitName,1,p-1);
Line:=1;
Col:=1;
if CodeToolBoss.FindUnitInAllUsesSections(CodeBuf,AnUnitName,
NamePos,InPos)
then begin
if InPos=0 then ;
CodeBuf.AbsoluteToLineCol(NamePos,Line,Col);
end;
Result:=ShortFilename+'('+IntToStr(Line)+','+IntToStr(Col)+') Error: '
+'Can''t find unit '+AnUnitName;
end;
var
LazUnitCode: TCodeBuffer;
CTResult: Boolean;
MissingUnits: TStrings;
MissingUnitsText: String;
i: Integer;
Msg: String;
CurDir: String;
CodePos: PCodeXYPosition;
MissingIncludeFilesCodeXYPos: TFPList;
begin
Result:=LoadCodeBuffer(LazUnitCode,LazarusUnitFilename,
[lbfCheckIfText,lbfUpdateFromDisk],ShowAbort);
if Result<>mrOk then exit;
// fix include filenames
DebugLn('FixMissingUnits fixing include directives ...');
MissingIncludeFilesCodeXYPos:=nil;
try
if not CodeToolBoss.FixIncludeFilenames(LazUnitCode,true,
MissingIncludeFilesCodeXYPos)
then begin
DebugLn('FixMissingUnits Error="',CodeToolBoss.ErrorMessage,'"');
if MissingIncludeFilesCodeXYPos<>nil then begin
for i:=0 to MissingIncludeFilesCodeXYPos.Count-1 do begin
CodePos:=PCodeXYPosition(MissingIncludeFilesCodeXYPos[i]);
Msg:=CodePos^.Code.Filename
+'('+IntToStr(CodePos^.y)+','+IntToStr(CodePos^.x)+')'
+' missing include file';
DebugLn('FixMissingUnits "',Msg,'"');
IDEMessagesWindow.AddMsg(Msg,'',-1);
end;
end;
DebugLn('FixMissingUnits 2 Error="',CodeToolBoss.ErrorMessage,'"');
Result:=JumpToCodetoolErrorAndAskToAbort(IsSubProc);
exit;
end;
finally
CodeToolBoss.FreeListOfPCodeXYPosition(MissingIncludeFilesCodeXYPos);
end;
MissingUnits:=nil;
try
// find missing units
DebugLn('FixMissingUnits FindMissingUnits');
CTResult:=CodeToolBoss.FindMissingUnits(LazUnitCode,MissingUnits,true);
if not CTResult then begin
Result:=JumpToCodetoolErrorAndAskToAbort(IsSubProc);
exit;
end;
if (MissingUnits=nil) or (MissingUnits.Count=0) then begin
// no missing units -> good
Result:=mrOk;
exit;
end;
MissingUnitsText:='';
for i:=0 to MissingUnits.Count-1 do begin
if MissingUnitsText<>'' then
MissingUnitsText:=MissingUnitsText+', ';
MissingUnitsText:=MissingUnitsText+MissingUnits[i];
end;
DebugLn('FixMissingUnits FindMissingUnits="',MissingUnitsText,'"');
// ask user if missing units should be commented
if MissingUnits.Count=1 then
Msg:=lisUnitNotFound
else
Msg:=lisUnitsNotFound2;
Msg:=Msg+' '+ExtractFileName(LazUnitCode.Filename);
// add error messages, so the user can click on them
CurDir:=ExtractFilePath(LazUnitCode.Filename);
for i:=0 to MissingUnits.Count-1 do begin
IDEMessagesWindow.AddMsg(
MissingUnitNameToMessage(LazUnitCode,MissingUnits[i]),CurDir,-1);
end;
// ask user, what to do
Result:=QuestionDlg(Msg,
Format(lisTheFollowingUnitsWereNotFound1EitherTheseUnitsAreN, [#13,
MissingUnitsText, #13, #13, #13]),
mtConfirmation,[mrYes,'Comment missing units',mrAbort],0);
if Result<>mrYes then exit;
// comment missing units
DebugLn('FixMissingUnits CommentUnitsInUsesSections ',MissingUnits.Text);
CTResult:=CodeToolBoss.CommentUnitsInUsesSections(LazUnitCode,MissingUnits);
if not CTResult then begin
Result:=JumpToCodetoolErrorAndAskToAbort(IsSubProc);
exit;
end;
finally
MissingUnits.Free;
end;
Result:=mrOk;
end;
function LoadUnitAndLFMFile(const UnitFileName: string;
var UnitCode, LFMCode: TCodeBuffer; LFMMustExist, ShowAbort: boolean): TModalResult;
var
LFMFilename: string;
begin
UnitCode:=nil;
LFMCode:=nil;
Result:=LoadCodeBuffer(UnitCode,UnitFileName,
[lbfCheckIfText,lbfUpdateFromDisk],ShowAbort);
if Result<>mrOk then exit;
LFMFilename:=ChangeFileExt(UnitFileName,'.lfm');
if FileExistsUTF8(LFMFilename) then begin
Result:=LoadCodeBuffer(LFMCode,LFMFilename,
[lbfCheckIfText,lbfUpdateFromDisk],ShowAbort);
if Result<>mrOk then exit;
end else if LFMMustExist then begin
Result:=QuestionDlg(lisLFMFileNotFound,
Format(lisUnitLFMFile, [UnitFileName, #13, LFMFilename]),
mtError,[mrCancel,'Skip this step',mrAbort,'Cancel all'],0);
end;
end;
function ConvertLFMtoLRSfile(const LFMFilename: string): TModalResult;
begin
if not LFMtoLRSfile(LFMFilename) then begin
Result:=MessageDlg(lisErrorCreatingLrs,
lisUnableToConvertLfmToLrsAndWriteLrsFile,
mtError,[mbCancel],0);
exit;
end;
Result:=mrOk;
end;
function CheckDelphiProjectExt(const Filename: string): TModalResult;
begin
if CompareFileExt(Filename,'.dpr',false)<>0 then begin
Result:=QuestionDlg(lisNotADelphiProject,
Format(lisTheFileIsNotADelphiProjectDpr, ['"', Filename, '"']),
mtError,[mrCancel,'Skipt this step',mbAbort],0);
exit;
end;
Result:=mrOk;
end;
function CreateLPRFileForDPRFile(const DPRFilename, LPRFilename: string;
out LPRCode: TCodeBuffer; ShowAbort: boolean): TModalResult;
begin
if not FileExistsUTF8(LPRFilename) then begin
Result:=CopyFileWithErrorDialogs(DPRFilename,LPRFilename,[]);
if Result<>mrOk then exit;
end;
Result:=LoadCodeBuffer(LPRCode,LPRFilename,
[lbfCheckIfText,lbfUpdateFromDisk],ShowAbort);
end;
function ExtractOptionsFromDelphiSource(const Filename: string;
AProjPkg: TObject): TModalResult;
begin
// TODO remove compiler directives and put them into project/package
Result:=mrOk;
end;
function ExtractOptionsFromDPK(const Filename: string; APackage: TLazPackage
): TModalResult;
begin
// TODO
Result:=mrOk;
end;
function FindDelphiDOF(const DelphiFilename: string): string;
var
Filename: String;
begin
Result:=ChangeFileExt(DelphiFilename,'.dof');
Filename:=FindDiskFileCaseInsensitive(Result);
if Filename<>'' then
Result:=Filename;
end;
function ExtractOptionsFromDOF(const DOFFilename: string; AProjPkg: TObject
): TModalResult;
// parse .dof file and put options into AProject
var
IniFile: TIniFile;
AProject: TProject;
APackage: TLazPackage;
CompOpts: TBaseCompilerOptions;
function ReadDirectory(const Section, Ident: string): string;
begin
Result:=IniFile.ReadString(Section,Ident,'');
DebugLn('.dof ReadDirectory Section=',Section,' Ident=',Ident,' Result="',Result,'"');
Result:=ExpandDelphiFilename(Result,AProject);
end;
function ReadSearchPath(const Section, Ident: string): string;
var
SearchPath: String;
begin
SearchPath:=IniFile.ReadString(Section,Ident,'');
DebugLn('.dof ReadSearchPath Section=',Section,' Ident=',Ident,' SearchPath="',SearchPath,'"');
Result:=ExpandDelphiSearchPath(SearchPath,AProject);
end;
procedure AddPackageDependency(const LazarusPkgName: string);
begin
if AProject<>nil then
AProject.AddPackageDependency(LazarusPkgName)
else if APackage<>nil then
APackage.AddPackageDependency(LazarusPkgName);
end;
procedure AddPackageDependency(const DelphiPkgName, DelphiPkgNames,
LazarusPkgName: string);
begin
if DelphiPkgName='' then exit;
if System.Pos(';'+lowercase(DelphiPkgName)+';',
';'+lowercase(DelphiPkgNames)+';')>0 then begin
DebugLn('AddPackageDependency adding package dependency ',LazarusPkgName);
AddPackageDependency(LazarusPkgName);
end;
end;
procedure ReadDelphiPackages;
var
DelphiPackages: String;
Pkgs: TStrings;
i: Integer;
Pkg: string;
begin
DelphiPackages:=IniFile.ReadString('Directories','Packages','');
//DebugLn('ReadDelphiPackages DelphiPackages=',DelphiPackages);
Pkgs:=SplitString(DelphiPackages,';');
if Pkgs=nil then exit;
try
for i:=0 to Pkgs.Count-1 do begin
Pkg:=Pkgs[i];
DebugLn('ReadDelphiPackages Pkg=',Pkg);
AddPackageDependency(Pkg,'rtl,dbrtl','FCL');
AddPackageDependency('LCL');
end;
finally
Pkgs.Free;
end;
end;
procedure AddSearchPath(const SearchPath: string);
begin
CompOpts.IncludePath:=MergeSearchPaths(CompOpts.IncludePath,SearchPath);
CompOpts.Libraries:=MergeSearchPaths(CompOpts.Libraries,SearchPath);
CompOpts.OtherUnitFiles:=MergeSearchPaths(CompOpts.OtherUnitFiles,SearchPath);
CompOpts.ObjectPath:=MergeSearchPaths(CompOpts.ObjectPath,SearchPath);
CompOpts.DebugPath:=MergeSearchPaths(CompOpts.DebugPath,SearchPath);
end;
var
OutputDir: String;
SearchPath: String;
DebugSourceDirs: String;
begin
if not FileExistsUTF8(DOFFilename) then exit(mrOk);
if AProjPkg is TProject then begin
AProject:=TProject(AProjPkg);
APackage:=nil;
CompOpts:=AProject.CompilerOptions;
end else if AProjPkg is TLazPackage then begin
AProject:=nil;
APackage:=TLazPackage(AProjPkg);
CompOpts:=APackage.CompilerOptions;
end else
RaiseGDBException('invalid AProjPkg');
try
IniFile:=TIniFile.Create(UTF8ToSys(DOFFilename));
try
// output directory
if AProject<>nil then begin
OutputDir:=ReadDirectory('Directories','OutputDir');
if (OutputDir<>'') then begin
DebugLn('ExtractOptionsFromDOF setting unit output directory to "',OutputDir,'"');
AProject.CompilerOptions.UnitOutputDirectory:=OutputDir;
end;
end;
// search path
SearchPath:=ReadSearchPath('Directories','SearchPath');
if (SearchPath<>'') then begin
DebugLn('ExtractOptionsFromDOF Adding to search paths: "',SearchPath,'"');
AddSearchPath(SearchPath);
end;
// debug source dirs
DebugSourceDirs:=ReadSearchPath('Directories','DebugSourceDirs');
if DebugSourceDirs<>'' then begin
DebugLn('ExtractOptionsFromDOF Adding to debug paths: "',DebugSourceDirs,'"');
CompOpts.DebugPath:=MergeSearchPaths(CompOpts.DebugPath,DebugSourceDirs);
end;
// packages
ReadDelphiPackages;
if AProject<>nil then begin
if IniFile.ReadString('Linker','ConsoleApp','')='0' then begin
// does not need a windows console
DebugLn('ExtractOptionsFromDOF ConsoleApp=0');
AProject.LazCompilerOptions.Win32GraphicApp:=true;
end;
end;
finally
IniFile.Free;
end;
except
on E: Exception do begin
DebugLn('ExtractOptionsFromDOF failed reading "'+DOFFilename+'" '+E.Message);
end;
end;
Result:=mrOk;
end;
function FindDelphiCFG(const DelphiFilename: string): string;
var
Filename: String;
begin
Result:=ChangeFileExt(DelphiFilename,'.cfg');
Filename:=FindDiskFileCaseInsensitive(Result);
if Filename<>'' then
Result:=Filename;
end;
function ExtractOptionsFromCFG(const CFGFilename: string; AProjPkg: TObject
): TModalResult;
var
sl: TStringList;
i: Integer;
Line: string;
UnitPath: String;
IncludePath: String;
AProject: TProject;
CompOpts: TBaseCompilerOptions;
APackage: TLazPackage;
begin
if not FileExistsUTF8(CFGFilename) then exit(mrOk);
if AProjPkg is TProject then begin
AProject:=TProject(AProjPkg);
CompOpts:=AProject.CompilerOptions;
end else if AProjPkg is TLazPackage then begin
APackage:=TLazPackage(AProjPkg);
CompOpts:=APackage.CompilerOptions;
end else
RaiseGDBException('invalid AProjPkg');
try
sl:=TStringList.Create;
try
sl.LoadFromFile(UTF8ToSys(CFGFilename));
for i:=0 to sl.Count-1 do begin
Line:=sl[i];
if Line='' then continue;
if (Line[1]<>'-') or (length(Line)<2) then continue;
if Line[2]='U' then begin
UnitPath:=ExpandDelphiSearchPath(copy(Line,4,length(Line)-4),AProject);
if UnitPath<>'' then begin
DebugLn('ExtractOptionsFromCFG adding unitpath "',UnitPath,'"');
CompOpts.OtherUnitFiles:=
MergeSearchPaths(CompOpts.OtherUnitFiles,UnitPath);
end;
end else if Line[2]='I' then begin
IncludePath:=ExpandDelphiSearchPath(copy(Line,4,length(Line)-4),AProject);
if IncludePath<>'' then begin
DebugLn('ExtractOptionsFromCFG adding IncludePath "',IncludePath,'"');
CompOpts.IncludePath:=
MergeSearchPaths(CompOpts.IncludePath,IncludePath);
end;
end;
end;
finally
sl.Free;
end;
except
on E: Exception do begin
DebugLn('ExtractOptionsFromDOF failed reading "'+CFGFilename+'" '+E.Message);
end;
end;
Result:=mrOk;
end;
function ConvertDelphiAbsoluteToRelativeFile(const Filename: string;
AProject: TProject): string;
var
ProjectDir: String;
ShortProjectDir: String;
p: LongInt;
begin
// often projects use paths near to their project directory
// For example:
// A project /somewhere/MyProjects/project1.dpr
// and a path C:\Delphi\MyProject\folder
// can mean, that the relative path is 'folder'
ProjectDir:=AProject.ProjectDirectory;
ShortProjectDir:=PathDelim+ExtractFileName(ChompPathDelim(ProjectDir))+PathDelim;
p:=System.Pos(ShortProjectDir,Filename);
//DebugLn('ConvertDelphiAbsoluteToRelativeFile ShortProjectDir="',ShortProjectDir,'" ',Filename,' ',dbgs(p));
if (p>0) then begin
Result:=copy(Filename,p+length(ShortProjectDir),length(Filename));
exit;
end;
// ignore all other absolute paths
Result:='';
end;
function ExpandDelphiFilename(const Filename: string; AProject: TProject
): string;
var
p: LongInt;
begin
Result:=Filename;
if Result='' then exit;
Result:=TrimFilename(SetDirSeparators(Result));
// check for $(Delphi) macro
p:=System.Pos('$(DELPHI)',Result);
//DebugLn('ExpandDelphiFilename Result="',Result,'" ',dbgs(p));
if p>0 then begin
// Delphi features are provided by FPC and Lazarus
// -> ignore
Result:='';
end;
// check for other macros
p:=System.Pos('$(',Result);
if p>0 then begin
// path macros are not supported
// -> ignore
Result:='';
end;
if FilenameIsWinAbsolute(Result) then begin
// absolute filenames are not portable
Result:=ConvertDelphiAbsoluteToRelativeFile(Result,AProject);
end;
// change PathDelim
Result:=TrimFilename(SetDirSeparators(Result));
end;
function ExpandDelphiSearchPath(const SearchPath: string;
AProject: TProject): string;
var
Paths: TStrings;
i: Integer;
CurPath: String;
j: Integer;
begin
Result:='';
//DebugLn('ExpandDelphiSearchPath SearchPath="',SearchPath,'"');
Paths:=SplitString(SearchPath,';');
if Paths=nil then exit;
try
// expand Delphi paths
for i:=0 to Paths.Count-1 do
Paths[i]:=ExpandDelphiFilename(Paths[i],AProject);
DebugLn(Paths.Text);
// remove doubles
for i:=Paths.Count-1 downto 0 do begin
CurPath:=Paths[i];
if (CurPath='') then
Paths.Delete(i)
else begin
j:=i-1;
while (j>=0) and (CompareText(CurPath,Paths[i])<>0) do dec(j);
if j>=0 then
Paths.Delete(i);
end;
end;
Result:='';
for i:=0 to Paths.Count-1 do begin
if i>0 then Result:=Result+';';
Result:=Result+Paths[i];
end;
//DebugLn('ExpandDelphiSearchPath Result="',Result,'"');
finally
Paths.Free;
end;
end;
end.