paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-10 14:29:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Darius Blaszijk:

Browse Source 
- added EXTERNALZIP define to make bootstrapping possible (missing zipper unit)
  - implemented SearchFiles method which can search recursively and with a filemask 
    (asterisk or questionmark) using MatchesMask function
  - implemented methods AddDocFiles, AddSrcFiles, AddExampleFiles, AddTestFiles in TCustomInstaller
  - implemented archiving of all files in TSources

git-svn-id: trunk@8294 -
This commit is contained in:
michael 2007-08-21 18:53:22 +00:00
parent bc5225b8ae
commit d69db0aa54
1 changed files with 191 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

197
packages/fpmkunit/src/fpmkunit.pp
View File

@ -18,12 +18,12 @@ unit fpmkunit;
{$Mode objfpc}
{$H+}
{ $define debug}
Interface
uses
SysUtils, Classes, zipper;
{$IFNDEF EXTERNALZIP} zipper, {$ENDIF}
SysUtils, Classes;
Type
TFileType = (ftSource,ftUnit,ftObject,ftResource,ftExecutable,ftStaticLibrary,
@ -86,7 +86,7 @@ Const
DLLExt = '.dll';
ExeExt = '.exe';
ZipExt = '.zip';
ManifestFile = 'manifest.xml';
UnitTargets = [ttUnit,ttExampleUnit];
@ -507,7 +507,9 @@ Type
FDefaults : TCustomDefaults;
FForceCompile : Boolean;
FListMode : Boolean;
{$IFNDEF EXTERNALZIP}
FZipFile: TZipper;
{$ENDIF}
// Variables used when compiling a package.
// Only valid during compilation of the package.
FCurrentOutputDir : String;
@ -633,6 +635,7 @@ Type
procedure SetDefaults(const AValue: TCustomDefaults);
procedure SetStrings(AIndex : Integer; const AValue: TStrings);
procedure SetOses(const AValue: TOSes);
procedure SearchFiles(FileName: string; Recursive: boolean; var List: TStrings);
Protected
Procedure Log(Level : TVerboseLevel; Const Msg : String);
Procedure CreatePackages; virtual;
@ -658,6 +661,11 @@ Type
Function Run : Boolean;
Function AddTarget(AName : String) : TTarget;
Procedure AddDependency(AName : String);
//files in package
procedure AddDocFiles(AFileMask: string; Recursive: boolean = False);
procedure AddSrcFiles(AFileMask: string; Recursive: boolean = False);
procedure AddExampleFiles(AFileMask: string; Recursive: boolean = False);
procedure AddTestFiles(AFileMask: string; Recursive: boolean = False);
Property DefaultPackage : TPackage read FDefaultPackage write SetDefaultPackage;
Property Packages : TPackages Read FPackages;
Property Dependencies : TStrings Index 0 Read GetStrings Write SetStrings;
@ -1122,6 +1130,74 @@ begin
Options:=Trim(S);
end;
function MatchesMask(What, Mask: string): boolean;
procedure FSplit(Path: string; var Dir: string; var Name: string; var Ext: string);
begin
Dir := ExtractFilePath(Path);
Ext := ExtractFileExt(Path);
Name := ExtractFileName(Path);
Name := Copy(Name, 1, Length(Name) - Length(Ext));
end;
Function CmpStr(const hstr1,hstr2:string):boolean;
var
found : boolean;
i1,i2 : integer;
begin
i1:=0;
i2:=0;
found:=true;
while found and (i1<length(hstr1)) and (i2<=length(hstr2)) do
begin
if found then
inc(i2);
inc(i1);
case hstr1[i1] of
'?' :
found:=true;
'*' :
begin
found:=true;
if (i1=length(hstr1)) then
i2:=length(hstr2)
else
if (i1<length(hstr1)) and (hstr1[i1+1]<>hstr2[i2]) then
begin
if i2<length(hstr2) then
dec(i1)
end
else
if i2>1 then
dec(i2);
end;
else
if (i1 > length(hstr1)) or (i2 > length(hstr2)) then
found := false
else
found:=(hstr1[i1]=hstr2[i2]) or (hstr2[i2]='?');
end;
end;
if found then
found:=(i1>=length(hstr1)) and (i2>=length(hstr2));
CmpStr:=found;
end;
var
D1,D2 : string;
N1,N2 : string;
E1,E2 : string;
begin
{$ifdef Unix}
FSplit(What,D1,N1,E1);
FSplit(Mask,D2,N2,E2);
{$else}
FSplit(UpperCase(What),D1,N1,E1);
FSplit(UpperCase(Mask),D2,N2,E2);
{$endif}
MatchesMask:=CmpStr(N2,N1) and CmpStr(E2,E1);
end;
{ TNamedItem }
procedure TNamedItem.SetName(const AValue: String);
@ -2139,6 +2215,38 @@ begin
DefaultPackage.OS:=AValue;
end;
procedure TCustomInstaller.SearchFiles(FileName: string; Recursive: boolean;
var List: TStrings);
procedure AddRecursiveFiles(SearchDir, FileMask: string; Recursive: boolean);
var
Info : TSearchRec;
begin
if FindFirst(SearchDir+'*',faAnyFile and faDirectory,Info)=0 then
begin
repeat
if ((Info.Attr and faDirectory) = faDirectory) and (Info.Name <> '.') and (Info.Name <> '..') and (Recursive) then
AddRecursiveFiles(SearchDir + Info.Name + PathDelim, FileMask, Recursive);
if ((Info.Attr and faDirectory) <> faDirectory) and MatchesMask(Info.Name, FileMask) then
List.Add(SearchDir + Info.Name);
until FindNext(Info)<>0;
end;
FindClose(Info);
end;
var
BasePath: string;
i: integer;
begin
BasePath := ExtractFilePath(ExpandFileName(FileName));
AddRecursiveFiles(BasePath, ExtractFileName(FileName), Recursive);
for i := 0 to Pred(List.Count) do
List[i] := ExtractRelativepath(ExtractFilePath(ParamStr(0)), List[i]);
end;
procedure TCustomInstaller.Log(Level: TVerboseLevel; const Msg: String);
begin
If Level in FLogLevels then
@ -2457,6 +2565,62 @@ begin
DefaultPackage.AddDependency(AName);
end;
procedure TCustomInstaller.AddDocFiles(AFileMask: string; Recursive: boolean);
var
List : TStrings;
i: integer;
begin
List := TStringList.Create;
SearchFiles(AFileMask, Recursive, List);
for i:= 0 to Pred(List.Count) do
FDefaultPackage.Sources.AddDocFiles(List[i]);
List.Free;
end;
procedure TCustomInstaller.AddSrcFiles(AFileMask: string; Recursive: boolean);
var
List : TStrings;
i: integer;
begin
List := TStringList.Create;
SearchFiles(AFileMask, Recursive, List);
for i:= 0 to Pred(List.Count) do
FDefaultPackage.Sources.AddSrcFiles(List[i]);
List.Free;
end;
procedure TCustomInstaller.AddExampleFiles(AFileMask: string; Recursive: boolean);
var
List : TStrings;
i: integer;
begin
List := TStringList.Create;
SearchFiles(AFileMask, Recursive, List);
for i:= 0 to Pred(List.Count) do
FDefaultPackage.Sources.AddExampleFiles(List[i]);
List.Free;
end;
procedure TCustomInstaller.AddTestFiles(AFileMask: string; Recursive: boolean);
var
List : TStrings;
i: integer;
begin
List := TStringList.Create;
SearchFiles(AFileMask, Recursive, List);
for i:= 0 to Pred(List.Count) do
FDefaultPackage.Sources.AddTestFiles(List[i]);
List.Free;
end;
{ TFPCInstaller }
constructor TFPCInstaller.Create(AOwner: TComponent);
@ -3215,29 +3379,50 @@ end;
procedure TBuildEngine.Archive(APackage: TPackage);
Var
L : TStrings;
L : TStringList;
L2: TStringList;
A : String;
UnitsDir: string;
BinDir: string;
i: integer;
begin
Log(vlInfo,SLogArchivingPackage,[APackage.Name]);
DoBeforeArchive(Apackage);
L:=TStringList.Create;
L2:=TStringList.Create;
Try
//get all files
//from targets
APackage.GetArchiveFiles(L, TargetDir, Defaults.OS);
//from sources
for i := 0 to Pred(APackage.Sources.Count) do
L.Add(APackage.Sources[i].Name);
//expand all filenames and ignore duplicates
L2.Sorted := True;
L2.Duplicates := dupIgnore;
for i := 0 to Pred(L.Count) do
L2.Add(L[i]);
A:=APackage.FileName + ZipExt;
{$IFNDEF EXTERNALZIP}
if not Assigned(ArchiveFilesProc) then
begin
FZipFile := TZipper.Create;
FZipFile.ZipFiles(A, L);
FZipFile.ZipFiles(A, L2);
end
else
CmdArchiveFiles(L,A);
{$ENDIF}
CmdArchiveFiles(L2,A);
Finally
L.Free;
L2.Free;
{$IFNDEF EXTERNALZIP}
if not Assigned(ArchiveFilesProc) then
FZipFile.Free;
{$ENDIF}
end;
Log(vlInfo, Format(SInfoArchiving, [APackage.Name]));
DoAfterArchive(Apackage);