mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-18 00:31:38 +02:00
09e7570e57
+ Add check after moving current directory to root drive
for Dos style pathes.
git-svn-id: trunk@18245 -
120 lines
2.9 KiB
ObjectPascal
120 lines
2.9 KiB
ObjectPascal
program test_directoryexists;
|
|
|
|
{$H+}
|
|
|
|
uses
|
|
dos, sysutils;
|
|
|
|
{$I+}
|
|
|
|
const
|
|
HasErrors : boolean = false;
|
|
AllowTrailingSeparators: boolean = false;
|
|
|
|
procedure TestDirectoryExists(Const DirName : string; ExpectedResult : boolean);
|
|
var
|
|
res : boolean;
|
|
begin
|
|
Writeln('Testing "',DirName,'"');
|
|
res:=Sysutils.DirectoryExists (DirName);
|
|
if res <> ExpectedResult then
|
|
begin
|
|
Writeln('Unexpected result: ',res,' for "',DirName,'"');
|
|
HasErrors:=true;
|
|
end;
|
|
end;
|
|
|
|
procedure TestParents(var dir : string);
|
|
var
|
|
backslashpos,slashpos,maxpos,i : longint;
|
|
begin
|
|
while true do
|
|
begin
|
|
backslashpos:=0;
|
|
for i:=length(dir) downto 1 do
|
|
if dir[i]='\' then
|
|
begin
|
|
backslashpos:=i;
|
|
break;
|
|
end;
|
|
slashpos:=0;
|
|
for i:=length(dir) downto 1 do
|
|
if dir[i]='/' then
|
|
begin
|
|
slashpos:=i;
|
|
break;
|
|
end;
|
|
if (backslashpos=0) and (slashpos=0) then
|
|
exit;
|
|
if slashpos>backslashpos then
|
|
maxpos:=slashpos
|
|
else
|
|
maxpos:=backslashpos;
|
|
dir:=copy(dir,1,maxpos);
|
|
TestDirectoryExists(dir,AllowTrailingSeparators);
|
|
if length(dir)>1 then
|
|
begin
|
|
dir:=copy(dir,1,maxpos-1);
|
|
TestDirectoryExists(dir,true);
|
|
end
|
|
else
|
|
{ if length(dir)<=1, exit test }
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
dir,dir1,dir2,StoredDir : string;
|
|
P,N,E : shortstring;
|
|
begin
|
|
Dos.FSplit(paramstr(0),P,N,E);
|
|
Writeln('Path="',P,'"');
|
|
Writeln('Name="',N,'"');
|
|
Writeln('Ext="',E,'"');
|
|
Writeln('DirectorySeparator="',DirectorySeparator,'"');
|
|
TestDirectoryExists(P,true);
|
|
if DirectoryExists(P+DirectorySeparator) and
|
|
DirectoryExists(P+DirectorySeparator+DirectorySeparator) then
|
|
AllowTrailingSeparators:=true;
|
|
|
|
dir:=P;
|
|
TestParents(dir);
|
|
dir:=P;
|
|
if (length(dir)>2) and (dir[2]=':') and (dir[3]=DirectorySeparator) then
|
|
begin
|
|
GetDir(0,StoredDir);
|
|
Writeln('Testing from Root drive');
|
|
ChDir(Copy(Dir,1,3));
|
|
TestParents(dir);
|
|
ChDir(StoredDir);
|
|
end;
|
|
dir:=P+'_Dummy';
|
|
TestDirectoryExists(dir,false);
|
|
dir1:=P+'_Dummy'+DirectorySeparator;
|
|
TestDirectoryExists(dir1,false);
|
|
mkdir(dir);
|
|
TestDirectoryExists(dir,true);
|
|
TestDirectoryExists(dir1,true);
|
|
{ Check that using two directory separators fails }
|
|
TestDirectoryExists(dir1+DirectorySeparator,AllowTrailingSeparators);
|
|
TestDirectoryExists(dir1+'/',AllowTrailingSeparators);
|
|
TestDirectoryExists(dir1+'//',AllowTrailingSeparators);
|
|
if DirectorySeparator='\' then
|
|
TestDirectoryExists(dir1+'\\',AllowTrailingSeparators);
|
|
dir2:=dir1+'_Dummy2';
|
|
TestDirectoryExists(dir2,false);
|
|
mkdir(dir2);
|
|
TestDirectoryExists(dir2,true);
|
|
rmdir(dir2);
|
|
rmdir(dir);
|
|
TestDirectoryExists(dir,false);
|
|
TestDirectoryExists(dir1,false);
|
|
if HasErrors then
|
|
begin
|
|
Writeln('Program encountered errors');
|
|
Halt(1);
|
|
end;
|
|
end.
|
|
|
|
|