mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-06 17:35:57 +02:00
* fsearch bugs and fexpand memory leak fixed
This commit is contained in:
parent
121e935fef
commit
6a582a3902
@ -626,37 +626,74 @@ end;
|
|||||||
external 'kernel32' name 'GetFullPathNameA';
|
external 'kernel32' name 'GetFullPathNameA';
|
||||||
|
|
||||||
function FExpand(const path : pathstr) : pathstr;
|
function FExpand(const path : pathstr) : pathstr;
|
||||||
var value, tmp : PChar;
|
var value : Array[0..255] of char;
|
||||||
|
tmp : PChar;
|
||||||
p : string;
|
p : string;
|
||||||
i : Longint;
|
i : Longint;
|
||||||
begin
|
begin
|
||||||
{ allow slash as backslash }
|
{ allow slash as backslash }
|
||||||
p := path;
|
p := path;
|
||||||
for i:=1 to length(p) do
|
for i:=1 to length(p) do
|
||||||
if p[i]='/' then
|
if p[i]='/' then
|
||||||
p[i]:='\';
|
p[i]:='\';
|
||||||
StringToPchar(p);
|
StringToPchar(p);
|
||||||
getmem(value, 255);
|
{getmem(value, 255); lets avoid slow getmem PM
|
||||||
getmem(tmp, 255);
|
getmem(tmp, 255); not necessary
|
||||||
|
tmp only points to the filename part at function exit }
|
||||||
GetFullPathName(@p, 255, value, tmp);
|
GetFullPathName(@p, 255, value, tmp);
|
||||||
FExpand := strpas(value);
|
FExpand := strpas(value);
|
||||||
|
{ freemem(value,255) this would be nice at least if we use getmem !! PM }
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function SearchPath(lpPath : PChar; lpFileName : PChar; lpExtension : PChar; nBufferLength : Longint; lpBuffer : PChar;
|
function SearchPath(lpPath : PChar; lpFileName : PChar; lpExtension : PChar; nBufferLength : Longint; lpBuffer : PChar;
|
||||||
var lpFilePart : PChar) : Longint; external 'kernel32' name 'SearchPathA';
|
var lpFilePart : PChar) : Longint; external 'kernel32' name 'SearchPathA';
|
||||||
|
|
||||||
Function FSearch(path: pathstr; dirlist: string): pathstr;
|
Function FSearch(path: pathstr; dirlist: string): pathstr;
|
||||||
var temp, value : PChar;
|
var temp : PChar;
|
||||||
|
value : Array [0..255] of char;
|
||||||
i : Longint;
|
i : Longint;
|
||||||
|
dir,dir2 : dirstr;
|
||||||
|
name : namestr;
|
||||||
|
ext : extstr;
|
||||||
begin
|
begin
|
||||||
{ allow slash as backslash }
|
fsearch:='';
|
||||||
for i:=1 to length(path) do
|
for i:=1 to length(path) do
|
||||||
if path[i]='/' then
|
if path[i]='/' then
|
||||||
path[i]:='\';
|
path[i]:='\';
|
||||||
StringToPchar(path);
|
fsplit(path,dir,name,ext);
|
||||||
StringToPchar(dirlist);
|
for i:=1 to length(dirlist) do
|
||||||
SearchPath(@dirlist, @path, nil, 255, value, temp);
|
if dirlist[i]='/' then
|
||||||
fsearch := strpas(value);
|
dirlist[i]:='\';
|
||||||
|
{ allow slash as backslash }
|
||||||
|
repeat
|
||||||
|
|
||||||
|
i:=pos(';',dirlist);
|
||||||
|
while i=1 do
|
||||||
|
begin
|
||||||
|
delete(dirlist,1,1);
|
||||||
|
i:=pos(';',dirlist);
|
||||||
|
end;
|
||||||
|
if i=0 then
|
||||||
|
begin
|
||||||
|
dir2:=dirlist;
|
||||||
|
dirlist:='';
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
dir2:=Copy(dirlist,1,i-1);
|
||||||
|
dirlist:=Copy(dirlist,i+1,255);
|
||||||
|
end;
|
||||||
|
dir2:=dir2+dir;
|
||||||
|
StringToPchar(name);
|
||||||
|
StringToPchar(ext);
|
||||||
|
StringToPchar(dir2);
|
||||||
|
if SearchPath(@dir2, @name, @ext, 255, @value, temp)>0 then
|
||||||
|
begin
|
||||||
|
fsearch := strpas(value);
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
until dirlist='';
|
||||||
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
{ </immobilizer> }
|
{ </immobilizer> }
|
||||||
@ -806,7 +843,10 @@ End;
|
|||||||
end.
|
end.
|
||||||
{
|
{
|
||||||
$Log$
|
$Log$
|
||||||
Revision 1.28 2000-01-07 16:41:52 daniel
|
Revision 1.29 2000-01-11 12:49:26 pierre
|
||||||
|
* fsearch bugs and fexpand memory leak fixed
|
||||||
|
|
||||||
|
Revision 1.28 2000/01/07 16:41:52 daniel
|
||||||
* copyright 2000
|
* copyright 2000
|
||||||
|
|
||||||
Revision 1.27 2000/01/07 16:32:34 daniel
|
Revision 1.27 2000/01/07 16:32:34 daniel
|
||||||
@ -887,4 +927,4 @@ end.
|
|||||||
|
|
||||||
Revision 1.2 1998/04/26 21:49:09 florian
|
Revision 1.2 1998/04/26 21:49:09 florian
|
||||||
+ first compiling and working version
|
+ first compiling and working version
|
||||||
}
|
}
|
Loading…
Reference in New Issue
Block a user