Power-Programmierung/CD1.mdf/pascal/library/dos/strings/textf/texttest.pas

Pascal/Delphi Source File | 1989-08-27 | 6.9 KB | 270 lines

PROGRAM RLtest;
  { Test program for the textf unit.
    Adapted from original RLINE program written by Don Strenczewilk.
    Modifications by Arthur Zatarain C'serve [73417,525]  09/24/89

    The AMZ modifications make use of objects.  The files previously
    named RLINE have been renamed TEXTF to avoid conflicts.  The test
    program is called TEXTTEST.


  Does a speed comparison between FReadLn and ReadLn,
       a file position/seek test,
       and types a file to the screen.

  Running TEXTTEST with "RLTEST.PAS" as the command line parameter should
  get you going.

  Test with different files and buffer sizes (CONST BS, below).
  }


USES DOS, CRT, textf;


  { Global constants and variables.}
CONST
  BS      = 2048;            { Disk Buffer size. }

VAR
  S       : STRING;          { general purpose string }
  i       : Word;
  TBuf    : ARRAY[1..BS] OF Char;
  RF      : RFrec;     { this is now an object }
  f       : Text;
  fname : string[32];


  { Timing routine.  Derived from Neil Rubenking's TIMER.PAS in LIB 4. }
TYPE
  OnOrOff = (On, Off);

VAR
  start, time : Real;

  PROCEDURE timer(O : OnOrOff);
  VAR
    hour, min, sec, hun : Word;
  BEGIN
    GetTime(hour, min, sec, hun);
    time := hour*3600+min*60+sec+hun/100;
    CASE O OF
      On : start := time;
      Off : BEGIN
              time := time-start;
              Write('Time: ', time:6:2, ' ');
            END;
    END;
  END;


PROCEDURE ShowIOerror(i : Integer);
    { Displays some of the common errors, and waits for a keypress. }
  VAR
    S       : STRING[80];
  BEGIN
    CASE i OF
      0 : S := '';           { it's not an error write nothing. }
      100 : S := 'Attempted to read past end of file.';
      101 : S := 'Disk write error.';
      102 : S := 'File not assigned.';
      103 : S := 'File not opened.';
      104 : S := 'File not open for input.';

      2 : S := 'File not found.';
      3 : S := 'Path not found.';
      4 : S := 'Too many files opened.';
      5 : S := 'File access denied.';
      6 : S := 'Invalid file handle.';
      -1 : S := 'End Of File.'; { special EOF number, unique to FRead and FReadln }
    ELSE BEGIN
           Str(i, S);
           S := 'IOerror '+S;
         END;
    END;
    Write('  ', S, '  [Press any key]');
    REPEAT UNTIL keypressed;
    IF readkey = #0 THEN ;
    writeln;
  END;

  (************************************************************************)


  PROCEDURE PrepForTimingTest(Fn : STRING);
    { Opens and read Fn, before doing the FReadLn/ReadLn timing tests.
    Otherwise, the order the two tests are performed produces different
    results ( probably because the disk heads start in different positions,
    and maybe second test benefits from using previously filled DOS buffers. }

  VAR
    i       : Integer;
    j       : LongInt;
  BEGIN
    with rf do begin
      WriteLn('Reading file to prepare for timing tests..');
      i := FOpen(Fn, BS, TBuf);
      IF i <> 0 THEN BEGIN
        ShowIOerror(i);
        Halt;
      END;
      WHILE (FReadLn(S) = 0) DO ;
      FClose;
    end;
  END;


  PROCEDURE ReadLnTest(Fn : STRING);
    { Time comparison between FReadLn and ReadLn }
  VAR
    NLines  : LongInt;
  BEGIN
    with rf do begin
      i := FOpen(Fn, BS, TBuf);
      IF i <> 0 THEN BEGIN
        ShowIOerror(i);
        Halt;
      END;

      Write('FReadLn timing test: Reading strings from ', Fn, '.. ');
      NLines := 0;
      timer(On);
      REPEAT
        i := FReadLn(S);
        IF i = 0
        THEN Inc(NLines);
      UNTIL i <> 0;
      timer(Off); WriteLn;
      Write(NLines, ' lines were read.'); ShowIOerror(i);
      FClose;
    end;
    WriteLn;

    {Test TP ReadLn}
    Assign(f, Fn);
    Reset(f);
    i := IoResult;
    IF i <> 0 THEN BEGIN
      ShowIOerror(i);
      Halt;
    END;
    Write('ReadLn timing test: Reading strings from ', Fn, '... ');
    SetTextBuf(f, TBuf);
    NLines := 0;
    timer(On);
    REPEAT
      ReadLn(f, S);
      i := IoResult;
      IF i = 0
      THEN Inc(NLines);
    UNTIL EOF(F) OR (i <> 0);
    timer(Off); WriteLn;
    WriteLn(NLines, ' lines were read.'); ShowIOerror(i);
    Close(f);
  END;


  PROCEDURE TypeFile(Fn : STRING);
    { TYPE a file to the screen.  A useless procedure except that it
    demonstrates using a buffer allocated on the heap to be used by RLINE. }
  VAR
    RF      : RFrec;         { Declare RFrec variable. }
    TBuf    : Pointer;
  BEGIN
    ClrScr;
    GetMem(TBuf, BS);        { First, allocate memory for the buffer. }
    rf.init;

    with rf do begin
      { Be certain to insert the ^ in TBuf^ when opening the file. }
      i := FOpen(Fn, BS, TBuf^); { try to open the file. }

      IF i <> 0 THEN BEGIN     { Was file successfully opened? }
        ShowIOerror(i);
        Halt(1);
      END;

      REPEAT
        i := FReadLn(S);   { Attempt to read the next line from the file. }

        IF keypressed AND (readkey = ^S) { if user pressed ^S, then pause }
        THEN IF readkey <> #0 THEN ; { the display by forcing a keypress. }

        IF i = 0
        THEN WriteLn(S);       { if no error, then display the line. }

      UNTIL i <> 0;
      ShowIOerror(i);
      FClose;              { Close the file. }
    END;
  end;

  PROCEDURE PositioningTest(Fn : STRING);
  VAR
    NLines, lno : LongInt;
    ch      : Char;
  BEGIN
    ClrScr;
    WriteLn('     Pos    Line     Pos    Line     Pos    Line     Pos    Line     Pos    Line');
    with rf do begin
      i := FOpen(Fn, BS, TBuf);   { Open Fn }
      IF i <> 0 THEN BEGIN
        ShowIOerror(i);
        Halt(1);
      END;

      window(1, 2, 80, 25);
      NLines := 0;
      Write(FFilepos:8, NLines:8);
      REPEAT
        i := FReadLn(S);
        IF i = 0 THEN BEGIN
          Inc(NLines);
          Write(FFilepos:8, NLines:8);
        END;
      UNTIL i <> 0;

      WriteLn(^j^j^j^j);
      window(1, 21, 80, 25);

      REPEAT
        Write('Enter file Position to Seek (-1 to quit): '); ReadLn(lno);
        if lno < 0 then halt;
        i := fseek(lno);
        IF i <> 0 THEN ShowIOerror(i)
        ELSE BEGIN
          i := FRead(ch);
          IF i <> 0 THEN ShowIOerror(i);
          WriteLn('Char is: #', Ord(ch));
          i := fseek(lno);
          IF i <> 0 THEN ShowIOerror(i);
          i := FReadLn(S);
          IF i <> 0 THEN ShowIOerror(i);
          WriteLn(S);
        END;
      UNTIL lno = 10000;
      FClose;
    end;
    window(1, 1, 80, 25);
  END;


BEGIN
  clrscr;  writeln('Text file prcessor as object test program');
  write('Enter file name ');  readln(fname);

  rf.init;

  WriteLn;

  PrepForTimingTest(fname);

  ReadLnTest(fname);

  IF ParamCount > 1
  THEN PositioningTest(ParamStr(2))
  ELSE PositioningTest(fname);


END.