std.testlib.pas.1.9: testlib.pas
{ Copyright(c) SPb-IFMO CTD Developers, 2000 }
{ Copyright(c) Anton Sukhanov, 1996 }
{ $Id: testlib.pas,v 1.9 2004/06/30 08:55:35 jury Exp $ }
{ Evaluating programs support stuff }
{$ifdef VER70}
{$A-,B-,D+,E+,F+,G+,I-,L+,N+,O-,P+,Q-,R+,S+,T-,V+,X+,Y+}
{$M 65520, 0, 0}
{$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
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];
type REAL = EXTENDED; {!!!!!!!!}
type CharSet = set of char;
TMode = (_Input, _Output, _Answer);
TResult = (_OK, _WA, _PE, _Fail, _PC, _Dirt);
{_OK - accepted, _WA - wrong answer, _PE - output format mismatch,
_Fail - when everything fucks up }
{ _Dirt - for inner using}
InStream = object
cur: char; { current char, =EofChar, if eof }
f: TEXT; { file }
name: string; { file name }
mode: TMode;
opened: boolean;
{ for internal usage }
constructor init (fname: string; m: TMode);
function CurChar: char; { returns cur }
function nextChar: char; { moves to next char }
function seekeof: boolean;
function eof : boolean; { == cur = EofChar }
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`. If eof or word is
empty or it contains more than 255 chars, generates _pe }
function ReadWord (Before, After: CharSet): string;
{ reads integer }
{ _pe if error }
{ USE readlongint! }
function ReadInteger: integer;
{ reads longint }
{ _pe if error }
function ReadLongint: longint;
{ reads int64 }
{ _pe if error }
function ReadInt64: int64;
{ reads real }
{ _pe if error }
function ReadReal: real;
procedure Reset;
{ 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); overload;
procedure QuitWithPC(msg : string; pctype : integer);
procedure SetCustomAttribute(name : string; value : string); overload;
procedure SetCustomAttribute(name : string; value : integer); overload;
procedure SetCustomAttribute(name : string; value : real); overload;
var inf, ouf, ans: InStream;
ResultName: string; { result file name }
AppesMode: boolean;
(* ================================================================= *)
implementation
(* ================================================================= *)
{$ifdef VER70}
uses crt;
{$else}
uses windows, sysutils;
{$endif}
{$ifndef VER70}
const
LightGray = $07;
LightRed = $0c;
LightCyan = $0b;
LightGreen = $0a;
Yellow = $0e;
MAX_CUSTOM_ATTR = 256;
type
TCustomAttr = record
name, value : string;
end;
var
nCustomAttr : integer = 0;
customAttr : array[1..MAX_CUSTOM_ATTR] of TCustomAttr;
procedure SetCustomAttribute(name : string; value : string); overload;
var
i : integer;
begin
for i := 1 to nCustomAttr do
if customAttr[i].name = name then begin
customAttr[i].value := value;
exit;
end;
inc(nCustomAttr);
assert(nCustomAttr <= MAX_CUSTOM_ATTR);
customAttr[nCustomAttr].name := name;
customAttr[nCustomAttr].value := value;
end;
procedure SetCustomAttribute(name : string; value : integer); overload;
begin
SetCustomAttribute(name, inttostr(value));
end;
procedure SetCustomAttribute(name : string; value : real); overload;
begin
SetCustomAttribute(name, floattostr(value));
end;
procedure textcolor(x: word);
var
h: thandle;
begin
h := getstdhandle(std_output_handle);
setconsoletextattribute(h, x);
end;
{$endif}
{$ifdef ver70}
procedure beep(freq, duration: integer);
begin
sound(freq);
delay(duration);
nosound;
end;
{$endif}
const outcomes: array[0..8] of string = (
'accepted',
'wrong-answer',
'presentation-error',
'fail',
'partially-correct',
'run-time-error',
'time-limit-exceeded',
'compilation-error',
'security-violation' );
procedure safewrite(var t: text; s: string);
var
i: longint;
begin
for i := 1 to length(s) do
begin
case s[i] of
'&': write(t, '&');
'<': write(t, '<');
'"': write(t, '"');
else
if s[i] < ' ' then
write(t, '?')
else
write(t, s[i]);
end; { case }
end;
end;
procedure quit (res: TResult; msg: string; pctype : integer); overload; forward;
procedure quit (res: TResult; msg: string); overload;
begin
assert(res <> _PC);
quit(res, msg, 0);
end;
procedure quitwithpc(msg : string; pctype : integer);
begin
quit(_PC, msg, pctype);
end;
procedure quit (res: TResult; msg: string; pctype : integer);
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
ouf.skip (Blanks);
if not ouf.eof then QUIT (_Dirt, 'Extra information in Output');
end;
case res of
_Fail: begin
ErrorName := 'FAIL ';
Scr (LightRed, ErrorName);
end;
_Dirt: begin
ErrorName := 'wrong output format ';
Scr (LightCyan, ErrorName);
res := _PE;
msg := 'Extra information in output file';
end;
_PE: begin
ErrorName := 'wrong output format ';
Scr (LightRed, ErrorName);
end;
_OK: begin
ErrorName := 'ok ';
Scr (LightGreen, ErrorName);
end;
_PC: begin
ErrorName := 'pc' + inttostr(pctype) + ' ';
Scr (Yellow, ErrorName);
end;
_WA: begin
ErrorName := 'wrong answer ';
TextColor (LightRed); 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 AppesMode then
begin
writeln(ResFile, '');
writeln(ResFile, '');
SafeWrite(ResFile, msg);
writeln(ResFile, '');
end
else
begin
writeln(resfile, 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));
{$i-}close (inf.f); close (ouf.f); close (ans.f);{$i+}
if ioresult<>0 then;
TextColor (LightGray);
if (res = _OK) or (appesmode) then HALT (0)
else HALT (ord (res));
end;
constructor Instream.init (fname: string; m: TMode);
begin
name := fname;
mode := m;
assign (f, fname);
{$I-} system.reset (f);
if IORESULT <> 0 then
begin
if mode = _Output then QUIT (_PE, 'File not found ' + fname);
cur := EofChar;
end
else
if system.eof (f) then cur := EofChar
else begin cur := ' '; nextchar end;
opened := true;
end;
function InStream.curchar: char;
begin
curchar := cur
end;
function InStream.nextChar: char;
begin
nextChar:= curChar;
if cur = EofChar then { do nothing }
else if system.eof (f) then cur := EofChar
else begin
{$I-} read (f, cur);
if IORESULT <> 0 then Quit (_Fail, 'Read error' + name);
if cur = eofChar then cur:= eofRemap;
end;
end;
procedure InStream.QUIT (res: TResult; msg: string);
begin
if mode = _Output then TESTLIB.QUIT (res, msg)
{ if can't read input or answer - fail }
else TESTLIB.QUIT (_Fail, msg + ' (' + name + ')');
end;
function InStream.ReadWord (Before, After: CharSet): string;
var
{$ifdef ver70}
i: integer;
{$endif}
res: string;
begin
while cur in Before do nextchar;
if (cur = EofChar) and not (cur in after) then
QUIT (_PE, 'Unexpected end-of-file');
{$ifdef ver70}
i := 0;
{$endif}
res := '';
while not ((cur IN AFTER) or (cur = EofChar)) do
begin
{$ifdef ver70}
inc (i);
if i > 255 then QUIT (_PE, 'Line too long');
{$endif}
res := res + cur;
nextchar;
end;
ReadWord := res;
end;
function InStream.ReadInteger: integer;
var help: string;
res: longint;
code: integer;
begin
help := ReadWord (NumberBefore, NumberAfter);
val (help, res, code);
if code <> 0 then QUIT (_PE, 'Expected integer instead of "' + help + '"');
if (res < -32768) or (res > 32767) then
QUIT (_PE, 'ReadInteger can not return LONGINT Value, DO NOT USE READINTEGER!!!');
ReadInteger := res
end;
function InStream.ReadReal: real;
var help: string;
res: real;
code: integer;
begin
help := ReadWord (NumberBefore, NumberAfter);
val (help, res, code);
if code <> 0 then QUIT (_PE, 'Expected real instead of "' + help + '"');
ReadReal := res
end;
function InStream.ReadLongint: longint;
var help: string;
res: longint;
code: integer;
begin
help := ReadWord (NumberBefore, NumberAfter);
val (help, res, code);
if code <> 0 then QUIT (_PE, 'Expected longint instead of "' + help + '"');
ReadLongint := res
end;
function InStream.ReadInt64: int64;
var help: string;
res: int64;
code: integer;
begin
help := ReadWord (NumberBefore, NumberAfter);
val (help, res, code);
if code <> 0 then QUIT (_PE, 'Expected int64 instead of "' + help + '"');
ReadInt64 := res
end;
procedure InStream.skip (setof: CharSet);
begin
while (cur in setof) and (cur <> eofchar) do nextchar;
end;
function InStream.eof: boolean;
begin
eof := cur = eofChar;
end;
function InStream.seekEof: boolean;
begin
while (cur in Blanks) do nextchar;
seekeof := cur = EofChar;
end;
function InStream.eoln: boolean;
begin
eoln:= cur in eolnChar;
end;
function InStream.seekEoln: boolean;
begin
skip ( [' ', #9] );
seekEoln:= eoln;
end;
procedure InStream.nextLine;
begin
while not (cur in eolnChar) do nextchar;
if cur = #13 then nextchar;
if cur = #10 then nextchar;
end;
function InStream.ReadString: string;
begin
readstring:= ReadWord ([], lineAfter);
nextLine;
end;
procedure InStream.Reset;
begin
{$I-} system.reset (f);
if IORESULT <> 0 then
begin
cur := EofChar; { allow for other files }
end
else
if system.eof (f) then cur := EofChar
else begin cur := ' '; nextchar end;
opened := true;
end;
procedure InStream.close;
begin
if opened then system.close(f);
opened := false;
end;
function upper(s: string): string;
var
i: longint;
begin
for i := 1 to length(s) do
s[i] := upcase(s[i]);
upper := s;
end;
BEGIN { a.k.a. initialization }
if (ParamCount < 3) or (ParamCount > 5) then
quit(_fail, 'Program must be run with the following arguments: ' +
' [ [-xml]]');
case ParamCount of
3: begin
ResultName := '';
AppesMode := false;
end;
4: begin
ResultName := ParamStr(4);
AppesMode := false;
end;
5: begin
if (upper(ParamStr(5)) <> '-XML') and (upper(paramstr(5)) <> '-APPES') then
quit(_fail, 'Program must be run with the following arguments: ' +
' [ [-xml]]');
ResultName := ParamStr(4);
AppesMode := true;
end;
end; { case }
inf.opened := false;
ouf.opened := false;
ans.opened := false;
inf.init (ParamStr (1), _Input);
ouf.init (ParamStr (2), _Output);
ans.init (ParamStr (3), _Answer);
END.