std.testlib.1.1: testlib.pas
{ Copyright(c) SPb-IFMO CTD Developers, 2000 }
{ Copyright(c) Anton Sukhanov, 1996 }
{ $Id: testlib.pas,v 1.1 2001/11/08 15:37:55 sta Exp $ }
{ Evaluating programs support stuff }
{$ifdef VER70}
{$ERROR}
{$ELSE}
{$I-,O+,Q-,R-,S-}
{$endif}
(*
Program, using testlib running format:
CHECK
[ [-xml]],
If result file is specified it will contain results.
*)
(*
Modifications log:
dd.mm.yyyy modified by modification log
01.05.2003 Maxim Babenko Support for custom xml tags added
31.03.2003 Georgiy Korneev -xml switch added instead of -appes.
XML header for DOS-encoding added
27.10.2002 Andrew Stankevich Buffered input (speedup up to 2 times on big files)
BP7.0 compatibility removed
17.09.2000 Andrew Stankevich XML correct comments
01.08.2000 Andrew Stankevich Messages translated to English
APPES support added
FAIL name changed
07.02.1998 Roman Elizarov Correct EOF processing
12.02.1998 Roman Elizarov SeekEoln corrected
eoln added
nextLine added
nextChar is now function
*)
unit testlib;
interface
const
eofChar = #$1A;
eofRemap = ' ';
NumberBefore = [#10,#13,' ',#09];
NumberAfter = [#10,#13,' ',#09,eofChar];
lineAfter = [#10,#13,eofChar];
Blanks = [#10,#13,' ',#09];
eolnChar = [#10,#13,eofChar];
BUFFER_SIZE = 1048576;
type
CharSet = set of char;
TMode = (_Input, _Output, _Answer);
TResult = (_ok, _wa, _pe, _fail, _dirt);
{
_ok - accepted,
_wa - wrong answer,
_pe - output format mismatch,
_fail - when everything fucks up
_dirt - for inner using
}
InStream = object
f: file; { file }
name: string; { file name }
mode: TMode;
opened: boolean;
fpos: integer;
size: integer;
buffer: array [0..BUFFER_SIZE - 1] of char;
bpos: integer;
bsize: integer;
{ for internal usage }
procedure fillbuffer;
constructor init(fname: string; m: TMode);
function curchar: char; { returns cur }
procedure skipchar; { skips current char }
function nextchar: char; { moves to next char }
function readchar: char; { moves to next char }
procedure Reset;
function Eof: boolean;
function SeekEof: boolean;
function Eoln: boolean;
function SeekEoln: boolean;
procedure NextLine; { skips current line }
{ Skips chars from given set }
{ Does not generate errors }
procedure Skip(setof: CharSet);
{ Read word. Skip before all chars from `before`
and after all chars from `after`. }
function ReadWord(Before, After: CharSet): string;
{ reads integer }
{ _pe if error }
function ReadLongint: integer;
{ = readlongint }
function ReadInteger: integer;
{ reads real }
{ _pe if error }
function ReadReal: extended;
{ same as readword([], [#13 #10]) }
function ReadString: string;
{ for internal usage }
procedure Quit(res: TResult; msg: string);
procedure Close;
end;
procedure Quit(res: TResult; msg: string);
procedure AddTag(name : string; value : integer); overload;
procedure AddTag(name : string; value : string); overload;
var
inf, ouf, ans: InStream;
ResultName: string; { result file name }
XMLMode: boolean;
encoding: string;
implementation
uses
sysutils, windows;
const
LightGray = $07;
LightRed = $0c;
LightCyan = $0b;
LightGreen = $0a;
const
maxTags = 256;
type
TTag = record
name : string;
value : string;
end;
var
nTags : integer = 0;
tags : array[1..maxTags] of TTag;
procedure AddTag(name : string; value : string);
begin
if nTags >= maxTags then
Quit(_Fail, 'Tag table overflow');
inc (nTags);
tags[nTags].name := name;
tags[nTags].value := value;
end;
procedure AddTag(name : string; value : integer);
begin
AddTag(name, inttostr (value));
end;
procedure TextColor(x: word);
var
h: THandle;
begin
h := GetStdHandle(STD_OUTPUT_HANDLE);
SetConsoleTextAttribute(h, x);
end;
const
outcomes: array[TResult] of string = (
'accepted',
'wrong-answer',
'presentation-error',
'fail',
'fail'
);
procedure XMLSafeWrite(var t: text; s: string);
var
i: integer;
begin
for i := 1 to length(s) do
begin
case s[i] of
'&': write(t, '&');
'<': write(t, '<');
'>': write(t, '>');
'"': write(t, '"');
#0..#31: write(t, '.');
else
write(t, s[i]);
end; { case }
end;
end;
procedure Quit(res: TResult; msg: string);
var
resfile: text;
errorname: string;
i : integer;
procedure scr(color: word; msg: string);
begin
if resultname = '' then { if no result file }
begin
TextColor(color); write(msg); TextColor(LightGray);
end;
end;
begin
if (res = _ok) then
begin
if not ouf.seekeof then quit(_dirt, 'Extra information in the output file');
end;
case res of
_fail:
begin
beep(100, 300);
ErrorName := 'FAIL ';
Scr(LightRed, ErrorName);
end;
_dirt:
begin
ErrorName := 'wrong output format ';
Scr(LightCyan, ErrorName);
res := _pe;
end;
_pe:
begin
ErrorName := 'wrong output format ';
Scr(LightRed, ErrorName);
end;
_ok:
begin
ErrorName := 'ok ';
Scr(LightGreen, ErrorName);
end;
_wa:
begin
ErrorName := 'wrong answer ';
scr(LightRed, ErrorName);
end;
else
Quit(_fail, 'What is the code ??? ');
end;
if ResultName <> '' then
begin
assign(RESFILE, ResultName); { Create file with result of evaluation }
rewrite(ResFile);
if IOResult <> 0 then Quit(_fail, 'Can not write to Result file');
if XMLMode then
begin
write(ResFile, '');
write(ResFile, '');
xmlsafewrite(ResFile, msg);
for i := 1 to nTags do begin
write(ResFile, '<', tags[i].name, '>');
xmlsafewrite(ResFile, tags[i].value);
writeln(ResFile, '');
end;
writeln(ResFile, ' ');
end else begin
writeln(ResFile, '.Testlib Result Number = ', ord(res));
writeln(ResFile, '.Result name (optional) = ', ErrorName);
writeln(ResFile, '.Check Comments = ', msg);
end;
close(ResFile);
if IOResult <> 0 then Quit(_fail, 'Can not write to Result file');
end;
Scr(LightGray, msg);
writeln;
if Res = _fail then HALT(ord(res));
close(inf.f);
close(ouf.f);
close(ans.f);
TextColor(LightGray);
if (res = _ok) or (xmlmode) then
halt(0)
else
halt(ord(res));
end;
procedure InStream.fillbuffer;
var
left: integer;
begin
left := size - fpos;
bpos := 0;
if left = 0 then
begin
bsize := 1;
buffer[0] := eofchar;
end else begin
blockread(f, buffer, buffer_size, bsize);
fpos := fpos + bsize;
end;
end;
procedure InStream.Reset;
begin
if opened then
close;
fpos := 0;
system.reset(f, 1);
size := filesize(f);
if ioresult <> 0 then
begin
if mode = _output then
quit(_pe, 'File not found: "' + name + '"');
bsize := 1;
bpos := 0;
buffer[0] := eofchar;
end else begin
fillbuffer;
end;
opened := true;
end;
constructor InStream.init(fname: string; m: TMode);
begin
opened := false;
name := fname;
mode := m;
assign(f, fname);
reset;
end;
function InStream.Curchar: char;
begin
curchar := buffer[bpos];
end;
function InStream.NextChar: char;
begin
NextChar := buffer[bpos];
skipchar;
end;
function InStream.ReadChar: char;
begin
ReadChar := buffer[bpos];
skipchar;
end;
procedure InStream.skipchar;
begin
if buffer[bpos] <> EofChar then
begin
inc(bpos);
if bpos = bsize then
fillbuffer;
end;
end;
procedure InStream.Quit(res: TResult; msg: string);
begin
if mode = _Output then
testlib.quit(res, msg)
else
testlib.quit(_fail, msg + ' (' + name + ')');
end;
function InStream.ReadWord(Before, After: CharSet): string;
begin
while buffer[bpos] in Before do skipchar;
if (buffer[bpos] = EofChar) and not (buffer[bpos] in after) then
quit(_pe, 'Unexpected end of file');
result := '';
while not ((buffer[bpos] in After) or (buffer[bpos] = EofChar)) do
begin
result := result + nextchar;
end;
end;
function InStream.ReadInteger: integer;
var
help: string;
code: integer;
begin
while (buffer[bpos] in NumberBefore) do skipchar;
if (buffer[bpos] = EofChar) then
quit(_pe, 'Unexpected end of file - integer expected');
help := '';
while not (buffer[bpos] in NumberAfter) do
help := help + nextchar;
val(help, result, code);
if code <> 0 then Quit(_pe, 'Expected integer instead of "' + help + '"');
end;
function InStream.ReadLongint: integer;
var
help: string;
code: integer;
begin
while (buffer[bpos] in NumberBefore) do skipchar;
if (buffer[bpos] = EofChar) then
quit(_pe, 'Unexpected end of file - integer expected');
help := '';
while not (buffer[bpos] in NumberAfter) do
help := help + nextchar;
val(help, result, code);
if code <> 0 then Quit(_pe, 'Expected integer instead of "' + help + '"');
end;
function InStream.ReadReal: extended;
var
help: string;
code: integer;
begin
help := ReadWord (NumberBefore, NumberAfter);
val(help, result, code);
if code <> 0 then Quit(_pe, 'Expected real instead of "' + help + '"');
end;
procedure InStream.skip(setof: CharSet);
begin
while (buffer[bpos] in setof) and (buffer[bpos] <> eofchar) do skipchar;
end;
function InStream.eof: boolean;
begin
eof := buffer[bpos] = eofChar;
end;
function InStream.seekEof: boolean;
begin
while (buffer[bpos] in Blanks) do skipchar;
seekeof := buffer[bpos] = EofChar;
end;
function InStream.eoln: boolean;
begin
eoln:= buffer[bpos] in eolnChar;
end;
function InStream.SeekEoln: boolean;
begin
skip([' ', #9]);
seekEoln := eoln;
end;
procedure InStream.nextLine;
begin
while not (buffer[bpos] in eolnChar) do skipchar;
if buffer[bpos] = #13 then skipchar;
if buffer[bpos] = #10 then skipchar;
end;
function InStream.ReadString: string;
begin
readstring := ReadWord([], lineAfter);
nextLine;
end;
procedure InStream.close;
begin
if opened then system.close(f);
opened := false;
end;
initialization
if sizeof(integer) <> 4 then
quit(_fail, '"testlib" unit assumes "sizeof(integer) = 4"');
if (ParamCount < 3) or (ParamCount > 5) then
quit(_fail, 'Program must be run with the following arguments: ' +
' [ [<-xml>]]');
case ParamCount of
3:
begin
ResultName := '';
XMLMode := false;
end;
4:
begin
ResultName := ParamStr(4);
XMLMode := false;
end;
5: begin
if (uppercase(ParamStr(5)) <> '-APPES') and (uppercase(ParamStr(5)) <> '-XML') then
quit(_fail, 'Program must be run with the following arguments: ' +
' [ [<-xml>]]');
ResultName := ParamStr(4);
XMLMode := true;
end;
end; { case }
encoding := 'cp866';
inf.init(ParamStr(1), _Input);
ouf.init(ParamStr(2), _Output);
ans.init(ParamStr(3), _Answer);
end.