{ 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.