freepascal.compiler/tests/test/tinoutres.pp

{ checks if the correct RTE's are generated for invalid io operations }

{$i-}

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;

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;
end.