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.