fpc/tests/test/units/dos/tfexpand.pp
Tomas Hajny 7d5b63042b * add test for web bug #16651
git-svn-id: trunk@15456 -
2010-06-19 16:27:03 +00:00

501 lines
14 KiB
ObjectPascal

{ %skiptarget=wince }
{
This file is part of the Free Pascal test suite.
Copyright (c) 1999-2004 by the Free Pascal development team.
Test for possible bugs in Dos.FExpand
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program TFExpand;
{$DEFINE DEBUG}
(* Defining DEBUG causes all the source and target strings *)
(* to be written to the console to make debugging easier. *)
{ $DEFINE DIRECT}
(* Defining DIRECT causes direct embedding of fexpand.inc instead *)
(* of using FExpand implementation in (previously compiled) unit Dos. *)
uses
{$ifdef FPC}
PopupErr,
{$endif FPC}
Dos;
{$IFDEF DIRECT}
(* For testing purposes on non-native platforms *)
{$DEFINE VOLUMES}
{$DEFINE NODOTS}
{ $DEFINE AMIGA}
{ $DEFINE UNIX}
{$DEFINE MACOS}
{ $DEFINE FPC_FEXPAND_DRIVES}
{ $DEFINE FPC_FEXPAND_UNC}
{$DEFINE FPC_FEXPAND_VOLUMES}
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
{ $DEFINE FPC_FEXPAND_DIRSEP_IS_UPDIR}
{$DEFINE FPC_FEXPAND_NO_DOTS_UPDIR}
{ $DEFINE FPC_FEXPAND_NO_CURDIR}
{ $DEFINE FPC_FEXPAND_TILDE}
{ $DEFINE FPC_FEXPAND_MULTIPLE_UPDIR}
{$DEFINE FPC_FEXPAND_DIRSEP_IS_CURDIR}
{ $DEFINE FPC_FEXPAND_GETENV_PCHAR}
{$ENDIF DIRECT}
{$IFDEF LINUX}
{$IFNDEF UNIX}
{$DEFINE UNIX}
{$ENDIF UNIX}
{$ENDIF LINUX}
{$IFDEF AMIGA}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$ENDIF AMIGA}
{$IFDEF NETWARE}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$ENDIF NETWARE}
{$IFDEF UNIX}
{$DEFINE NODRIVEC}
{$ENDIF UNIX}
{$IFDEF MACOS}
{$DEFINE VOLUMES}
{$DEFINE NODRIVEC}
{$DEFINE NODOTS}
{$ENDIF MACOS}
const
{$IFNDEF NODRIVEC}
CC = 'C:';
{$ENDIF NODRIVEC}
{$IFNDEF FPC}
FileNameCaseSensitive = false;
DirectorySeparator = '\';
DirectorySeparator2 = '\';
DirSep = '\';
CDrive = 'C:';
DriveSep = ':';
{$ELSE FPC}
(* Used for ChDir/MkDir *)
DirectorySeparator2 = System.DirectorySeparator;
{$IFDEF DIRECT}
{$IFDEF MACOS}
DirectorySeparator = ':';
LFNSupport = true;
FileNameCaseSensitive = false;
{$ELSE MACOS}
{$IFDEF UNIX}
DirectorySeparator = '/';
DriveSeparator = '/';
FileNameCaseSensitive = true;
{$ELSE UNIX}
{$IFDEF AMIGA}
DirectorySeparator = ':';
FileNameCaseSensitive = true;
{$ELSE AMIGA}
DirectorySeparator = '\';
FileNameCaseSensitive = false;
{$ENDIF AMIGA}
{$ENDIF UNIX}
{$ENDIF MACOS}
{$ENDIF DIRECT}
DirSep = DirectorySeparator;
{$IFDEF MACOS}
DriveSep = '';
{$ELSE MACOS}
{$IFDEF AMIGA}
DriveSep = '';
{$ELSE AMIGA}
DriveSep = DriveSeparator;
{$ENDIF AMIGA}
{$ENDIF MACOS}
{$IFDEF UNIX}
CDrive = '';
{$ELSE UNIX}
{$IFDEF MACOS}
CDrive = 'C';
{$ELSE MACOS}
{$IFDEF AMIGA}
CDrive = 'C';
{$ELSE AMIGA}
CDrive = 'C:';
{$ENDIF AMIGA}
{$ENDIF MACOS}
{$ENDIF UNIX}
{$ENDIF FPC}
TestFileName = 'testfile.tst';
TestDir1Name = 'TESTDIR1';
TestDir2Name = 'TESTDIR2';
HasErrors: boolean = false;
{$IFDEF DIRECT}
procedure XToDirect (var S: string);
var
I: byte;
begin
if DirectorySeparator2 <> DirectorySeparator then
for I := 1 to Length (S) do
if S [I] = DirectorySeparator2 then
S [I] := DirectorySeparator;
{$IFNDEF FPC_FEXPAND_DRIVES}
if DriveSeparator = DirectorySeparator then
I := Pos (DirectorySeparator + DirectorySeparator, S)
else
I := Pos (DriveSeparator, S);
if I <> 0 then
Delete (S, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
end;
procedure GetDir (Drive: byte; var Directory: string);
begin
System.GetDir (Drive, Directory);
XToDirect (Directory);
end;
{$I fexpand.inc}
{$ENDIF DIRECT}
var
{$IFNDEF NODRIVEC}
CDir,
{$endif}
TestDir, TestDir0, OrigDir, OrigTstDir, CurDir, S: DirStr;
TestDrive: string [2];
I: byte;
IOR: longint;
F: file;
function Translate (S: PathStr): PathStr;
var
I: byte;
begin
{$IFDEF UNIX}
if (Length (S) > 1) and (S [2] = ':') then Delete (S, 1, 2);
{$ELSE UNIX}
for I := 1 to Length (S) do if S [I] = '/' then S [I] := DirSep;
if (Length (S) > 1) and (S [1] in ['a'..'z']) and (S[2]=DriveSep) then
S [1] := UpCase (S [1]);
{$ENDIF UNIX}
if not (FileNameCaseSensitive) then
for I := 1 to Length (S) do S [I] := UpCase (S [I]);
Translate := S;
end;
procedure Check (Src, Rslt: PathStr);
var
Rslt2: PathStr;
begin
{$IFDEF DEBUG}
WriteLn (Src, '=>', Rslt);
{$ENDIF DEBUG}
Rslt := Translate (Rslt);
Rslt2 := FExpand (Src);
{$IFDEF DIRECT}
{$IFNDEF FPC_FEXPAND_DRIVES}
I := Pos (System.DriveSeparator, Rslt2);
if I <> 0 then
Delete (Rslt2, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
{$ENDIF DIRECT}
{$IFNDEF UNIX}
if (Length (Rslt2) > 1) and (Rslt2 [1] in ['a'..'z']) and (Rslt2[2]=DriveSep) then
Rslt2 [1] := UpCase (Rslt2 [1]);
{$ENDIF NDEF UNIX}
if Rslt <> Rslt2 then
begin
WriteLn ('Error: FExpand (', Src, ') should be "', Rslt, '", not "',
Rslt2, '"');
HasErrors := true;
end;
end;
begin
if ParamCount <> 1 then
begin
WriteLn ('Warning: Parameter missing!');
WriteLn ('Full path to a directory with write access' +
{$IFNDEF UNIX}
{$IFNDEF VOLUMES}
#13#10'(preferably not on a C: drive)' +
{$ENDIF VOLUMES}
{$ENDIF UNIX}
' expected.');
WriteLn ('Trying to use the current directory instead ' +
{$IFDEF UNIX}
'(not quite ideal).');
{$ELSE UNIX}
'(problems might arise).');
{$ENDIF UNIX}
{$IFDEF DIRECT}System.{$ENDIF DIRECT}GetDir (0, TestDir);
end else TestDir := ParamStr (1);
if TestDir [Length (TestDir)] <> DirectorySeparator2 then
TestDir := TestDir + DirectorySeparator2;
{$IFDEF DIRECT}System.{$ENDIF DIRECT}GetDir (0, OrigDir);
{$IFDEF NODRIVEC}
TestDrive := '';
{$ELSE NODRIVEC}
TestDrive := Copy (TestDir, 1, 2);
GetDir ((Ord (TestDir [1]) and not ($20)) - 64, OrigTstDir);
{$ENDIF NODRIVEC}
{$I-}
MkDir (TestDir + TestDir1Name);
if IOResult <> 0 then ;
MkDir (TestDir + TestDir1Name + DirectorySeparator2 + TestDir2Name);
if IOResult <> 0 then ;
{$I+}
ChDir (TestDir + TestDir1Name + DirectorySeparator2 + TestDir2Name);
{$I-}
TestDir0 := TestDir;
{$IFDEF DIRECT}
XToDirect (TestDir);
{$IFNDEF FPC_FEXPAND_DRIVES}
I := Pos (System.DriveSeparator, TestDir);
if I <> 0 then
Delete (TestDir, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
{$ENDIF DIRECT}
Assign (F, TestFileName);
Rewrite (F);
Close (F);
if IOResult <> 0 then ;
{$IFNDEF DIRECT}
Assign (F, FExpand (TestFileName));
{$ENDIF DIRECT}
{$I+}
GetDir (0, CurDir);
{$IFDEF DIRECT}
{$IFNDEF FPC_FEXPAND_DRIVES}
I := Pos (System.DriveSeparator, CurDir);
if I <> 0 then
Delete (CurDir, 1, I);
{$ENDIF FPC_FEXPAND_DRIVES}
{$ENDIF DIRECT}
{$IFNDEF NODRIVEC}
GetDir (3, CDir);
{$ENDIF NODRIVEC}
Check (' ', CurDir + DirSep + ' ');
{$IFDEF AMIGA}
Check ('', CurDir);
{$ELSE AMIGA}
Check ('', CurDir + DirSep);
{$ENDIF AMIGA}
{$IFDEF MACOS}
Check (':', CurDir + DirSep);
{$ELSE MACOS}
Check ('.', CurDir);
{$ENDIF MACOS}
{$IFNDEF NODRIVEC}
if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
else Check ('c:anything', CDir + DirSep + 'anything');
Check (CC + DirSep, CDrive + DirSep);
{$IFDEF NODOTS}
Check ('C:.', 'C:.');
Check (CC + DirSep + '.', CDrive + DirSep + '.');
Check (CC + DirSep + '..', CDrive + DirSep + '..');
{$ELSE NODOTS}
Check ('C:.', CDir);
Check (CC + DirSep + '.', CDrive + DirSep);
Check (CC + DirSep + '..', CDrive + DirSep);
{$ENDIF NODOTS}
Check (CC + DirSep + 'DOS', CDrive + DirSep + 'DOS');
{$IFNDEF NODOTS}
Check (CC + DirSep + '..' + DirSep + 'DOS', CDrive + DirSep + 'DOS');
{$ENDIF NODOTS}
Check (CC + DirSep + 'DOS.', CDrive + DirSep + 'DOS.');
{$IFDEF AMIGA}
Check (CC + DirSep + 'DOS' + DirSep, CDrive + DirSep);
{$ELSE AMIGA}
Check (CC + DirSep + 'DOS' + DirSep, CDrive + DirSep + 'DOS' + DirSep);
{$ENDIF AMIGA}
{$IFNDEF NODOTS}
Check (CC + DirSep + 'DOS' + DirSep + '.', CDrive + DirSep + 'DOS');
Check (CC + DirSep + 'DOS' + DirSep + '..', CDrive + DirSep);
Check (CC + DirSep + 'DOS' + DirSep + '..' + DirSep, CDrive + DirSep);
Check (CC + DirSep + 'DOS' + DirSep + 'TEST' + DirSep + '..', CDrive +
DirSep + 'DOS');
Check ('C:' + DirSep + 'DOS' + DirSep + 'TEST' + DirSep + '..' + DirSep,
CDrive + DirSep + 'DOS' + DirSep);
{$ENDIF NODOTS}
{$ENDIF NODRIVEC}
{$IFNDEF MACOS}
Check (DirSep, TestDrive + DirSep);
Check (DirSep + '.', TestDrive + DirSep);
Check (DirSep + '..', TestDrive + DirSep);
Check (DirSep + 'DOS', TestDrive + DirSep + 'DOS');
{$ENDIF MACOS}
Check ('d', CurDir + DirSep + 'd');
{$IFDEF MACOS}
Check (DirSep + 'd', CurDir + DirSep + 'd');
{$ELSE MACOS}
{$IFNDEF NODOTS}
Check ('.' + DirSep + 'd', CurDir + DirSep + 'd');
{$ENDIF NODOTS}
{$ENDIF MACOS}
Check ('d' + DirSep + TestFileName, CurDir + DirSep + 'd' + DirSep + TestFileName);
Check (' d', CurDir + DirSep + ' d');
Check ('dd', CurDir + DirSep + 'dd');
{$IFDEF MACOS}
Check (DirSep + 'dd' + DirSep + 'dd', CurDir + DirSep + 'dd' + DirSep + 'dd');
Check ('dd' + DirSep + 'dd', 'dd' + DirSep + 'dd');
{$ELSE MACOS}
Check ('dd' + DirSep + 'dd', CurDir + DirSep + 'dd' + DirSep + 'dd');
{$ENDIF MACOS}
Check ('ddd', CurDir + DirSep + 'ddd');
{$IFDEF MACOS}
Check ('dddd' + DirSep + 'eeee.ffff', 'dddd' + DirSep + 'eeee.ffff');
{$ELSE MACOS}
Check ('dddd' + DirSep + 'eeee.ffff', CurDir + DirSep + 'dddd' + DirSep
+ 'eeee.ffff');
{$ENDIF MACOS}
Check ('.special', CurDir + DirSep + '.special');
Check ('..special', CurDir + DirSep + '..special');
Check ('special..', CurDir + DirSep + 'special..');
{$IFDEF AMIGA}
Check ('special.' + DirSep, CurDir);
{$ELSE AMIGA}
{$IFDEF MACOS}
Check ('special.' + DirSep, 'special.' + DirSep);
{$ELSE MACOS}
Check ('special.' + DirSep, CurDir + DirSep + 'special.' + DirSep);
{$ENDIF MACOS}
{$ENDIF AMIGA}
{$IFDEF MACOS}
Check (DirSep + DirSep, TestDir + TestDir1Name + DirSep);
Check (DirSep + DirSep + TestFileName, TestDir + TestDir1Name + DirSep
+ TestFileName);
{$ELSE MACOS}
Check (DirSep + '.special', TestDrive + DirSep + '.special');
{$IFNDEF NODOTS}
Check ('..', TestDir + TestDir1Name);
Check ('.' + DirSep + '..', TestDir + TestDir1Name);
Check ('..' + DirSep + '.', TestDir + TestDir1Name);
{$ENDIF NODOTS}
{$ENDIF MACOS}
{$IFDEF NETWARE}
Check ('...', TestDir);
{$ELSE NETWARE}
Check ('...', CurDir + DirSep + '...');
{$ENDIF NETWARE}
Check (TestFileName, CurDir + DirSep + TestFileName);
{$IFDEF UNIX}
S := GetEnv ('HOME');
{ On m68k netbsd at least, HOME contains a final slash
remove it PM }
if S[length(S)]=DirSep then
S:=Copy(S,1,Length(S)-1);
Check ('~', S);
Check ('~' + DirSep + '.', S);
if (Length (S) > 0) and (S [Length (S)] <> DirSep) then S := S + DirSep;
Check ('~NobodyWithThisNameShouldEverExist.test/nothing', CurDir + DirSep +
'~NobodyWithThisNameShouldEverExist.test/nothing');
Check ('/tmp/~NoSuchUserAgain', '/tmp/~NoSuchUserAgain');
Check ('~' + DirSep, S);
Check ('~' + DirSep + '.' + DirSep, S);
Check ('~' + DirSep + 'directory' + DirSep + 'another',
S + 'directory' + DirSep + 'another');
{$ELSE UNIX}
{$IFNDEF NODRIVEC}
Check (TestDrive + '..', TestDir + TestDir1Name);
Check (TestDrive + '..' + DirSep, TestDir + TestDir1Name + DirSep);
Check (TestDrive + '.' + DirSep + '.', CurDir);
Check (TestDrive + '.' + DirSep + '..', TestDir + TestDir1Name);
{$I-}
(*
{ $ ifndef unix }
{ avoid a and b drives for
no unix systems to reduce the
probablility of getting an alert message box }
{ This should not be needed - unit popuperr should solve this?! TH }
I := 3;
{$else unix} *)
I := 1;
{ $ endif unix}
repeat
S := '';
GetDir (I, S);
IOR := IOResult;
if IOR = 0 then Inc (I);
until (I > 26) or (IOR <> 0);
if I <= 26 then
begin
S := Chr (I + 64) + ':ddd';
Check (S, Chr (I + 64) + ':' + DirSep + 'ddd');
end else
WriteLn ('Sorry, cannot test FExpand behaviour for incorrect drives here.');
{$I+}
{$IFDEF FPC}
Check ('d\d/d', CurDir + DirSep + 'd' + DirSep + 'd' + DirSep + 'd');
Check ('\\server\share\directory', '\\server\share\directory');
Check ('\\server\share\directory1\directory2\..',
'\\server\share\directory1');
Check ('\\', '\\');
Check ('\\.', '\\.\');
Check ('\\.\', '\\.\');
Check ('\\.\.', '\\.\.');
Check ('\\.\..', '\\.\..');
Check ('\\.\...', '\\.\...');
Check ('\\.\TEST', '\\.\TEST');
Check ('\\..\', '\\..\');
Check ('\\..\TEST', '\\..\TEST');
Check ('\\..\TEST\.', '\\..\TEST');
Check ('\\..\TEST1\TEST2\..', '\\..\TEST1');
Check ('\\..\TEST\..', '\\..\TEST');
Check ('\\..\TEST\..\..', '\\..\TEST');
{$ENDIF FPC}
{$ENDIF NODRIVEC}
{$ENDIF UNIX}
{$IFDEF VOLUMES}
Check ('VolName' + DriveSep + DirSep + 'DIR1', 'VolName' + DriveSep + DirSep + 'DIR1');
{$IFNDEF NODOTS}
Check ('VolName' + DriveSep + DirSep + 'DIR1' + DirSep + '..', 'VolName' + DriveSep + DirSep);
Check ('VolName' + DriveSep + DirSep + 'DIR1' + DirSep + '..' + DirSep + '..',
'VolName' + DriveSep + DirSep);
Check ('VolName' + DriveSep + DirSep + '.', 'VolName:' + DirSep);
Check ('VolName' + DriveSep + DirSep + '..', 'VolName:' + DirSep);
Check ('VolName' + DriveSep + DirSep + '..' + DirSep, 'VolName' + DriveSep + DirSep);
{$ENDIF NODOTS}
{$IFDEF NETWARE}
Check ('SrvName\VolName' + DriveSep + DirSep + 'TEST', 'SrvName' + DirSep + 'VolName' +
DriveSep + DirSep + 'TEST');
Check ('SrvName/VolName' + DriveSep + DirSep + 'TEST', 'SrvName' + DirSep + 'VolName' +
DriveSep + DirSep + 'TEST');
{$ENDIF NETWARE}
{$IFDEF AMIGA}
{$IFDEF NODOTS}
Check ('.', CurDir + DirSep + '.');
{$ELSE NODOTS}
Check ('.', CurDir);
{$ENDIF NODOTS}
{$ENDIF AMIGA}
{$ENDIF VOLUMES}
Erase (F);
{$IFNDEF NODRIVEC}
ChDir (OrigTstDir);
{$ENDIF NODRIVEC}
ChDir (OrigDir);
RmDir (TestDir0 + TestDir1Name + DirectorySeparator2 + TestDir2Name);
RmDir (TestDir0 + TestDir1Name);
if HasErrors then
begin
WriteLn ('FExpand doesn''t work correctly.');
Halt (1);
end;
end.