mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-29 11:00:23 +02:00
* separated some tests
* make tfexpand more portable
This commit is contained in:
carl
parent
fb5b623e30
commit
f088674d6a
86
tests/test/units/dos/tbreak.pp
Normal file
86
tests/test/units/dos/tbreak.pp
Normal file
@ -0,0 +1,86 @@
|
||||
{******************************************}
|
||||
{ Used to check the DOS unit }
|
||||
{------------------------------------------}
|
||||
{ SetCBreak / GetCBreak routine testing }
|
||||
{******************************************}
|
||||
Program tbreak;
|
||||
|
||||
|
||||
{ verifies that the DOSError variable is equal to }
|
||||
{ the value requested. }
|
||||
Procedure CheckDosError(err: Integer);
|
||||
var
|
||||
x : integer;
|
||||
s :string;
|
||||
Begin
|
||||
Write('Verifying value of DOS Error...');
|
||||
x := DosError;
|
||||
case x of
|
||||
0 : s := '(0): No Error.';
|
||||
2 : s := '(2): File not found.';
|
||||
3 : s := '(3): Path not found.';
|
||||
5 : s := '(5): Access Denied.';
|
||||
6 : s := '(6): Invalid File Handle.';
|
||||
8 : s := '(8): Not enough memory.';
|
||||
10 : s := '(10) : Invalid Environment.';
|
||||
11 : s := '(11) : Invalid format.';
|
||||
18 : s := '(18) : No more files.';
|
||||
else
|
||||
s := 'INVALID DOSERROR';
|
||||
end;
|
||||
if err <> x then
|
||||
Begin
|
||||
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
|
||||
Halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn('Success.');
|
||||
end;
|
||||
|
||||
|
||||
Procedure TestCBreak;
|
||||
Var
|
||||
B: Boolean;
|
||||
s: string;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' GETCBREAK/SETCBREAK ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
s:='Testing GetCBreak...';
|
||||
SetCBreak(TRUE);
|
||||
CheckDosError(0);
|
||||
GetCBreak(b);
|
||||
CheckDosError(0);
|
||||
if b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
end;
|
||||
{ actually setting Ctrl-C only works under DOS }
|
||||
{$ifdef go32v2}
|
||||
s:='Testing GetCBreak...';
|
||||
SetCBreak(FALSE);
|
||||
CheckDosError(0);
|
||||
GetCBreak(b);
|
||||
CheckDosError(0);
|
||||
if NOT b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
end;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
Begin
|
||||
testcbreak;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-11-08 21:01:18 carl
|
||||
* separated some tests
|
||||
* make tfexpand more portable
|
||||
|
||||
}
|
||||
70
tests/test/units/dos/tdisk.pp
Normal file
70
tests/test/units/dos/tdisk.pp
Normal file
@ -0,0 +1,70 @@
|
||||
{ %INTERACTIVE }
|
||||
{******************************************}
|
||||
{ Used to check the DOS unit }
|
||||
{------------------------------------------}
|
||||
{ DiskFree / DiskSize routine testing }
|
||||
{******************************************}
|
||||
uses dos;
|
||||
|
||||
{ verifies that the DOSError variable is equal to }
|
||||
{ the value requested. }
|
||||
Procedure CheckDosError(err: Integer);
|
||||
var
|
||||
x : integer;
|
||||
s :string;
|
||||
Begin
|
||||
Write('Verifying value of DOS Error...');
|
||||
x := DosError;
|
||||
case x of
|
||||
0 : s := '(0): No Error.';
|
||||
2 : s := '(2): File not found.';
|
||||
3 : s := '(3): Path not found.';
|
||||
5 : s := '(5): Access Denied.';
|
||||
6 : s := '(6): Invalid File Handle.';
|
||||
8 : s := '(8): Not enough memory.';
|
||||
10 : s := '(10) : Invalid Environment.';
|
||||
11 : s := '(11) : Invalid format.';
|
||||
18 : s := '(18) : No more files.';
|
||||
else
|
||||
s := 'INVALID DOSERROR';
|
||||
end;
|
||||
if err <> x then
|
||||
Begin
|
||||
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
|
||||
Halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn('Success.');
|
||||
end;
|
||||
|
||||
|
||||
Procedure TestdiskSize;
|
||||
Var
|
||||
i : Integer;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' DISKSIZE/DISKFREE ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' Note: Should return -1 on both functions if device is not ready. ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
{ Check Disksize / DiskFree routines }
|
||||
for I:=0 to 20 do
|
||||
Begin
|
||||
Write('Disk unit ',i:2,' free size : ',DiskFree(i):10, ' Total Size: ',DiskSize(i):10);
|
||||
WriteLn(' bytes.');
|
||||
end;
|
||||
CheckDosError(0);
|
||||
end;
|
||||
|
||||
Begin
|
||||
TestDiskSize;
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-11-08 21:01:18 carl
|
||||
* separated some tests
|
||||
* make tfexpand more portable
|
||||
|
||||
}
|
||||
@ -37,7 +37,7 @@ Uses Dos;
|
||||
{$IFDEF WIN32}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
{$IFDEF TOS}
|
||||
{$IFDEF ATARI}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
|
||||
@ -120,157 +120,10 @@ Procedure CheckDosError(err: Integer);
|
||||
end;
|
||||
|
||||
|
||||
Procedure TestdiskSize;
|
||||
Var
|
||||
i : Integer;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' DISKSIZE/DISKFREE ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' Note: Should return -1 on both functions if device is not ready. ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
{ Check Disksize / DiskFree routines }
|
||||
for I:=0 to 20 do
|
||||
Begin
|
||||
Write('Disk unit ',i:2,' free size : ',DiskFree(i):10, ' Total Size: ',DiskSize(i):10);
|
||||
WriteLn(' bytes.');
|
||||
end;
|
||||
CheckDosError(0);
|
||||
PauseScreen;
|
||||
end;
|
||||
|
||||
Procedure TestDosVersion;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' DOSVERSION ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' Note: Number should be major version followed by minor version. ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
{*------------------------- NOTE -------------------------------------*}
|
||||
{* This is OS specific. LO -> Major revision, HI -> Minor Revision *}
|
||||
{*--------------------------------------------------------------------*}
|
||||
WriteLn('Operating system Version :',Lo(DosVersion),'.',Hi(DosVersion));
|
||||
CheckDosError(0);
|
||||
PauseScreen;
|
||||
end;
|
||||
|
||||
Procedure TestEnvCount;
|
||||
Var
|
||||
I: Integer;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' ENVCOUNT/ENVSTR ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' Note: Environment variables should be of the form VAR=VALUE ');
|
||||
WriteLn(' Note: Non valid indexes should return empty strings. ');
|
||||
WriteLn(' Note: Index 0 points to an empty string ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
PauseScreen;
|
||||
{*------------------------- NOTE -------------------------------------*}
|
||||
{* Variables should be of the form VAR=VALUE *}
|
||||
{*--------------------------------------------------------------------*}
|
||||
WriteLn('Number of environment variables : ',EnvCount);
|
||||
WriteLn('CURRENT ENVIRONMENT');
|
||||
For I:=1 to EnvCount do
|
||||
WriteLn(EnvStr(i));
|
||||
CheckDosError(0);
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' Note: The next few lines should be empty strings, as they are ');
|
||||
WriteLn(' invalid environment indexes. ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
For i:=-5 to 0 do
|
||||
WriteLn(EnvStr(i));
|
||||
CheckDosError(0);
|
||||
For i:=20000 to 20002 do
|
||||
WriteLn(EnvStr(i));
|
||||
CheckDosError(0);
|
||||
PauseScreen;
|
||||
end;
|
||||
|
||||
Procedure TestVerify;
|
||||
Var
|
||||
B: Boolean;
|
||||
s: string;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' GETVERIFY/SETVERIFY ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
s:='Testing GetVerify...';
|
||||
SetVerify(TRUE);
|
||||
CheckDosError(0);
|
||||
GetVerify(b);
|
||||
CheckDosError(0);
|
||||
if b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
end;
|
||||
s:='Testing GetVerify...';
|
||||
SetVerify(FALSE);
|
||||
CheckDosError(0);
|
||||
GetVerify(b);
|
||||
CheckDosError(0);
|
||||
{ verify actually only works under dos }
|
||||
{ and always returns TRUE on other platforms }
|
||||
{$ifdef go32v2}
|
||||
if NOT b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
end;
|
||||
{$else}
|
||||
if b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
end;
|
||||
{$endif}
|
||||
PauseScreen;
|
||||
end;
|
||||
|
||||
Procedure TestCBreak;
|
||||
Var
|
||||
B: Boolean;
|
||||
s: string;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' GETCBREAK/SETCBREAK ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
s:='Testing GetCBreak...';
|
||||
SetCBreak(TRUE);
|
||||
CheckDosError(0);
|
||||
GetCBreak(b);
|
||||
CheckDosError(0);
|
||||
if b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
end;
|
||||
{ actually setting Ctrl-C only works under DOS }
|
||||
{$ifdef go32v2}
|
||||
s:='Testing GetCBreak...';
|
||||
SetCBreak(FALSE);
|
||||
CheckDosError(0);
|
||||
GetCBreak(b);
|
||||
CheckDosError(0);
|
||||
if NOT b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
end;
|
||||
{$endif}
|
||||
PauseScreen;
|
||||
end;
|
||||
|
||||
|
||||
Procedure TestSystemDate;
|
||||
@ -415,142 +268,6 @@ Begin
|
||||
end;
|
||||
|
||||
|
||||
Procedure TestFAttr;
|
||||
Var
|
||||
F: File;
|
||||
Attr: Word;
|
||||
s: string;
|
||||
Begin
|
||||
PauseScreen;
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' GETFATTR / SETFATTR ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
|
||||
WriteLn('Opening an invalid file...Success.');
|
||||
Assign(f,'');
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(3);
|
||||
Assign(f,TestFName);
|
||||
WriteLn('Trying to open a valid file..Success.');
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
{----------------------------------------------------------------}
|
||||
{ This routine causes problems, because it all depends on the }
|
||||
{ operating system. It is assumed here that HIDDEN is available }
|
||||
{ to all operating systems. }
|
||||
{----------------------------------------------------------------}
|
||||
s:='Setting read-only attribute on '+TestFName+'...';
|
||||
SetFAttr(f,ReadOnly);
|
||||
CheckDosError(0);
|
||||
{$IFDEF EXTATTR}
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and ReadOnly<> 0 then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Read-only attribute not set.');
|
||||
end;
|
||||
{ file should no longer be read only }
|
||||
s:='Removing read-only attribute...';
|
||||
SetFAttr(f,Archive);
|
||||
CheckDosError(0);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and ReadOnly<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Read-only attribute still set.');
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
{$ENDIF}
|
||||
|
||||
s:='Setting hidden attribute on '+TestFName+'...';
|
||||
SetFAttr(f,Hidden);
|
||||
CheckDosError(0);
|
||||
{$IFDEF EXTATTR}
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and Hidden<> 0 then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Hidden attribute not set.');
|
||||
end;
|
||||
|
||||
{ file should no longer be read only }
|
||||
s:='Removing hidden attribute...';
|
||||
SetFAttr(f,Archive);
|
||||
CheckDosError(0);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and Hidden<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Hidden attribute still set.');
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
{$ENDIF}
|
||||
|
||||
s:='Setting system attribute on '+TestFName+'...';
|
||||
SetFAttr(f,SysFile);
|
||||
CheckDosError(0);
|
||||
{$IFDEF EXTATTR}
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and SysFile<> 0 then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. SysFile attribute not set.');
|
||||
end;
|
||||
{ file should no longer be read only }
|
||||
s:='Removing read-only attribute...';
|
||||
SetFAttr(f,Archive);
|
||||
CheckDosError(0);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and Sysfile<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. SysFile attribute still set.');
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
{$ENDIF}
|
||||
|
||||
s:='Setting Directory attribute on '+TestFName+'...';
|
||||
SetFAttr(f,Directory);
|
||||
CheckDosError(5);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and Directory<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Directory Attribute set.');
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
|
||||
{**********************************************************************}
|
||||
{********************** TURBO PASCAL BUG ******************************}
|
||||
{ The File is not a volume name, and DosError = 0, which is incorrect }
|
||||
{ it shoulf not be so in FPC. }
|
||||
{**********************************************************************}
|
||||
{********************** TURBO PASCAL BUG ******************************}
|
||||
s:='Setting Volume attribute on '+TestFName+'...';
|
||||
SetFAttr(f,VolumeID);
|
||||
CheckDosError(5);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and VolumeID<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Volume Attribute set.');
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
|
||||
PauseScreen;
|
||||
end;
|
||||
|
||||
|
||||
Procedure TestFTime;
|
||||
@ -942,10 +659,7 @@ var
|
||||
F: File;
|
||||
Attr : Word;
|
||||
Begin
|
||||
TestDiskSize;
|
||||
TestDosVersion;
|
||||
TestEnvCount;
|
||||
TestVerify;
|
||||
TestSystemDate;
|
||||
TestSystemTime;
|
||||
|
||||
@ -959,7 +673,6 @@ Begin
|
||||
Rewrite(f,1);
|
||||
Close(F);
|
||||
MkDir(TestDir);
|
||||
TestFAttr;
|
||||
TestFTime;
|
||||
TestCBreak;
|
||||
TestFind;
|
||||
@ -971,7 +684,11 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.7 2002-09-07 15:40:56 peter
|
||||
Revision 1.8 2002-11-08 21:01:18 carl
|
||||
* separated some tests
|
||||
* make tfexpand more portable
|
||||
|
||||
Revision 1.7 2002/09/07 15:40:56 peter
|
||||
* old logs removed and tabs fixed
|
||||
|
||||
}
|
||||
|
||||
85
tests/test/units/dos/tenv.pp
Normal file
85
tests/test/units/dos/tenv.pp
Normal file
@ -0,0 +1,85 @@
|
||||
{******************************************}
|
||||
{ Used to check the DOS unit }
|
||||
{------------------------------------------}
|
||||
{ TestEncCount routine testing }
|
||||
{******************************************}
|
||||
Program tenv;
|
||||
|
||||
uses dos;
|
||||
|
||||
|
||||
{ verifies that the DOSError variable is equal to }
|
||||
{ the value requested. }
|
||||
Procedure CheckDosError(err: Integer);
|
||||
var
|
||||
x : integer;
|
||||
s :string;
|
||||
Begin
|
||||
Write('Verifying value of DOS Error...');
|
||||
x := DosError;
|
||||
case x of
|
||||
0 : s := '(0): No Error.';
|
||||
2 : s := '(2): File not found.';
|
||||
3 : s := '(3): Path not found.';
|
||||
5 : s := '(5): Access Denied.';
|
||||
6 : s := '(6): Invalid File Handle.';
|
||||
8 : s := '(8): Not enough memory.';
|
||||
10 : s := '(10) : Invalid Environment.';
|
||||
11 : s := '(11) : Invalid format.';
|
||||
18 : s := '(18) : No more files.';
|
||||
else
|
||||
s := 'INVALID DOSERROR';
|
||||
end;
|
||||
if err <> x then
|
||||
Begin
|
||||
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
|
||||
Halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn('Success.');
|
||||
end;
|
||||
|
||||
|
||||
Procedure TestEnvCount;
|
||||
Var
|
||||
I: Integer;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' ENVCOUNT/ENVSTR ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' Note: Environment variables should be of the form VAR=VALUE ');
|
||||
WriteLn(' Note: Non valid indexes should return empty strings. ');
|
||||
WriteLn(' Note: Index 0 points to an empty string ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
{*------------------------- NOTE -------------------------------------*}
|
||||
{* Variables should be of the form VAR=VALUE *}
|
||||
{*--------------------------------------------------------------------*}
|
||||
WriteLn('Number of environment variables : ',EnvCount);
|
||||
WriteLn('CURRENT ENVIRONMENT');
|
||||
For I:=1 to EnvCount do
|
||||
WriteLn(EnvStr(i));
|
||||
CheckDosError(0);
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' Note: The next few lines should be empty strings, as they are ');
|
||||
WriteLn(' invalid environment indexes. ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
For i:=-5 to 0 do
|
||||
WriteLn(EnvStr(i));
|
||||
CheckDosError(0);
|
||||
For i:=20000 to 20002 do
|
||||
WriteLn(EnvStr(i));
|
||||
CheckDosError(0);
|
||||
end;
|
||||
|
||||
Begin
|
||||
TestEnvCount;
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-11-08 21:01:18 carl
|
||||
* separated some tests
|
||||
* make tfexpand more portable
|
||||
|
||||
}
|
||||
319
tests/test/units/dos/tfattr.pp
Normal file
319
tests/test/units/dos/tfattr.pp
Normal file
@ -0,0 +1,319 @@
|
||||
{******************************************}
|
||||
{ Used to check the DOS unit }
|
||||
{------------------------------------------}
|
||||
{ SetFAttr / GetFAttr testing }
|
||||
{******************************************}
|
||||
Program tfattr;
|
||||
|
||||
uses dos;
|
||||
|
||||
{$IFDEF MSDOS}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
{$IFDEF DPMI}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
{$IFDEF GO32V1}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
{$IFDEF GO32V2}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
{$IFDEF OS2}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
{$IFDEF WIN32}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
{$IFDEF ATARI}
|
||||
{$DEFINE EXTATTR}
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
CONST
|
||||
{ what is the root path }
|
||||
{$IFDEF EXTATTR}
|
||||
RootPath = 'C:\';
|
||||
{$ENDIF}
|
||||
{$IFDEF UNIX}
|
||||
RootPath = '/';
|
||||
{$ENDIF}
|
||||
Week:Array[0..6] of String =
|
||||
('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
|
||||
|
||||
TestFName = 'TESTDOS.DAT'; { CASE SENSITIVE DON'T TOUCH! }
|
||||
TestFName1 = 'TESTFILE'; { CASE SENSITIVE DON'T TOUCH! }
|
||||
TestDir = 'MYDIR'; { CASE SENSITIVE DON'T TOUCH! }
|
||||
TestExt = 'DAT';
|
||||
{$IFDEF TP}
|
||||
DirectorySeparator = '\';
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
{ verifies that the DOSError variable is equal to }
|
||||
{ the value requested. }
|
||||
Procedure CheckDosError(err: Integer);
|
||||
var
|
||||
x : integer;
|
||||
s :string;
|
||||
Begin
|
||||
x := DosError;
|
||||
case x of
|
||||
0 : s := '(0): No Error.';
|
||||
2 : s := '(2): File not found.';
|
||||
3 : s := '(3): Path not found.';
|
||||
5 : s := '(5): Access Denied.';
|
||||
6 : s := '(6): Invalid File Handle.';
|
||||
8 : s := '(8): Not enough memory.';
|
||||
10 : s := '(10) : Invalid Environment.';
|
||||
11 : s := '(11) : Invalid format.';
|
||||
18 : s := '(18) : No more files.';
|
||||
else
|
||||
s := 'INVALID DOSERROR';
|
||||
end;
|
||||
if err <> x then
|
||||
Begin
|
||||
WriteLn('FAILURE. (Value of DOSError should be ',err,' '+s+')');
|
||||
Halt(1);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure fail;
|
||||
Begin
|
||||
WriteLn('Failed!');
|
||||
Halt(1);
|
||||
End;
|
||||
|
||||
Procedure TestFAttr1;
|
||||
Var
|
||||
F: File;
|
||||
Attr: Word;
|
||||
s: string;
|
||||
Begin
|
||||
WriteLn('Opening an invalid file...Success!');
|
||||
Assign(f,'');
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(3);
|
||||
Assign(f,TestFName);
|
||||
WriteLn('Trying to open a valid file...Success!');
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
Write('Trying to open the current directory file...');
|
||||
Assign(f,'.');
|
||||
GetFAttr(f,Attr);
|
||||
if (attr and Directory) = 0 then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
CheckDosError(0);
|
||||
Write('Trying to open the parent directory file...');
|
||||
Assign(f,'..');
|
||||
GetFAttr(f,Attr);
|
||||
if (attr and Directory) = 0 then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
CheckDosError(0);
|
||||
{ This is completely platform dependent
|
||||
Write('Trying to open the parent directory file when in root...');
|
||||
Getdir(0,s);
|
||||
ChDir(RootPath);
|
||||
Assign(f,'..');
|
||||
GetFAttr(f,Attr);
|
||||
ChDir(s);
|
||||
CheckDosError(3);
|
||||
WriteLn('Success!');
|
||||
}
|
||||
{ Should normally fail, because of end directory separator }
|
||||
WriteLn('Trying to open a directory file...Success!');
|
||||
GetDir(0,s);
|
||||
Assign(f,s+DirectorySeparator);
|
||||
GetFAttr(f, Attr);
|
||||
CheckDosError(3);
|
||||
|
||||
Write('Trying to open a directory file...');
|
||||
GetDir(0,s);
|
||||
Assign(f,s);
|
||||
GetFAttr(f, Attr);
|
||||
if (attr and Directory) = 0 then
|
||||
fail
|
||||
else
|
||||
WriteLn('Success!');
|
||||
CheckDosError(0);
|
||||
end;
|
||||
|
||||
Procedure TestFAttr;
|
||||
Var
|
||||
F: File;
|
||||
Attr: Word;
|
||||
s: string;
|
||||
Begin
|
||||
Assign(f, TestFname);
|
||||
{----------------------------------------------------------------}
|
||||
{ This routine causes problems, because it all depends on the }
|
||||
{ operating system. It is assumed here that HIDDEN is available }
|
||||
{ to all operating systems. }
|
||||
{----------------------------------------------------------------}
|
||||
s:='Setting read-only attribute on '+TestFName+'...';
|
||||
SetFAttr(f,ReadOnly);
|
||||
CheckDosError(0);
|
||||
{$IFDEF EXTATTR}
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and ReadOnly<> 0 then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Read-only attribute not set.');
|
||||
halt(1);
|
||||
end;
|
||||
{ file should no longer be read only }
|
||||
s:='Removing read-only attribute...';
|
||||
SetFAttr(f,Archive);
|
||||
CheckDosError(0);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and ReadOnly<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Read-only attribute still set.');
|
||||
halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
{$ENDIF}
|
||||
|
||||
s:='Setting hidden attribute on '+TestFName+'...';
|
||||
SetFAttr(f,Hidden);
|
||||
CheckDosError(0);
|
||||
{$IFDEF EXTATTR}
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and Hidden<> 0 then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Hidden attribute not set.');
|
||||
halt(1);
|
||||
end;
|
||||
|
||||
{ file should no longer be read only }
|
||||
s:='Removing hidden attribute...';
|
||||
SetFAttr(f,Archive);
|
||||
CheckDosError(0);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and Hidden<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Hidden attribute still set.');
|
||||
halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF EXTATTR}
|
||||
|
||||
s:='Setting system attribute on '+TestFName+'...';
|
||||
SetFAttr(f,SysFile);
|
||||
CheckDosError(0);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and SysFile<> 0 then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. SysFile attribute not set.');
|
||||
halt(1);
|
||||
end;
|
||||
{ file should no longer be read only }
|
||||
s:='Removing Sysfile attribute...';
|
||||
SetFAttr(f,0);
|
||||
CheckDosError(0);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and Sysfile<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. SysFile attribute still set.');
|
||||
halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
{$ENDIF}
|
||||
{
|
||||
s:='Setting Directory attribute on '+TestFName+'...';
|
||||
SetFAttr(f,Directory);
|
||||
CheckDosError(5);
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and Directory<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Directory Attribute set.');
|
||||
halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
}
|
||||
{**********************************************************************}
|
||||
{********************** TURBO PASCAL BUG ******************************}
|
||||
{ The File is not a volume name, and DosError = 0, which is incorrect }
|
||||
{ it shoulf not be so in FPC. }
|
||||
{**********************************************************************}
|
||||
{********************** TURBO PASCAL BUG ******************************}
|
||||
s:='Setting Volume attribute on '+TestFName+'...';
|
||||
SetFAttr(f,VolumeID);
|
||||
{$ifndef tp}
|
||||
CheckDosError(5);
|
||||
{$else}
|
||||
CheckDosError(0);
|
||||
{$endif}
|
||||
GetFAttr(f,Attr);
|
||||
CheckDosError(0);
|
||||
if Attr and VolumeID<> 0 then
|
||||
Begin
|
||||
WriteLn(s+'FAILURE. Volume Attribute set.');
|
||||
halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn(s+'Success.');
|
||||
end;
|
||||
|
||||
|
||||
|
||||
|
||||
var
|
||||
f: file;
|
||||
oldexit : pointer;
|
||||
|
||||
procedure MyExit;far;
|
||||
begin
|
||||
ExitProc := OldExit;
|
||||
RmDir(TestDir);
|
||||
Assign(f, TestFname);
|
||||
Erase(f);
|
||||
Assign(f, TestFname1);
|
||||
Erase(f);
|
||||
end;
|
||||
|
||||
|
||||
Begin
|
||||
WriteLn('File should never be executed in root path!');
|
||||
OldExit := ExitProc;
|
||||
ExitProc := @MyExit;
|
||||
Assign(f,TestFName);
|
||||
Rewrite(f,1);
|
||||
BlockWrite(f,Week,sizeof(Week));
|
||||
Close(f);
|
||||
Assign(f,TestFName1);
|
||||
Rewrite(f,1);
|
||||
Close(F);
|
||||
MkDir(TestDir);
|
||||
testfattr1;
|
||||
testfattr;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-11-08 21:01:18 carl
|
||||
* separated some tests
|
||||
* make tfexpand more portable
|
||||
|
||||
}
|
||||
@ -29,21 +29,17 @@ function _DosError (Error: longint): longint; cdecl;
|
||||
{$ENDIF NETWARE}
|
||||
|
||||
const
|
||||
{$IFDEF FPC}
|
||||
{$IFDEF VER1_0}
|
||||
{$IFDEF UNIX}
|
||||
FileNameCaseSensitive = true;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
{$ELSE}
|
||||
{$IFNDEF FPC}
|
||||
FileNameCaseSensitive = false;
|
||||
{$ENDIF}
|
||||
{$IFDEF UNIX}
|
||||
DirSep = '/';
|
||||
CDrive = '';
|
||||
{$ELSE}
|
||||
DirSep = '\';
|
||||
CDrive = 'C:';
|
||||
{$ELSE}
|
||||
DirSep = System.DirectorySeparator;
|
||||
{$IFDEF UNIX}
|
||||
CDrive = '';
|
||||
{$ELSE}
|
||||
CDrive = 'C:';
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
HasErrors: boolean = false;
|
||||
|
||||
|
||||
102
tests/test/units/dos/tverify.pp
Normal file
102
tests/test/units/dos/tverify.pp
Normal file
@ -0,0 +1,102 @@
|
||||
{******************************************}
|
||||
{ Used to check the DOS unit }
|
||||
{------------------------------------------}
|
||||
{ SetVerify / GetVerify routine testing }
|
||||
{******************************************}
|
||||
Program tverify;
|
||||
|
||||
uses dos;
|
||||
|
||||
{$IFDEF GO32V2}
|
||||
{$DEFINE SUPPORTS_VERIFY}
|
||||
{$ENDIF}
|
||||
|
||||
{ verifies that the DOSError variable is equal to }
|
||||
{ the value requested. }
|
||||
Procedure CheckDosError(err: Integer);
|
||||
var
|
||||
x : integer;
|
||||
s :string;
|
||||
Begin
|
||||
Write('Verifying value of DOS Error...');
|
||||
x := DosError;
|
||||
case x of
|
||||
0 : s := '(0): No Error.';
|
||||
2 : s := '(2): File not found.';
|
||||
3 : s := '(3): Path not found.';
|
||||
5 : s := '(5): Access Denied.';
|
||||
6 : s := '(6): Invalid File Handle.';
|
||||
8 : s := '(8): Not enough memory.';
|
||||
10 : s := '(10) : Invalid Environment.';
|
||||
11 : s := '(11) : Invalid format.';
|
||||
18 : s := '(18) : No more files.';
|
||||
else
|
||||
s := 'INVALID DOSERROR';
|
||||
end;
|
||||
if err <> x then
|
||||
Begin
|
||||
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
|
||||
Halt(1);
|
||||
end
|
||||
else
|
||||
WriteLn('Success.');
|
||||
end;
|
||||
|
||||
Procedure TestVerify;
|
||||
Var
|
||||
B: Boolean;
|
||||
s: string;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' GETVERIFY/SETVERIFY ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
s:='Testing GetVerify...';
|
||||
SetVerify(TRUE);
|
||||
CheckDosError(0);
|
||||
GetVerify(b);
|
||||
CheckDosError(0);
|
||||
if b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
halt(1);
|
||||
end;
|
||||
s:='Testing GetVerify...';
|
||||
SetVerify(FALSE);
|
||||
CheckDosError(0);
|
||||
GetVerify(b);
|
||||
CheckDosError(0);
|
||||
{ verify actually only works under dos }
|
||||
{ and always returns TRUE on other platforms }
|
||||
{$ifdef supports_verify}
|
||||
if NOT b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
halt(1);
|
||||
end;
|
||||
{$else}
|
||||
if b then
|
||||
WriteLn(s+'Success.')
|
||||
else
|
||||
Begin
|
||||
WriteLn(s+'FAILURE.');
|
||||
halt(1);
|
||||
end;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
|
||||
Begin
|
||||
testverify;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-11-08 21:01:18 carl
|
||||
* separated some tests
|
||||
* make tfexpand more portable
|
||||
|
||||
}
|
||||
69
tests/test/units/dos/tversion.pp
Normal file
69
tests/test/units/dos/tversion.pp
Normal file
@ -0,0 +1,69 @@
|
||||
{ %INTERACTIVE }
|
||||
|
||||
{******************************************}
|
||||
{ Used to check the DOS unit }
|
||||
{------------------------------------------}
|
||||
{ DosVersion routine testing }
|
||||
{******************************************}
|
||||
program tversion;
|
||||
|
||||
uses dos;
|
||||
|
||||
{ verifies that the DOSError variable is equal to }
|
||||
{ the value requested. }
|
||||
Procedure CheckDosError(err: Integer);
|
||||
var
|
||||
x : integer;
|
||||
s :string;
|
||||
Begin
|
||||
Write('Verifying value of DOS Error...');
|
||||
x := DosError;
|
||||
case x of
|
||||
0 : s := '(0): No Error.';
|
||||
2 : s := '(2): File not found.';
|
||||
3 : s := '(3): Path not found.';
|
||||
5 : s := '(5): Access Denied.';
|
||||
6 : s := '(6): Invalid File Handle.';
|
||||
8 : s := '(8): Not enough memory.';
|
||||
10 : s := '(10) : Invalid Environment.';
|
||||
11 : s := '(11) : Invalid format.';
|
||||
18 : s := '(18) : No more files.';
|
||||
else
|
||||
s := 'INVALID DOSERROR';
|
||||
end;
|
||||
if err <> x then
|
||||
Begin
|
||||
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
|
||||
end
|
||||
else
|
||||
WriteLn('Success.');
|
||||
end;
|
||||
|
||||
|
||||
|
||||
Procedure TestDosVersion;
|
||||
Begin
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' DOSVERSION ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
WriteLn(' Note: Number should be major version followed by minor version. ');
|
||||
WriteLn('----------------------------------------------------------------------');
|
||||
CheckDosError(0);
|
||||
{*------------------------- NOTE -------------------------------------*}
|
||||
{* This is OS specific. LO -> Major revision, HI -> Minor Revision *}
|
||||
{*--------------------------------------------------------------------*}
|
||||
WriteLn('Operating system Version : ',Lo(DosVersion),'.',Hi(DosVersion));
|
||||
CheckDosError(0);
|
||||
end;
|
||||
|
||||
Begin
|
||||
TestDosVersion;
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2002-11-08 21:01:18 carl
|
||||
* separated some tests
|
||||
* make tfexpand more portable
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user