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

* Improvements so package name can be specified, fpmake is excluded

Browse Source 
git-svn-id: trunk@22211 -
This commit is contained in:
michael 2012-08-23 12:56:53 +00:00
parent 2252b71ae9
commit efaf017b17
1 changed files with 59 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
utils/pas2fpm/pas2fpm.pp
View File

@ -17,8 +17,7 @@ type
procedure AddLine(const ALine: String);
function CheckParams : boolean;
procedure CreateSources;
function GetUnitProps(const FN: String; out Res: Boolean; U: TStrings
): Boolean;
function GetUnitProps(const FN: String; out Res: Boolean; U: TStrings; Out Err : string): Boolean;
procedure WriteProgEnd;
procedure WriteProgStart;
procedure WriteSources;
@ -26,6 +25,8 @@ type
FFiles,
FSrc,
FUnits: TStrings;
InterfaceUnitsOnly : Boolean;
FPackageName : string;
FOutputFile : string;
procedure DoRun; override;
public
@ -38,6 +39,24 @@ type
Function TPas2FPMakeApp.CheckParams : Boolean;
Procedure AddFileMask(S : String);
Var
Info : TSearchRec;
D : String;
begin
D:=ExtractFilePath(S);
If FindFirst(S,0,Info)=0 then
try
Repeat
FFiles.Add(D+Info.Name);
until (FindNext(Info)<>0);
finally
FindClose(Info);
end;
end;
Var
I : Integer;
S : String;
@ -52,12 +71,28 @@ begin
begin
if S[1]<>'-' then
begin
FFiles.Add(S);
FUnits.Add(ChangeFileExt(ExtractFileName(S),''));
If (Pos('?',S)<>0) or (Pos('*',S)<>0) then
AddFileMask(S)
else if comparetext(ChangeFileExt(extractfilename(s),''),'fpmake')<>0 then
begin
FFiles.Add(S);
FUnits.Add(ChangeFileExt(ExtractFileName(S),''));
end;
end
else
begin
If (s='-o') then
If (s='o') then
begin
inc(I);
FoutputFile:=ParamStr(i);
end
else If (s='-i') then
InterfaceUnitsOnly:=True
else if (s='-p') then
begin
Inc(i);
FPackageName:=ParamStr(i);
end
else
begin
Result:=False;
@ -76,7 +111,7 @@ begin
FSrc.Add(ALine);
end;
Function TPas2FPMakeApp.GetUnitProps(Const FN : String; Out Res : Boolean; U : TStrings) : Boolean;
Function TPas2FPMakeApp.GetUnitProps(Const FN : String; Out Res : Boolean; U : TStrings; Out Err : string) : Boolean;
Var
I : Integer;
@ -89,7 +124,10 @@ begin
try
A.FileName:=FN;
Res:=A.HasResourcestrings;
A.GetUsedUnits(U);
if InterfaceUnitsOnly then
A.GetInterfaceUnits(U)
else
A.GetUsedUnits(U);
For I:=U.Count-1 downto 0 do
if FUnits.IndexOf(U[i])=-1 then
U.Delete(i);
@ -98,8 +136,11 @@ begin
end;
Result:=True;
except
On E : Exception do
Err:=E.Message;
// Ignore
end;
end;
procedure TPas2FPMakeApp.WriteProgStart;
@ -115,6 +156,7 @@ begin
AddLine('begin');
AddLine(' With Installer do');
AddLine(' begin');
AddLine(' P:=AddPackage('''+FPackageName+''');');
AddLine(' P.Version:=''0.0'';');
// AddLine(' P.Dependencies.Add('fcl-base');
AddLine(' P.Author := ''Your name'';');
@ -139,7 +181,7 @@ procedure TPas2FPMakeApp.CreateSources;
Var
I,j : Integer;
U : TStrings;
FN : String;
FN,Err : String;
R : Boolean;
begin
@ -149,8 +191,8 @@ begin
FN:=FFiles[i];
AddLine(' T:=P.Targets.AddUnit('''+FN+''');');
U:=TStringList.Create;
if not GetUnitProps(Fn,R,U) then
AddLine(' // Failed to analyse unit '+FN)
if not GetUnitProps(Fn,R,U,Err) then
AddLine(' // Failed to analyse unit "'+Fn+'". Error: "'+Err+'"')
else
begin
if R then
@ -210,6 +252,7 @@ begin
FFiles:=TStringList.Create;
FSrc:=TStringList.Create;
FUnits:=TStringList.Create;
FPackageName:='Your package name here';
end;
destructor TPas2FPMakeApp.Destroy;
@ -223,7 +266,12 @@ end;
procedure TPas2FPMakeApp.WriteHelp;
begin
{ add your help code here }
writeln('Usage: ',ExeName,' [-h] [-o outputfile] file1 .. filen');
writeln('Usage: ',ExeName,' [options] file1 .. filen');
Writeln('Where [options] is one or more of');
Writeln(' -h This help');
Writeln(' -p packagename Set package name');
Writeln(' -i Use interface units only for checking dependencies');
Writeln(' -o outputfile Set output filename (default is standard output)');
end;
var