t_id
253
t_adddate
2003/10/03
t_result
0
t_knownrunerror
0
| tr_id | run | tr_ok | tr_skip | tr_result |
|---|---|---|---|---|
| 443619187 | 934961 | True | False | Successfully run |
Record count: 1
program TFExpand;
(* Test for possible bugs in Dos.FExpand *)
{ $DEFINE DEBUG}
(* Defining DEBUG causes all the source and target strings *)
(* to be written to the console to make debugging easier. *)
uses
{$ifdef FPC}
{$ifdef win32}
win32err,
{$endif win32}
{$endif FPC}
Dos;
{$IFDEF OS2}
function _DosError (Error: longint): longint; cdecl;
external 'DOSCALLS' index 212;
{$ENDIF OS2}
{$IFDEF LINUX}
{$IFNDEF UNIX}
{$DEFINE UNIX}
{$ENDIF UNIX}
{$ENDIF LINUX}
{$IFDEF AMIGA}
{$DEFINE VOLUMES}
{$ENDIF AMIGA}
{$IFDEF NETWARE}
{$DEFINE VOLUMES}
{$ENDIF NETWARE}
const
{$IFNDEF FPC}
FileNameCaseSensitive = false;
DirSep = '';
CDrive = 'C:';
{$ELSE}
DirSep = System.DirectorySeparator;
{$IFDEF UNIX}
CDrive = '';
{$ELSE}
CDrive = 'C:';
{$ENDIF}
{$ENDIF}
HasErrors: boolean = false;
var
TestDir, OrigDir, OrigTstDir, CurDir, CDir, S: DirStr;
TestDrive: string [2];
I: byte;
IOR: longint;
function Translate (S: PathStr): PathStr;
var
I: byte;
begin
{$IFDEF UNIX}
if (Length (S) > 1) and (S [2] = ':') then Delete (S, 1, 2);
{$ELSE}
for I := 1 to Length (S) do if S [I] = '/' then S [I] := DirSep;
if (Length (S) > 0) and (S [1] in ['a'..'z']) then S [1] := UpCase (S [1]);
{$ENDIF}
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}
Rslt := Translate (Rslt);
Rslt2 := FExpand (Src);
if Rslt <> Rslt2 then
begin
WriteLn ('Error: FExpand (', Src, ') should be "', Rslt, '", not "',
Rslt2, '"');
HasErrors := true;
end;
end;
begin
{$IFDEF OS2}
(* Avoid OS/2 error messages. *)
_DosError (0);
{$ENDIF OS2}
if ParamCount <> 1 then
begin
WriteLn ('Warning: Parameter missing!');
WriteLn ('Full path to a directory with write access' +
{$IFNDEF UNIX}
#13#10'(preferably not on a C: drive)' +
{$ENDIF}
' expected.');
WriteLn ('Trying to use the current directory instead ' +
{$IFDEF UNIX}
'(not quite ideal).');
{$ELSE UNIX}
'(problems might arise).');
{$ENDIF UNIX}
GetDir (0, TestDir);
end else TestDir := ParamStr (1);
if TestDir [Length (TestDir)] <> DirSep then TestDir := TestDir + DirSep;
GetDir (0, OrigDir);
{$IFDEF UNIX}
TestDrive := '';
{$ELSE UNIX}
TestDrive := Copy (TestDir, 1, 2);
GetDir ((Ord (TestDir [1]) and not ($20)) - 64, OrigTstDir);
{$ENDIF UNIX}
{$I-}
MkDir (TestDir + 'TESTDIR1');
if IOResult <> 0 then ;
MkDir (TestDir + 'TESTDIR1' + DirSep + 'TESTDIR2');
if IOResult <> 0 then ;
{$I+}
ChDir (TestDir + 'TESTDIR1' + DirSep + 'TESTDIR2');
GetDir (0, CurDir);
{$IFDEF UNIX}
CDir := CurDir;
{$ELSE UNIX}
GetDir (3, CDir);
{$ENDIF UNIX}
Check (' ', CurDir + DirSep + ' ');
Check ('', CurDir + DirSep);
Check ('.', CurDir);
Check ('C:', CDir);
Check ('C:.', CDir);
if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
else Check ('c:anything', CDir + DirSep + 'anything');
Check ('C:' + DirSep, CDrive + DirSep);
Check ('C:' + DirSep + '.', CDrive + DirSep);
Check ('C:' + DirSep + '..', CDrive + DirSep);
Check ('C:' + DirSep + 'DOS', CDrive + DirSep + 'DOS');
Check ('C:' + DirSep + '..' + DirSep + 'DOS', CDrive + DirSep + 'DOS');
Check ('C:' + DirSep + 'DOS.', CDrive + DirSep + 'DOS.');
Check ('C:' + DirSep + 'DOS' + DirSep, CDrive + DirSep + 'DOS' + DirSep);
Check ('C:' + DirSep + 'DOS' + DirSep + '.', CDrive + DirSep + 'DOS');
Check ('C:' + DirSep + 'DOS' + DirSep + '..', CDrive + DirSep);
Check ('C:' + DirSep + 'DOS' + DirSep + '..' + DirSep, CDrive + DirSep);
Check ('C:' + DirSep + 'DOS' + DirSep + 'TEST' + DirSep + '..', CDrive +
DirSep + 'DOS');
Check ('C:' + DirSep + 'DOS' + DirSep + 'TEST' + DirSep + '..' + DirSep,
CDrive + DirSep + 'DOS' + DirSep);
Check (DirSep, TestDrive + DirSep);
Check (DirSep + '.', TestDrive + DirSep);
Check (DirSep + '..', TestDrive + DirSep);
Check (DirSep + 'DOS', TestDrive + DirSep + 'DOS');
Check ('d', CurDir + DirSep + 'd');
Check (' d', CurDir + DirSep + ' d');
Check ('dd', CurDir + DirSep + 'dd');
Check ('dd' + DirSep + 'dd', CurDir + DirSep + 'dd' + DirSep + 'dd');
Check ('ddd', CurDir + DirSep + 'ddd');
Check ('dddd' + DirSep + 'eeee.ffff', CurDir + DirSep + 'dddd' + DirSep
+ 'eeee.ffff');
Check ('.special', CurDir + DirSep + '.special');
Check ('..special', CurDir + DirSep + '..special');
Check ('special..', CurDir + DirSep + 'special..');
Check ('special.' + DirSep, CurDir + DirSep + 'special.' + DirSep);
Check (DirSep + '.special', TestDrive + DirSep + '.special');
Check ('..', TestDir + 'TESTDIR1');
Check ('.' + DirSep + '..', TestDir + 'TESTDIR1');
Check ('..' + DirSep + '.', TestDir + 'TESTDIR1');
Check ('...', CurDir + DirSep + '...');
{$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}
Check (TestDrive + '..', TestDir + 'TESTDIR1');
Check (TestDrive + '..' + DirSep, TestDir + 'TESTDIR1' + DirSep);
Check (TestDrive + '.' + DirSep + '.', CurDir);
Check (TestDrive + '.' + DirSep + '..', TestDir + 'TESTDIR1');
{$I-}
{$ifndef unix}
{ avoid a and b drives for
no unix systems to reduce the
probablility of getting an alert message box }
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 ('dd/d', CurDir + DirSep + 'd' + DirSep + 'd' + DirSep + 'd');
Check ('\serversharedirectory', '\serversharedirectory');
Check ('\serversharedirectory1directory2..',
'\serversharedirectory1');
Check ('\', '\');
Check ('\.', '\.');
Check ('\.', '\.');
Check ('\..', '\..');
Check ('\...', '\...');
Check ('\....', '\....');
Check ('\.TEST', '\.TEST');
Check ('\..', '\..');
Check ('\..TEST', '\..TEST');
Check ('\..TEST.', '\..TEST');
Check ('\..TEST1TEST2..', '\..TEST1');
Check ('\..TEST..', '\..TEST');
Check ('\..TEST....', '\..TEST');
{$ENDIF FPC}
ChDir (OrigTstDir);
{$ENDIF UNIX}
{$IFDEF VOLUMES}
Check ('VolName:' + DirSep + 'DIR1', 'VolName:' + DirSep + 'DIR1');
Check ('VolName:' + DirSep + 'DIR1' + DirSep + '..', 'VolName:' + DirSep);
Check ('VolName:' + DirSep + 'DIR1' + DirSep + '..' + DirSep + '..',
'VolName:' + DirSep);
Check ('VolName:' + DirSep + '.', 'VolName:' + DirSep);
Check ('VolName:' + DirSep + '..', 'VolName:' + DirSep);
Check ('VolName:' + DirSep + '..' + DirSep, 'VolName:' + DirSep);
Check ('SrvNameVolName:' + DirSep + 'TEST', 'SrvName' + DirSep + 'VolName:' +
DirSep + 'TEST');
Check ('SrvName/VolName:' + DirSep + 'TEST', 'SrvName' + DirSep + 'VolName:' +
DirSep + 'TEST');
{$ENDIF VOLUMES}
ChDir (OrigDir);
RmDir (TestDir + 'TESTDIR1' + DirSep + 'TESTDIR2');
RmDir (TestDir + 'TESTDIR1');
if HasErrors then
begin
WriteLn ('FExpand doesn''t work correctly.');
Halt (1);
end;
end.