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

atari: FSearch impementation for DOS unit, copied from msdos target

Browse Source 
git-svn-id: trunk@35255 -
This commit is contained in:
Károly Balogh 2017-01-07 04:33:00 +00:00
parent a8a9a5f5de
commit 4b7d0eb0ac
1 changed files with 45 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
rtl/atari/dos.pp
View File

@ -212,7 +212,7 @@ begin
gemdos_setdta(@IFD^.dta_search);
f.IFD:=IFD;
dosResult:=gemdos_fsfirst(pchar(r), Attr);
dosResult:=gemdos_fsfirst(pchar(r), Attr and AnyFile);
if dosResult < 0 then
begin
Error2DosError(dosResult);
@ -273,8 +273,50 @@ begin
end;
function FSearch(path: PathStr; dirlist: String) : PathStr;
var
p1 : longint;
s : searchrec;
newdir : pathstr;
begin
FSearch:='';
{ No wildcards allowed in these things }
if (pos('?',path)<>0) or (pos('*',path)<>0) then
begin
fsearch:='';
exit;
end;
{ check if the file specified exists }
findfirst(path,anyfile and not(directory),s);
if doserror=0 then
begin
findclose(s);
fsearch:=path;
exit;
end;
findclose(s);
{ allow slash as backslash }
DoDirSeparators(dirlist);
repeat
p1:=pos(';',dirlist);
if p1<>0 then
begin
newdir:=copy(dirlist,1,p1-1);
delete(dirlist,1,p1);
end
else
begin
newdir:=dirlist;
dirlist:='';
end;
if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
newdir:=newdir+'\';
findfirst(newdir+path,anyfile and not(directory),s);
if doserror=0 then
newdir:=newdir+path
else
newdir:='';
findclose(s);
until (dirlist='') or (newdir<>'');
fsearch:=newdir;
end;
procedure GetFAttr(var f; var Attr : word);
@ -305,7 +347,7 @@ var
td: TDOSTIME;
begin
gemdos_fdatime(@td,TextRec(f).Handle,0);
Time:=(td.date << 16) + td.time;
Time:=(td.date shl 16) + td.time;
end;
procedure SetFAttr(var f; attr : word);