paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 22:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* tried to make as many as possible tests non interactive

Browse Source
This commit is contained in:
pierre 2002-11-18 09:49:49 +00:00
parent 9a8c771280
commit 2f85cb6f3e
10 changed files with 1017 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
tests/test/units/dos/tbreak.pp
View File

@ -7,6 +7,8 @@ Program tbreak;
uses dos;
const
has_errors : boolean = false;
{ verifies that the DOSError variable is equal to }
{ the value requested. }
@ -33,7 +35,7 @@ Procedure CheckDosError(err: Integer);
if err <> x then
Begin
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
Halt(1);
has_errors:=true;
end
else
WriteLn('Success.');
@ -58,6 +60,7 @@ Begin
WriteLn(s+'Success.')
else
Begin
has_errors:=true;
WriteLn(s+'FAILURE.');
end;
{ actually setting Ctrl-C only works under DOS }
@ -71,6 +74,7 @@ Begin
WriteLn(s+'Success.')
else
Begin
has_errors:=true;
WriteLn(s+'FAILURE.');
end;
{$endif}
@ -78,14 +82,19 @@ end;
Begin
testcbreak;
if has_errors then
Halt(1);
end.
{
$Log$
Revision 1.2 2002-11-09 23:08:07 carl
Revision 1.3 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
Revision 1.2 2002/11/09 23:08:07 carl
* fix compilation problems
Revision 1.1 2002/11/08 21:01:18 carl
* separated some tests
* make tfexpand more portable
}
}

18
tests/test/units/dos/tdisk.pp
View File

@ -1,4 +1,8 @@
{ %INTERACTIVE }
{ this one is interactive because
on removable drives it will generate
alert boxes on some OS like windows }
{******************************************}
{ Used to check the DOS unit }
{------------------------------------------}
@ -6,6 +10,9 @@
{******************************************}
uses dos;
const
has_errors : boolean = false;
{ verifies that the DOSError variable is equal to }
{ the value requested. }
Procedure CheckDosError(err: Integer);
@ -31,7 +38,7 @@ Procedure CheckDosError(err: Integer);
if err <> x then
Begin
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
Halt(1);
has_errors:=true;
end
else
WriteLn('Success.');
@ -59,12 +66,17 @@ end;
Begin
TestDiskSize;
if has_errors then
Halt(1);
end.
{
$Log$
Revision 1.1 2002-11-08 21:01:18 carl
Revision 1.2 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
Revision 1.1 2002/11/08 21:01:18 carl
* separated some tests
* make tfexpand more portable
}
}

38
tests/test/units/dos/tdos.pp
View File

