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

* changed delp from unit dos to unit sysutils. (path lengths)

Browse Source 
git-svn-id: trunk@21472 -
This commit is contained in:
marco 2012-06-03 12:36:56 +00:00
parent 6033d3df0d
commit 347ab7651a
1 changed files with 40 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
utils/delp.pp
View File

@ -1,5 +1,5 @@
{
Copyright (c) 1999-2010 by Peter Vreman, Michael Van Canneyt
Copyright (c) 1999-2012 by Peter Vreman, Michael Van Canneyt
Deletes all files generated for Pascal (*.exe,units,objects,libs)
@ -20,14 +20,15 @@
****************************************************************************}
program Delp;
{$mode ObjFPC}{$H+}
uses
dos,getopts;
Sysutils,getopts;
const
Version = 'Version 1.2';
Version = 'Version 1.3';
Title = 'DelPascal';
Copyright = 'Copyright (c) 1999-2010 by the Free Pascal Development Team';
Copyright = 'Copyright (c) 1999-2012 by the Free Pascal Development Team';
function DStr(l:longint):string;
var
@ -45,33 +46,20 @@ begin
DStr:=TmpStr;
end;
Procedure EraseFile(Const HStr:String);
var
f : file;
procedure dosfsplit(path:ansistring;var dir,name,ext:ansistring);
// implementation of dos.fsplit on top of sysutils routines to avoid
// path length issues.
// a lot of old tooling uses fsplit, maybe move this to sysutils?
begin
Assign(f,Hstr);
{$I-}
Erase(f);
{$I+}
if ioresult<>0 then;
dir:=extractfiledir(dir);
name:=changefileext(extractfilename(path),'');
ext:=extractfileext(path);
if (length(ext)>0) and (ext[1]='.') then
delete(ext,1,1);
end;
function MatchesMask(What, Mask: string): boolean;
function upper(const s : string) : string;
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['a'..'z'] then
upper[i]:=char(byte(s[i])-32)
else
upper[i]:=s[i];
upper[0]:=s[0];
end;
Function CmpStr(const hstr1,hstr2:string):boolean;
var
found : boolean;
@ -117,16 +105,16 @@ function MatchesMask(What, Mask: string): boolean;
end;
var
D1,D2 : DirStr;
N1,N2 : NameStr;
E1,E2 : Extstr;
D1,D2 : ansistring;
N1,N2 : ansistring;
E1,E2 : ansistring;
begin
{$ifdef Unix}
FSplit(What,D1,N1,E1);
FSplit(Mask,D2,N2,E2);
DosFSplit(What,D1,N1,E1);
DosFSplit(Mask,D2,N2,E2);
{$else}
FSplit(Upper(What),D1,N1,E1);
FSplit(Upper(Mask),D2,N2,E2);
DosFSplit(Uppercase(What),D1,N1,E1);
DosFSplit(Uppercase(Mask),D2,N2,E2);
{$endif}
MatchesMask:=CmpStr(N2,N1) and CmpStr(E2,E1);
end;
@ -191,9 +179,8 @@ begin
Until C=EndOfOptions;
end;
var
Dir : Searchrec;
Dir : TSearchrec;
Total : longint;
hp : pmaskitem;
found : boolean;
@ -231,24 +218,24 @@ begin
BaseDir:=Paramstr(I);
If BaseDir[Length(BaseDir)]<>DirectorySeparator then
BaseDir:=BaseDir+DirectorySeparator;
FindFirst(basedir+'*.*',anyfile,Dir);
while (doserror=0) do
begin
hp:=masklist;
while assigned(hp) do
begin
if MatchesMask(Dir.Name,hp^.mask) then
begin
EraseFile(BaseDir+Dir.Name);
inc(hp^.Files);
inc(hp^.Size,Dir.Size);
break;
end;
hp:=hp^.next;
end;
FindNext(Dir);
if FindFirst(basedir+'*.*',faanyfile,Dir)=0 then
begin
repeat
hp:=masklist;
while assigned(hp) do
begin
if MatchesMask(Dir.Name,hp^.mask) then
begin
DeleteFile(BaseDir+Dir.Name);
inc(hp^.Files);
inc(hp^.Size,Dir.Size);
break;
end;
hp:=hp^.next;
end;
until FindNext(Dir)<>0;
FindClose(Dir);
end;
FindClose(Dir);
Inc(I);
end;
{ Write Results }