mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 14:20:05 +02:00
+ moved from /test/ and renamed
+ added directory service testing + added filesize/filepos testing.
This commit is contained in:
carl
parent
e51a3f73a9
commit
ed24a184b2
394
tests/test/units/system/tiorte.pp
Normal file
394
tests/test/units/system/tiorte.pp
Normal file
@ -0,0 +1,394 @@
|
||||
|
||||
{ checks if the correct RTE's are generated for invalid io operations }
|
||||
|
||||
{$i-}
|
||||
|
||||
const
|
||||
TMP_DIRECTORY = 'temp2';
|
||||
|
||||
procedure test(value, required: longint);
|
||||
begin
|
||||
if value <> required then
|
||||
begin
|
||||
writeln('Got ',value,' instead of ',required);
|
||||
halt(1);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure test_read_text;
|
||||
var
|
||||
f: text;
|
||||
s: string;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
write('Reading from not opened text file...');
|
||||
read(f,s);
|
||||
test(ioresult,103);
|
||||
readln(f);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
|
||||
write('Seekeoln from not opened text file...');
|
||||
seekeoln(f);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
|
||||
write('Seekeof from not opened text file...');
|
||||
seekeof(f);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
|
||||
assign(f,'inoutrte.$$$');
|
||||
rewrite(f);
|
||||
test(ioresult,0);
|
||||
|
||||
write('Reading from write-only (rewritten) text file...');
|
||||
read(f,s);
|
||||
test(ioresult,104);
|
||||
readln(f);
|
||||
test(ioresult,104);
|
||||
writeln(' Passed!');
|
||||
|
||||
write('Seekeoln from write-only (rewritten) text file...');
|
||||
seekeoln(f);
|
||||
test(ioresult,104);
|
||||
writeln(' Passed!');
|
||||
|
||||
write('Seekeof from write-only (rewritten) text file...');
|
||||
seekeof(f);
|
||||
test(ioresult,104);
|
||||
writeln(' Passed!');
|
||||
|
||||
close(f);
|
||||
test(ioresult,0);
|
||||
append(f);
|
||||
test(ioresult,0);
|
||||
|
||||
write('Reading from write-only (appended) text file...');
|
||||
read(f,s);
|
||||
test(ioresult,104);
|
||||
readln(f);
|
||||
test(ioresult,104);
|
||||
writeln(' Passed!');
|
||||
|
||||
write('Seekeoln from write-only (appended) text file...');
|
||||
seekeoln(f);
|
||||
test(ioresult,104);
|
||||
writeln(' Passed!');
|
||||
|
||||
write('Seekeof from write-only (appended) text file...');
|
||||
seekeof(f);
|
||||
test(ioresult,104);
|
||||
writeln(' Passed!');
|
||||
|
||||
close(f);
|
||||
test(ioresult,0);
|
||||
erase(f);
|
||||
test(ioresult,0);
|
||||
end;
|
||||
|
||||
procedure test_read_typed;
|
||||
var
|
||||
f: file of byte;
|
||||
s: byte;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
|
||||
write('Reading from not opened typed file...');
|
||||
read(f,s);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
|
||||
{ with filemode 2, the file is read-write }
|
||||
filemode := 1;
|
||||
assign(f,'inoutrte.$$$');
|
||||
rewrite(f);
|
||||
test(ioresult, 0);
|
||||
write(f,s);
|
||||
test(ioresult, 0);
|
||||
close(f);
|
||||
test(ioresult, 0);
|
||||
reset(f);
|
||||
test(ioresult, 0);
|
||||
write('Reading from write-only typed file...');
|
||||
read(f,s);
|
||||
test(ioresult,104);
|
||||
writeln(' Passed!');
|
||||
|
||||
filemode := 2;
|
||||
close(f);
|
||||
test(ioresult, 0);
|
||||
erase(f);
|
||||
test(ioresult, 0);
|
||||
end;
|
||||
|
||||
procedure test_read_untyped;
|
||||
var
|
||||
f: file;
|
||||
r: longint;
|
||||
s: byte;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
|
||||
write('Reading from not opened untyped file...');
|
||||
blockread(f,s,1,r);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
|
||||
{ with filemode 2, the file is read-write }
|
||||
filemode := 1;
|
||||
assign(f,'inoutrte.$$$');
|
||||
rewrite(f);
|
||||
test(ioresult, 0);
|
||||
blockwrite(f,s,1);
|
||||
test(ioresult, 0);
|
||||
close(f);
|
||||
test(ioresult, 0);
|
||||
reset(f);
|
||||
test(ioresult, 0);
|
||||
write('Reading from write-only utyped file...');
|
||||
blockread(f,s,1,r);
|
||||
test(ioresult,104);
|
||||
writeln(' Passed!');
|
||||
|
||||
filemode := 2;
|
||||
close(f);
|
||||
test(ioresult, 0);
|
||||
erase(f);
|
||||
test(ioresult, 0);
|
||||
end;
|
||||
|
||||
|
||||
procedure test_write_text;
|
||||
var f: text;
|
||||
s: string;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
|
||||
write('Writing to not opened text file...');
|
||||
write(f,s);
|
||||
test(ioresult,103);
|
||||
writeln(f);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
|
||||
assign(f,'inoutrte.$$$');
|
||||
rewrite(f);
|
||||
close(f);
|
||||
test(ioresult,0);
|
||||
reset(f);
|
||||
test(ioresult,0);
|
||||
|
||||
write('Writing to read-only text file...');
|
||||
write(f,s);
|
||||
test(ioresult,105);
|
||||
writeln(f);
|
||||
test(ioresult,105);
|
||||
Writeln(' Passed!');
|
||||
|
||||
close(f);
|
||||
test(ioresult,0);
|
||||
erase(f);
|
||||
test(ioresult,0);
|
||||
end;
|
||||
|
||||
procedure test_write_typed;
|
||||
var f: file of byte;
|
||||
s: byte;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
|
||||
write('Writing to not opened typed file...');
|
||||
write(f,s);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
|
||||
assign(f,'inoutrte.$$$');
|
||||
rewrite(f);
|
||||
close(f);
|
||||
test(ioresult,0);
|
||||
filemode := 0;
|
||||
reset(f);
|
||||
test(ioresult,0);
|
||||
|
||||
write('Writing to read-only typed file...');
|
||||
write(f,s);
|
||||
test(ioresult,105);
|
||||
Writeln(' Passed!');
|
||||
|
||||
filemode := 2;
|
||||
close(f);
|
||||
test(ioresult,0);
|
||||
erase(f);
|
||||
test(ioresult,0);
|
||||
end;
|
||||
|
||||
procedure test_write_untyped;
|
||||
var f: file;
|
||||
r: longint;
|
||||
s: byte;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
|
||||
write('Writing to not opened untyped file...');
|
||||
blockwrite(f,s,1,r);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
|
||||
assign(f,'inoutrte.$$$');
|
||||
rewrite(f);
|
||||
close(f);
|
||||
test(ioresult,0);
|
||||
filemode := 0;
|
||||
reset(f);
|
||||
test(ioresult,0);
|
||||
|
||||
write('Writing to read-only untyped file...');
|
||||
blockwrite(f,s,1,r);
|
||||
test(ioresult,105);
|
||||
Writeln(' Passed!');
|
||||
|
||||
filemode := 2;
|
||||
close(f);
|
||||
test(ioresult,0);
|
||||
erase(f);
|
||||
test(ioresult,0);
|
||||
end;
|
||||
|
||||
|
||||
procedure test_close_text;
|
||||
var f: text;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
|
||||
write('Testing closing of not opened text file...');
|
||||
close(f);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
end;
|
||||
|
||||
procedure test_close_typed;
|
||||
var f: file of byte;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
|
||||
write('Testing closing of not opened typed file...');
|
||||
close(f);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
end;
|
||||
|
||||
procedure test_close_untyped;
|
||||
var f: file;
|
||||
begin
|
||||
{ to avoid influence of previous runs/procedures }
|
||||
fillchar(f,sizeof(f),0);
|
||||
|
||||
write('Testing closing of not opened untyped file...');
|
||||
close(f);
|
||||
test(ioresult,103);
|
||||
writeln(' Passed!');
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure test_fileroutines;
|
||||
var
|
||||
F: File;
|
||||
L: longint;
|
||||
begin
|
||||
{ get the file position of a non-existent file }
|
||||
write('Testing Filepos on non initialized file...');
|
||||
l:=FilePos(F);
|
||||
test(IOresult,103);
|
||||
writeln(' Passed!');
|
||||
write('Testing Filesize on non initialized file...');
|
||||
l:=FileSize(F);
|
||||
test(IOresult,103);
|
||||
writeln(' Passed!');
|
||||
end;
|
||||
|
||||
procedure test_directory;
|
||||
var
|
||||
F: File;
|
||||
{ test directory I/O }
|
||||
begin
|
||||
{ test on non-existant directory }
|
||||
write('Testing change directory on non-existent file...');
|
||||
ChDir('notexist');
|
||||
test(IOResult,3);
|
||||
{ test on a file }
|
||||
ChDir('testdir.pas');
|
||||
test(IOResult,3);
|
||||
Writeln(' Passed!');
|
||||
{ test on non-existant directory }
|
||||
{$ifdef go32v2}
|
||||
ChDir('Y:\test.dir');
|
||||
test(IOResult,15);
|
||||
{$endif}
|
||||
(*
|
||||
{ make a stub directory for testing purposes }
|
||||
Mkdir(TMP_DIRECTORY);
|
||||
test(IOResult,0);
|
||||
{ try to recreate the directory .... }
|
||||
write('Testing make directory on already existent dir...');
|
||||
MkDir(TMP_DIRECTORY);
|
||||
test(IOResult,5);
|
||||
Writeln(' Passed!');
|
||||
|
||||
{ try to erase the directory, using file access }
|
||||
write('Testing erase of directory...');
|
||||
Assign(F,TMP_DIRECTORY);
|
||||
Erase(F);
|
||||
test(IOResult,2);
|
||||
Writeln(' Passed!');
|
||||
{ now really remove the directory }
|
||||
RmDir(TMP_DIRECTORY);
|
||||
test(IOResult,0);
|
||||
*)
|
||||
{ remove non-existant directory }
|
||||
write('Testing remove directory of non-existent file...');
|
||||
RmDir('testdir.exe');
|
||||
{ TP here returns 5 , not 2 }
|
||||
test(IOResult,2);
|
||||
Writeln(' Passed!');
|
||||
{ erase non-existant file }
|
||||
write('Testing erase of non-existent file...');
|
||||
Assign(F,'notexist.txt');
|
||||
Erase(F);
|
||||
test(IOResult,2);
|
||||
WriteLn(' Passed!');
|
||||
end;
|
||||
|
||||
|
||||
begin
|
||||
test_read_text;
|
||||
test_read_typed;
|
||||
test_read_untyped;
|
||||
test_write_text;
|
||||
test_write_typed;
|
||||
test_write_untyped;
|
||||
test_close_text;
|
||||
test_close_typed;
|
||||
test_close_untyped;
|
||||
test_directory;
|
||||
test_fileroutines;
|
||||
end.
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2001-05-09 21:12:36 carl
|
||||
+ moved from /test/ and renamed
|
||||
+ added directory service testing
|
||||
+ added filesize/filepos testing.
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user