@ -1,4 +1,3 @@
{ %INTERACTIVE }
{
$Id$
@ -23,6 +22,9 @@ uses dos;
{$DEFINE NOEXESUFFIX}
{$endif}
const
exedir : string = '';
procedure TestInfo;
var
dt : DateTime;
@ -43,8 +45,6 @@ begin
UnpackTime(ptime,DT);
writeln('Unpacked again (MM-DD-YYYY) ',Dt.Month,'-',Dt.Day,'-',Dt.Year,' ',Dt.Hour,':',Dt.Min,':',Dt.Sec);
writeln;
write('Press Enter');
Readln;
end;
@ -60,12 +60,9 @@ begin
writeln('GetEnv HOST : ',GetEnv('HOST'));
writeln('GetEnv PATH : ',GetEnv('PATH'));
writeln('GetEnv SHELL: ',GetEnv('SHELL'));
write('Press Enter for all Environment Strings using EnvStr()');
Readln;
write(' all Environment Strings using EnvStr()');
for i:=1 to EnvCount do
writeln(EnvStr(i));
write('Press Enter');
Readln;
end;
@ -74,19 +71,16 @@ begin
writeln;
writeln('Exec Functions');
writeln('**************');
write('Press Enter for an Exec of ''hello -good -day''');
Readln;
write('Going to Exec of ''hello -good -day''');
SwapVectors;
{$ifdef noexesuffix}
Exec('hello','-good -day');
Exec(exedir+'hello','-good -day');
{$else}
Exec('hello.exe','-good -day');
Exec(exedir+'hello.exe','-good -day');
{$endif}
SwapVectors;
writeln('Exit should be 213 : ',DosExitCode);
writeln('Error code should be 0 : ',DosError);
write('Press Enter');
Readln;
end;
@ -102,13 +96,12 @@ begin
writeln('DiskFree 0 : ',DiskFree(0));
writeln('DiskSize 0 : ',DiskSize(0));
{writeln('DiskSize 1 : ',DiskSize(1)); this is a: on dos ??! }
writeln('DiskSize 1 : ',DiskSize(3)); { this is c: on dos }
writeln('DiskSize 3 : ',DiskSize(3)); { this is c: on dos }
{$IFDEF Unix}
AddDisk('/fd0');
writeln('DiskSize 4 : ',DiskSize(4));
{$ENDIF}
write('Press Enter for FindFirst/FindNext Test');
Readln;
write('FindFirst/FindNext Test');
FindFirst('*.*',$20,Dir);
while (DosError=0) do
@ -117,8 +110,6 @@ begin
Writeln(dir.Name,' ',dir.Size,' ',DT.Year,'-',DT.Month,'-',DT.Day);
FindNext(Dir);
end;
write('Press Enter');
Readln;
end;
@ -181,13 +172,15 @@ begin
Writeln('Empty FSearch (should return empty string):',FSearch('',test));
write('Press Enter');
Readln;
end;
var
name,dir,ext : string;
begin
FSplit(paramstr(0),dir,name,ext);
exedir:=dir;
TestInfo;
TestEnvironment;
TestExec;
@ -197,7 +190,10 @@ end.
{
$Log$
Revision 1.7 2002-10-20 11:47:39 carl
Revision 1.8 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
Revision 1.7 2002/10/20 11:47:39 carl
* add format date to make test clearer
Revision 1.6 2002/09/07 15:40:56 peter

16
tests/test/units/dos/tdos2.pp
View File

@ -1,4 +1,3 @@
{ %INTERACTIVE }
{******************************************}
{ Used to check the DOS unit }
{------------------------------------------}
@ -79,14 +78,17 @@ CONST
TestFName1 = 'TESTFILE'; { CASE SENSITIVE DON'T TOUCH! }
TestDir = 'MYDIR'; { CASE SENSITIVE DON'T TOUCH! }
TestExt = 'DAT';
has_errors : boolean = false;
Procedure PauseScreen;
var
ch: char;
Begin
{ this is the non-interacting version
so we disable this
WriteLn('-- Press any key --');
ReadLn;
ReadLn;}
end;
{ verifies that the DOSError variable is equal to }
@ -114,6 +116,7 @@ Procedure CheckDosError(err: Integer);
if err <> x then
Begin
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
has_errors:=true;
end
else
WriteLn('Success.');
@ -659,7 +662,6 @@ var
F: File;
Attr : Word;
Begin
TestEnvCount;
TestSystemDate;
TestSystemTime;
@ -674,17 +676,21 @@ Begin
Close(F);
MkDir(TestDir);
TestFTime;
TestCBreak;
TestFind;
PauseScreen;
TestSplit;
RmDir(TestDir);
PauseScreen;
if has_errors then
halt(1);
end.
{
$Log$
Revision 1.8 2002-11-08 21:01:18 carl
Revision 1.9 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
Revision 1.8 2002/11/08 21:01:18 carl
* separated some tests
* make tfexpand more portable

15
tests/test/units/dos/tenv.pp
View File

@ -8,6 +8,10 @@ Program tenv;
uses dos;
const
has_errors : boolean = false;
{ verifies that the DOSError variable is equal to }
{ the value requested. }
Procedure CheckDosError(err: Integer);
@ -33,7 +37,7 @@ Procedure CheckDosError(err: Integer);
if err <> x then
Begin
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
Halt(1);
has_errors:=true;
end
else
WriteLn('Success.');
@ -74,12 +78,17 @@ end;
Begin
TestEnvCount;
if has_errors then
Halt(1);
end.
{
$Log$
Revision 1.1 2002-11-08 21:01:18 carl
Revision 1.2 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
Revision 1.1 2002/11/08 21:01:18 carl
* separated some tests
* make tfexpand more portable
}
}

32
tests/test/units/dos/tfattr.pp
View File

@ -48,6 +48,7 @@ CONST
{$IFDEF TP}
DirectorySeparator = '\';
{$ENDIF}
has_errors : boolean = false;
{ verifies that the DOSError variable is equal to }
@ -74,14 +75,14 @@ Procedure CheckDosError(err: Integer);
if err <> x then
Begin
WriteLn('FAILURE. (Value of DOSError should be ',err,' '+s+')');
Halt(1);
has_errors:=true;
end;
end;
procedure fail;
Begin
WriteLn('Failed!');
Halt(1);
has_errors:=true;
End;
Procedure TestFAttr1;
@ -114,7 +115,7 @@ Begin
else
WriteLn('Success!');
CheckDosError(0);
{ This is completely platform dependent
{ This is completely platform dependent
Write('Trying to open the parent directory file when in root...');
Getdir(0,s);
ChDir(RootPath);
@ -165,7 +166,7 @@ Begin
else
Begin
WriteLn(s+'FAILURE. Read-only attribute not set.');
halt(1);
has_errors:=true;
end;
{ file should no longer be read only }
s:='Removing read-only attribute...';
@ -176,7 +177,7 @@ Begin
if Attr and ReadOnly<> 0 then
Begin
WriteLn(s+'FAILURE. Read-only attribute still set.');
halt(1);
has_errors:=true;
end
else
WriteLn(s+'Success.');
@ -193,7 +194,7 @@ Begin
else
Begin
WriteLn(s+'FAILURE. Hidden attribute not set.');
halt(1);
has_errors:=true;
end;
{ file should no longer be read only }
@ -205,7 +206,7 @@ Begin
if Attr and Hidden<> 0 then
Begin
WriteLn(s+'FAILURE. Hidden attribute still set.');
halt(1);
has_errors:=true;
end
else
WriteLn(s+'Success.');
@ -223,7 +224,7 @@ Begin
else
Begin
WriteLn(s+'FAILURE. SysFile attribute not set.');
halt(1);
has_errors:=true;
end;
{ file should no longer be read only }
s:='Removing Sysfile attribute...';
@ -234,7 +235,7 @@ Begin
if Attr and Sysfile<> 0 then
Begin
WriteLn(s+'FAILURE. SysFile attribute still set.');
halt(1);
has_errors:=true;
end
else
WriteLn(s+'Success.');
@ -248,7 +249,7 @@ Begin
if Attr and Directory<> 0 then
Begin
WriteLn(s+'FAILURE. Directory Attribute set.');
halt(1);
has_errors:=true;
end
else
WriteLn(s+'Success.');
@ -271,7 +272,7 @@ Begin
if Attr and VolumeID<> 0 then
Begin
WriteLn(s+'FAILURE. Volume Attribute set.');
halt(1);
has_errors:=true;
end
else
WriteLn(s+'Success.');
@ -309,11 +310,16 @@ Begin
MkDir(TestDir);
testfattr1;
testfattr;
if has_errors then
halt(1);
end.
{
$Log$
Revision 1.1 2002-11-08 21:01:18 carl
Revision 1.2 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
Revision 1.1 2002/11/08 21:01:18 carl
* separated some tests
* make tfexpand more portable
}
}

7
tests/test/units/dos/tfexpand.pp
View File

@ -182,7 +182,14 @@ begin
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);

215
tests/test/units/dos/tidos.pp Normal file
View File

@ -0,0 +1,215 @@
{ %INTERACTIVE }
{
$Id$
Program to test DOS unit by Peter Vreman.
Only main TP functions are tested (nothing with Interrupts/Break/Verify).
}
{$V-}
program tesidos;
uses dos;
{ These should be defined for each operating system to be tested }
{ NOEXESUFFIX = No .EXE to prepend to prefix the file with to get }
{ a file executable. }
{$ifdef unix}
{$DEFINE NOEXESUFFIX}
{$endif}
{$ifdef amiga}
{$DEFINE NOEXESUFFIX}
{$endif}
procedure TestInfo;
var
dt : DateTime;
ptime : longint;
wday : word;
HSecs : word;
begin
writeln;
writeln('Info Functions');
writeln('**************');
writeln('Dosversion : ',lo(DosVersion),'.',hi(DosVersion));
GetDate(Dt.Year,Dt.Month,Dt.Day,wday);
writeln('Current Date (MM-DD-YYYY) : ',Dt.Month,'-',Dt.Day,'-',Dt.Year,' weekday ',wday);
GetTime(Dt.Hour,Dt.Min,Dt.Sec,HSecs);
writeln('Current Time (HH:MM:SS) : ',Dt.Hour,':',Dt.Min,':',Dt.Sec,' hsecs ',HSecs);
PackTime(Dt,ptime);
writeln('Packed like dos: ',ptime);
UnpackTime(ptime,DT);
writeln('Unpacked again (MM-DD-YYYY) ',Dt.Month,'-',Dt.Day,'-',Dt.Year,' ',Dt.Hour,':',Dt.Min,':',Dt.Sec);
writeln;
write('Press Enter');
Readln;
end;
procedure TestEnvironment;
var
i : longint;
begin
writeln;
writeln('Environment Functions');
writeln('*********************');
writeln('Amount of environment strings : ',EnvCount);
writeln('GetEnv TERM : ',GetEnv('TERM'));
writeln('GetEnv HOST : ',GetEnv('HOST'));
writeln('GetEnv PATH : ',GetEnv('PATH'));
writeln('GetEnv SHELL: ',GetEnv('SHELL'));
write('Press Enter for all Environment Strings using EnvStr()');
Readln;
for i:=1 to EnvCount do
writeln(EnvStr(i));
write('Press Enter');
Readln;
end;
procedure TestExec;
begin
writeln;
writeln('Exec Functions');
writeln('**************');
write('Press Enter for an Exec of ''hello -good -day''');
Readln;
SwapVectors;
{$ifdef noexesuffix}
Exec('hello','-good -day');
{$else}
Exec('hello.exe','-good -day');
{$endif}
SwapVectors;
writeln('Exit should be 213 : ',DosExitCode);
writeln('Error code should be 0 : ',DosError);
write('Press Enter');
Readln;
end;
procedure TestDisk;
var
Dir : SearchRec;
DT : DateTime;
begin
writeln;
writeln('Disk Functions');
writeln('**************');
writeln('DiskFree 0 : ',DiskFree(0));
writeln('DiskSize 0 : ',DiskSize(0));
writeln('DiskSize 1 : ',DiskSize(1)); { this is a: on dos ??! }
writeln('DiskSize 3 : ',DiskSize(3)); { this is c: on dos }
{$IFDEF Unix}
AddDisk('/fd0');
writeln('DiskSize 4 : ',DiskSize(4));
{$ENDIF}
write('Press Enter for FindFirst/FindNext Test');
Readln;
FindFirst('*.*',$20,Dir);
while (DosError=0) do
begin
UnpackTime(dir.Time,DT);
Writeln(dir.Name,' ',dir.Size,' ',DT.Year,'-',DT.Month,'-',DT.Day);
FindNext(Dir);
end;
write('Press Enter');
Readln;
end;
procedure TestFile;
var
test,
name,dir,ext : string;
begin
writeln;
writeln('File(name) Functions');
writeln('********************');
{$ifdef unix }
test:='/usr/local/bin/ppc.so';
writeln('FSplit(',test,')');
FSplit(test,dir,name,ext);
writeln('dir: ',dir,' name: ',name,' ext: ',ext);
test:='/usr/bin.1/ppc';
writeln('FSplit(',test,')');
FSplit(test,dir,name,ext);
writeln('dir: ',dir,' name: ',name,' ext: ',ext);
test:='mtools.tar.gz';
writeln('FSplit(',test,')');
FSplit(test,dir,name,ext);
writeln('dir: ',dir,' name: ',name,' ext: ',ext);
Writeln('Expanded dos.pp : ',FExpand('dos.pp'));
Writeln('Expanded ../dos.pp : ',FExpand('../dos.pp'));
Writeln('Expanded /usr/local/dos.pp : ',FExpand('/usr/local/dos.pp'));
Writeln('Expanded ../dos/./../././dos.pp : ',FExpand('../dos/./../././dos.pp'));
test:='../;/usr/;/usr/bin/;/usr/bin;/bin/;';
{$else not linux }
test:='\usr\local\bin\ppc.so';
writeln('FSplit(',test,')');
FSplit(test,dir,name,ext);
writeln('dir: ',dir,' name: ',name,' ext: ',ext);
test:='\usr\bin.1\ppc';
writeln('FSplit(',test,')');
FSplit(test,dir,name,ext);
writeln('dir: ',dir,' name: ',name,' ext: ',ext);
test:='mtools.tar.gz';
writeln('FSplit(',test,')');
FSplit(test,dir,name,ext);
writeln('dir: ',dir,' name: ',name,' ext: ',ext);
Writeln('Expanded dos.pp : ',FExpand('dos.pp'));
Writeln('Expanded ..\dos.pp : ',FExpand('..\dos.pp'));
Writeln('Expanded \usr\local\dos.pp : ',FExpand('\usr\local\dos.pp'));
Writeln('Expanded ..\dos\.\..\.\.\dos.pp : ',FExpand('..\dos\.\..\.\.\dos.pp'));
test:='..\;\usr\;\usr\bin\;\usr\bin;\bin\;';
{$endif not linux}
test:=test+getenv('PATH');
{$ifdef NOEXESUFFIX}
Writeln('FSearch ls: ',FSearch('ls',test));
{$else not noexesuffix}
Writeln('FSearch ls: ',FSearch('ls.exe',test));
{$endif not noexesuffix}
Writeln('Empty FSearch (should return empty string):',FSearch('',test));
write('Press Enter');
Readln;
end;
begin
TestInfo;
TestEnvironment;
TestExec;
TestDisk;
TestFile;
end.
{
$Log$
Revision 1.1 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
Revision 1.7 2002/10/20 11:47:39 carl
* add format date to make test clearer
Revision 1.6 2002/09/07 15:40:56 peter
* old logs removed and tabs fixed
Revision 1.5 2002/07/06 11:46:08 carl
+ fsearch testing added
Revision 1.4 2002/06/01 19:08:52 marco
* Renamefest
}

695
tests/test/units/dos/tidos2.pp Normal file
View File

@ -0,0 +1,695 @@
{ %INTERACTIVE }
{******************************************}
{ Used to check the DOS unit }
{------------------------------------------}
{ Requirements for this unit can be }
{ found in testdos.htm }
{******************************************}
Program TestDos;
Uses Dos;
{**********************************************************************}
{ Some specific OS verifications : }
{ Mainly for file attributes: }
{ Read-Only }
{ Hidden }
{ System File }
{ only work on Win32, OS/2 and 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}
{$IFNDEF UNIX}
{$IFDEF LINUX}
{$DEFINE UNIX}
{$ENDIF}
{$IFDEF QNX}
{$DEFINE UNIX}
{$ENDIF}
{$IFDEF SOLARIS}
{$DEFINE UNIX}
{$ENDIF}
{$IFDEF FREEBSD}
{$DEFINE UNIX}
{$ENDIF}
{$IFDEF BEOS}
{$DEFINE UNIX}
{$ENDIF}
{$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';
Procedure PauseScreen;
var
ch: char;
Begin
WriteLn('-- Press any key --');
ReadLn;
end;
{ 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 TestSystemDate;
var
Year,Month, DayOfWeek, Day: Word;
Year1,Month1, DayOfWeek1, Day1: Word;
s: string;
Begin
WriteLn('----------------------------------------------------------------------');
WriteLn(' GETDATE ');
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: Number of week should be consistent (0 = Sunday) ');
WriteLn(' Note: Year should contain full four digits. ');
WriteLn('----------------------------------------------------------------------');
CheckDosError(0);
Month:=0;
Day:=0;
DayOfWeek:=0;
Year:=0;
GetDate(Year,Month,Day,DayOfWeek);
CheckDosError(0);
Write('DD-MM-YYYY : ',Day,'-',Month,'-',Year);
WriteLn(' (',Week[DayOfWeek],')');
PauseScreen;
WriteLn('----------------------------------------------------------------------');
WriteLn(' SETDATE ');
WriteLn('----------------------------------------------------------------------');
{ normal call }
SetDate(Year,Month,Day);
CheckDosError(0);
{ setdate and settime is not supported on most platforms }
{$ifdef go32v2}
s:='Testing with invalid year....';
SetDate(98,Month,Day);
CheckDosError(0);
GetDate(Year1,Month1,Day1,DayOfWeek1);
CheckDosError(0);
if (Year1 <> Year) or (Month1 <> month) or (Day1 <> Day) then
Begin
WriteLn(s+'FAILURE.');
end
else
WriteLn(s+'Success.');
SetDate(Year,Month,255);
CheckDosError(0);
s:='Testing with invalid day.....';
GetDate(Year1,Month1,Day1,DayOfWeek1);
CheckDosError(0);
if (Year1 <> Year) or (Month1 <> month) or (Day1 <> Day) then
Begin
WriteLn(s+'FAILURE.');
end
else
WriteLn(s+'Success.');
SetDate(Year,13,Day);
CheckDosError(0);
s:='Testing with invalid month...';
GetDate(Year1,Month1,Day1,DayOfWeek1);
CheckDosError(0);
if (Year1 <> Year) or (Month1 <> month) or (Day1 <> Day) then
Begin
WriteLn(s+'FAILURE.');
end
else
WriteLn(s+'Success.');
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: Date should be 01-01-1998 ');
WriteLn('----------------------------------------------------------------------');
SetDate(1998,01,01);
CheckDosError(0);
GetDate(Year1,Month1,Day1,DayOfWeek1);
CheckDosError(0);
WriteLn('DD-MM-YYYY : ',Day1,'-',Month1,'-',Year1);
SetDate(Year,Month,Day);
CheckDosError(0);
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: Date should be restored to previous value ');
WriteLn('----------------------------------------------------------------------');
GetDate(Year1,Month1,Day1,DayOfWeek1);
CheckDosError(0);
WriteLn('DD-MM-YYYY : ',Day1,'-',Month1,'-',Year1);
PauseScreen;
{$endif}
end;
Procedure TestsystemTime;
Var
Hour, Minute, Second, Sec100: word;
Hour1, Minute1, Second1, Sec1001: word;
Begin
WriteLn('----------------------------------------------------------------------');
WriteLn(' GETTIME ');
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: Hours should be in military format (0..23), and MSec in 0..100 ');
WriteLn('----------------------------------------------------------------------');
CheckDosError(0);
Hour:=0;
Minute:=0;
Second:=0;
Sec100:=0;
GetTime(Hour,Minute,Second,Sec100);
CheckDosError(0);
WriteLn('HH:MIN:SEC (MS): ',Hour,':',Minute,':',Second,' (',Sec100,')');
WriteLn('----------------------------------------------------------------------');
WriteLn(' SETTIME ');
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: GetTime should return the same value as the previous test. ');
WriteLn('----------------------------------------------------------------------');
SetTime(36,Minute,Second,Sec100);
CheckDosError(0);
GetTime(Hour1,Minute1,Second1,Sec1001);
CheckDosError(0);
WriteLn('HH:MIN:SEC ',Hour1,':',Minute1,':',Second1);
{ actual settime is only supported under DOS }
{$ifdef go32v2}
SetTime(Hour,32000,Second,Sec100);
CheckDosError(0);
GetTime(Hour1,Minute1,Second1,Sec1001);
CheckDosError(0);
WriteLn('HH:MIN:SEC ',Hour1,':',Minute1,':',Second1);
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: GetTime should return 0:0:0 ');
WriteLn('----------------------------------------------------------------------');
SetTime(0,0,0,0);
CheckDosError(0);
GetTime(Hour1,Minute1,Second1,Sec1001);
CheckDosError(0);
WriteLn('HH:MIN:SEC ',Hour1,':',Minute1,':',Second1);
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: GetTime should return approximately the original time ');
WriteLn('----------------------------------------------------------------------');
SetTime(Hour,Minute,Second,Sec1001);
CheckDosError(0);
GetTime(Hour1,Minute1,Second1,Sec1001);
CheckDosError(0);
WriteLn('HH:MIN:SEC ',Hour1,':',Minute1,':',Second1);
{$endif}
end;
Procedure TestFTime;
var
s : string;
F: File;
Time: Longint;
DT: DateTime;
DT1 : Datetime; { saved values }
Begin
WriteLn('----------------------------------------------------------------------');
WriteLn(' GETFTIME / SETFTIME ');
WriteLn('----------------------------------------------------------------------');
CheckDosError(0);
{**********************************************************************}
{********************** TURBO PASCAL BUG ******************************}
{ The File is not Open and DosError is still zero! THIS SHOULD NOT BE }
{ SO IN FPC! }
{**********************************************************************}
{********************** TURBO PASCAL BUG ******************************}
Write('Opening an invalid file...');
Assign(f,'x');
GetFTime(f,Time);
CheckDosError(6);
Write('Trying to open ',TestFName,'...');
Assign(f,TestFName);
Reset(f,1);
GetFTime(f,Time);
CheckDosError(0);
UnpackTime(Time,Dt);
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: Hour should be in military format and year should be a 4 digit ');
WriteLn(' number. ');
WriteLn('----------------------------------------------------------------------');
WriteLn('DD-MM-YYYY : ',DT.Day,'-',DT.Month,'-',DT.Year);
WriteLn('HH:MIN:SEC ',DT.Hour,':',DT.Min,':',DT.Sec);
{ SETFTIME / GETFTIME No Range checking is performed so the tests are }
{ very limited. }
s:='Setting '+TestFName+' date/time to 01-28-1998:0:0:0...';
dt1.Year:=1998;
dt1.Month:=1;
dt1.Day:=28;
Dt1.Hour:=0;
Dt1.Min:=0;
Dt1.Sec:=0;
PackTime(DT1,Time);
CheckDosError(0);
SetFTime(f,Time);
CheckDosError(0);
GetFTime(f,Time);
CheckDosError(0);
{ Re-initialize the date time file }
FillChar(Dt1,sizeof(dt1),#0);
UnpackTime(Time,Dt1);
if (Dt1.Year <> 1998) or (Dt1.Month<>1) or (Dt1.Day<>28) or
(Dt1.Hour<>0) or (Dt1.Min <>0) or (Dt1.Sec<>0) then
Begin
WriteLn(s+'FAILURE.');
end
else
WriteLn(s+'Success.');
s:='Restoring old file time stamp...';
Move(Dt,Dt1,sizeof(Dt));
PackTime(DT1,Time);
CheckDosError(0);
SetFTime(f,Time);
CheckDosError(0);
GetFTime(f,Time);
CheckDosError(0);
{ Re-initialize the date time file }
FillChar(Dt1,sizeof(dt),#0);
UnpackTime(Time,Dt1);
if (Dt1.Year <> Dt.Year) or (Dt1.Month<>Dt.Month) or (Dt1.Day<>Dt.Day) or
(Dt1.Hour<>Dt.Hour) or (Dt1.Min <> Dt.Min) or (Dt1.Sec<>Dt.Sec) then
Begin
WriteLn(s+'FAILURE.');
end
else
WriteLn(s+'Success.');
Close(f);
end;
Procedure TestFind;
var
Search: SearchRec;
DT: Datetime;
Year, Month, Day, DayOfWeek: Word;
Failure : Boolean;
FoundDot, FoundDotDot: boolean;
FoundDir : boolean;
s : string;
Begin
WriteLn('----------------------------------------------------------------------');
WriteLn(' FINDFIRST/ FINDNEXT ');
WriteLn('----------------------------------------------------------------------');
WriteLn(' Note: The full path should NOT be displayed. ');
WriteLn('----------------------------------------------------------------------');
CheckDosError(0);
WriteLn('Trying to find an invalid file ('''') with Any Attribute...');
FindFirst('',AnyFile,Search);
CheckDosError(3);
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
WriteLn('Trying to find an invalid file ('''') with VolumeID attribute...');
FindFirst('',VolumeID,Search);
CheckDosError(3);
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
WriteLn('Trying to find an invalid file (''''zz.dat'''') with Any Attribute...');
FindFirst('zz.dat',AnyFile,Search);
CheckDosError(18);
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
WriteLn('Trying to find an invalid file (''''zz.dat'''') with VolumeID attribute...');
FindFirst('zz.dat',VolumeID,Search);
CheckDosError(18);
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
WriteLn('Trying to find an invalid file (''''zz.dat'''') with Directory attribute...');
FindFirst('zz.dat',Directory,Search);
CheckDosError(18);
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
s:='Looking for '+TestFName +' with Any Attribute...';
FindFirst('*.DAT',AnyFile,Search);
if Search.Name <> TestFName then
Begin
repeat
FindNext(Search);
until (DosError <> 0) OR (Search.Name = TestFName);
end;
if Search.Name <> TestFName then
{ At least testdos.dat should appear }
WriteLn(s+'FAILURE. ',TestFName,' should be found.')
else
WriteLn(s+'Success.');
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
{ In addition to normal files }
{ directory files should also be found }
s:='Looking for '+TestFName +' with Directory Attribute...';
FindFirst('*.DAT',Directory,Search);
if DosError<> 0 then
WriteLn(s+'FAILURE. ',TestFName,' should be found.')
else
WriteLn(s+'Success.');
if Search.Name <> TestFName then
Begin
repeat
FindNext(Search);
until (DosError <> 0) OR (Search.Name = TestFName);
end;
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
Write('Checking file stats of ',TestFName,'...');
UnpackTime(Search.Time,DT);
GetDate(Year, Month, Day, DayOfWeek);
if (Search.Size <> Sizeof(week)) OR (DT.Year <> Year) OR (DT.Month <> Month)
OR (DT.Day <> Day)
then
Begin
WriteLn('FAILURE. Size/Date is different.')
end
else
WriteLn('Success.');
Write('Looking for ',TestFName,'...');
FindFirst('*.D??',AnyFile,Search);
{ At least testdos.dat should appear }
if DosError <> 0 then
WriteLn('FAILURE. ',Testfname,' should be found.')
else
WriteLn('Success.');
if Search.Name <> TestFName then
Begin
repeat
FindNext(Search);
until (DosError <> 0) OR (Search.Name = TestFName);
end;
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
Write('Checking file stats of ',TestFName,'...');
UnpackTime(Search.Time,DT);
GetDate(Year, Month, Day, DayOfWeek);
if (Search.Size <> Sizeof(week)) OR (DT.Year <> Year) OR (DT.Month <> Month)
OR (DT.Day <> Day)
then
Begin
WriteLn('FAILURE. Size/Date is different.')
end
else
WriteLn('Success.');
{ Should show all possible files }
FoundDot := False;
FoundDotDot := False;
Failure := True;
FoundDir := False;
s:='Searching using * wildcard (normal files + directories)...';
FindFirst('*',Directory,Search);
WriteLn(#9'Resources found (full path should not be displayed):');
while DosError = 0 do
Begin
If Search.Name = TestDir then
Begin
If Search.Attr and Directory <> 0 then
FoundDir := TRUE;
end;
If Search.Name = '.' then
Begin
If Search.Attr and Directory <> 0 then
FoundDot := TRUE;
End;
if Search.Name = '..' then
Begin
If Search.Attr and Directory <> 0 then
FoundDotDot := TRUE;
End;
{ check for both . and .. special files }
If Search.Name = TestFName1 then
Failure := FALSE;
WriteLn(#9+Search.Name);
FindNext(Search);
end;
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
if not FoundDir then
WriteLn(s+'FAILURE. Did not find '+TestDir+' directory')
else
if not FoundDot then
WriteLn(s+'FAILURE. Did not find special ''''.'''' directory')
else
if not FoundDotDot then
WriteLn(s+'FAILURE. Did not find special ''''..'''' directory')
else
if Failure then
WriteLn(s+'FAILURE. Did not find special '+TestFName1+' directory')
else
WriteLn(s+'Success.');
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
s:='Searching using ??? wildcard (normal files + all special files)...';
FindFirst('???',AnyFile,Search);
FoundDot := False;
FoundDotDot := False;
WriteLn(#9'Resources found (full path should not be displayed):');
while DosError = 0 do
Begin
If Search.Name = '.' then
Begin
If Search.Attr and Directory <> 0 then
FoundDot := TRUE;
End;
if Search.Name = '..' then
Begin
If Search.Attr and Directory <> 0 then
FoundDotDot := TRUE;
End;
WriteLn(#9+Search.Name);
FindNext(Search);
end;
if not FoundDot then
WriteLn(s+'FAILURE. Did not find special ''''.'''' directory')
else
if not FoundDotDot then
WriteLn(s+'FAILURE. Did not find special ''''..'''' directory')
else
WriteLn(s+'Success.');
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
{ search for volume ID }
s:='Searching using * wildcard in ROOT (normal files + volume ID)...';
FindFirst(RootPath+'*',Directory+VolumeID,Search);
Failure := TRUE;
WriteLn(#9'Resources found (full path should not be displayed):');
while DosError = 0 do
Begin
If Search.Attr and VolumeID <> 0 then
Begin
Failure := FALSE;
WriteLn(#9'Volume ID: '+Search.Name);
End
else
WriteLn(#9+Search.Name);
FindNext(Search);
end;
If Failure then
WriteLn(s+'FAILURE. Did not find volume name')
else
WriteLn(s+'Success.');
{$IFDEF FPC}
FindClose(Search);
{$ENDIF}
end;
Procedure TestSplit;
var
P: PathStr;
D: DirStr;
N: NameStr;
E: ExtStr;
temp : string;
Begin
WriteLn('----------------------------------------------------------------------');
WriteLn(' FSPLIT ');
WriteLn('----------------------------------------------------------------------');
Write('Testing invalid filename...');
{ Initialize names ot invalid values! }
D:='Garbage';
N:='Garbage';
E:='GAR';
{ This is the path to be split }
P:='';
FSPlit(P,D,N,E);
IF (length(D) <> 0) OR (length(N) <>0) OR (length(E) <> 0) THEN
WriteLn('FAILURE. Same length as PATH (now length 0) should be returned.')
else
WriteLn('Success.');
Write('Testing paramstr(0)...');
{ Initialize names ot invalid values! }
D:='Garbage';
N:='Garbage';
E:='GAR';
{ This is the path to be split }
P:=paramstr(0);
FSPlit(P,D,N,E);
IF length(p) <> (length(d)+length(n)+length(e)) then
WriteLn('FAILURE. Same length as PATH should be returned.')
else
WriteLn('Success.');
temp:=d+n+e;
Write('Testing paramstr(0)...');
if temp <> p then
WriteLn('FAILURE. Concatenated string should be the same.')
else
WriteLn('Success.');
WriteLn('PARAMSTR(0) = ', ParamStr(0));
WriteLn('DRIVE + NAME + EXT = ',d+n+e);
{$ifdef go32v2}
Write('Testing invalid path (..)...');
P:='..';
FSPlit(P,D,N,E);
IF (length(D) <> 0) OR (length(N) <>0) OR (E <> P) THEN
WriteLn('FAILURE. Length of drive and name should be zero and Ext should return Path')
else
WriteLn('Success.');
{$endif}
Write('Testing invalid path (*)...');
P:='*';
FSPlit(P,D,N,E);
IF (length(D) <> 0) OR (length(e) <>0) OR (N <> P) THEN
WriteLn('FAILURE. Length of drive and name should be zero and Name should return Path')
else
WriteLn('Success.');
end;
var
F: File;
Attr : Word;
Begin
TestSystemDate;
TestSystemTime;
{ Now the file I/O functions }
{ Let us create a file that we will play with }
Assign(f,TestFName);
Rewrite(f,1);
BlockWrite(f,Week,sizeof(Week));
Close(f);
Assign(f,TestFName1);
Rewrite(f,1);
Close(F);
MkDir(TestDir);
TestFTime;
TestFind;
PauseScreen;
TestSplit;
RmDir(TestDir);
PauseScreen;
end.
{
$Log$
Revision 1.1 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
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
}

20
tests/test/units/dos/tverify.pp
View File

@ -11,6 +11,9 @@ uses dos;
{$DEFINE SUPPORTS_VERIFY}
{$ENDIF}
const
has_errors : boolean = false;
{ verifies that the DOSError variable is equal to }
{ the value requested. }
Procedure CheckDosError(err: Integer);
@ -36,7 +39,7 @@ Procedure CheckDosError(err: Integer);
if err <> x then
Begin
WriteLn('FAILURE. (Value should be ',err,' '+s+')');
Halt(1);
has_errors:=true;
end
else
WriteLn('Success.');
@ -61,7 +64,7 @@ Begin
else
Begin
WriteLn(s+'FAILURE.');
halt(1);
has_errors:=true;
end;
s:='Testing GetVerify...';
SetVerify(FALSE);
@ -76,7 +79,7 @@ Begin
else
Begin
WriteLn(s+'FAILURE.');
halt(1);
has_errors:=true;
end;
{$else}
if b then
@ -84,7 +87,7 @@ Begin
else
Begin
WriteLn(s+'FAILURE.');
halt(1);
has_errors:=true;
end;
{$endif}
end;
@ -92,11 +95,16 @@ end;
Begin
testverify;
if has_errors then
halt(1);
end.
{
$Log$
Revision 1.1 2002-11-08 21:01:18 carl
Revision 1.2 2002-11-18 09:49:49 pierre
* tried to make as many as possible tests non interactive
Revision 1.1 2002/11/08 21:01:18 carl
* separated some tests
* make tfexpand more portable
}
}