The World of Computer Software/World_Of_Computer_Software-02-385-Vol-1of3.iso/t/tcsel003.zip/READTEXT.PAS

Pascal/Delphi Source File | 1992-10-16 | 7KB | 273 lines

{$A+,B-,D-,E+,F-,I+,L-,N-,O-,R+,S-,V-}
{$M 4048,65536,655360}

program Readtext;

{ Author Trevor J Carlsen - released into the public domain 1991         }
{        PO Box 568                                                      }
{        Port Hedland                                                    }
{        Western Australia 6721                                          }
{        Voice [phone]  Data [phone]                       }
{        FidoNet 3:690/644                                               }

{ This example programs displays a text file using simple word wrap. The }
{ cursor keys are used to page forward or backwards by page or by line.  }
{ The program makes some important assumptions.  The main one is that no }
{ line in the file will ever exceed 255 characters in length.  To get    }
{ around this restriction the ReadTxtLine function would need to be      }
{ rewritten.                                                             }

{ The other major restriction is that files exceeding a size able to be  }
{ totally placed in RAM cannot be viewed.                                }

{$DEFINE TurboPower (Remove the period if you have Turbo Power's TPro)  }

uses
  {$IFDEF TurboPower }
  tpcrt,
  colordef;
  {$ELSE}
  crt;
  {$ENDIF}

const
  {$IFNDEF TurboPower }
  BlackOnLtGray = $70;      LtGrayOnBlue = $17;
  {$ENDIF}
  LineLength    = 79;       MaxLines     = 6000;
  ScreenLines   = 22;       escape       = $011b;
  Home          = $4700;    _end         = $4f00;
  upArrow       = $4800;    downArrow    = $5000;
  PageUp        = $4900;    PageDown     = $5100;

type
  LineStr    = string[Linelength];
  StrPtr     = ^LineStr;

var
  TxtFile    : text;
  Lines      : array[1..MaxLines] of StrPtr;
  NumberLines: 1..MaxLines+1;
  CurrentLine: 1..MaxLines+1-ScreenLines;
  st         : string;
  finished   : boolean;
  OldExitProc: pointer;
  TxtBuffer  : array[0..16383] of byte;
  OldAttr    : byte;

function LastPos(ch : char; S : string): byte;
  { Returns the last position of ch in S or zero if ch not in S }
  var
    x   : word;
    len : byte absolute S;
  begin
    x := succ(len);
    repeat
      dec(x);
    until (x = 0) or (S[x] = ch);
    LastPos := x;
  end;  { LastPos }

function Wrap(var S,CarryOver: string): string;
  { Returns a string of maximum length Linelength from S. Any additional }
  { characters remaining are placed into CarryOver.                      }
  const
    space = #32;
  var
    temp      : string;
    LastSpace : byte;
    len       : byte absolute S;
  begin
    FillChar(temp,sizeof(temp),32);
    temp := S; CarryOver := ''; wrap := temp;
    if length(temp) > LineLength then begin
      LastSpace := LastPos(space,copy(temp,1,LineLength+1));
      if LastSpace <> 0 then begin
        Wrap[0]   := chr(LastSpace - 1);
        CarryOver := copy(temp,LastSpace + 1, 255)
      end  { if LastSpace... }
      else begin
        Wrap[0]   := chr(len);
        CarryOver := copy(temp,len,255);
      end; { else }
    end; { if (length(S))...}
  end;  { Wrap }

function ReadTxtLine(var f: text; L: byte): string;
  var
    temp : string;
    len  : byte absolute temp;
    done : boolean;
  begin
    len := 0; done := false;
    {$I-}
    while not eoln(f) do begin
      read(f,temp);
      if IOResult <> 0 then begin
        writeln('Error reading file - aborted');
        halt;
      end;
    end; { while }
    if eoln(f) then readln(f);
    ReadTxtLine := st + Wrap(temp,st);
    finished := eof(f);
  end;  { ReadTxtLine }

procedure ReadTxtFile(var f: text);
  var
    x : word;
  begin
    st          := '';
    NumberLines := 1;
    repeat
      if NumberLines > MaxLines then begin
        writeln('File too big');
        halt;
      end;
      if (MaxAvail >= Sizeof(LineStr)) then
        new(Lines[NumberLines])
      else begin
        writeln('Insufficient memory');
        halt;
      end;
      FillChar(Lines[NumberLines]^,LineLength+1,32);
      if length(st) > LineLength then
        Lines[NumberLines]^  := wrap(st,st)
      else if length(st) <> 0 then begin
        Lines[NumberLines]^  := st;
        st := '';
      end else
        Lines[NumberLines]^  := ReadTxtLine(f,LineLength+1);
      Lines[NumberLines]^[0] := chr(LineLength);
      if not finished then
        inc(NumberLines);
    until finished;
  end;  { ReadTxtFile }

procedure DisplayScreen(line: word);
  var
    x : byte;
  begin
    GotoXY(1,1);
    for x := 1 to ScreenLines - 1 do
      writeln(Lines[x-1+line]^);
    write(Lines[x+line]^)
  end;

procedure PreviousPage;
  begin
    if CurrentLine > ScreenLines then
      dec(CurrentLine,ScreenLines-1)
    else
      CurrentLine := 1;
  end;  { PreviousPage }

procedure NextPage;
  begin
    if CurrentLine < (succ(NumberLines) - ScreenLines * 2) then
      inc(CurrentLine,ScreenLines-1)
    else
      CurrentLine := succ(NumberLines) - ScreenLines;
  end;   { NextPage }

procedure PreviousLine;
  begin
    if CurrentLine > 1 then
      dec(CurrentLine)
    else
      CurrentLine := 1;
  end;  { PreviousLine }

procedure NextLine;
  begin
    if CurrentLine < (succ(NumberLines) - ScreenLines) then
      inc(CurrentLine)
    else
      CurrentLine := succ(NumberLines) - ScreenLines;
  end; { NextLine }

procedure StartOfFile;
  begin
    CurrentLine := 1;
  end; { StartOfFile }

procedure EndOfFile;
  begin
    CurrentLine := succ(NumberLines) - ScreenLines;
  end;  { EndOfFile }

procedure DisplayFile;

  function KeyWord : word; assembler;
    asm
      mov  ah,0
      int  16h
    end;

  begin
    DisplayScreen(CurrentLine);
    repeat
      case KeyWord of
        PageUp    : PreviousPage;
        PageDown  : NextPage;
        UpArrow   : PreviousLine;
        DownArrow : NextLine;
        Home      : StartOfFile;
        _End      : EndOfFile;
        Escape    : halt;
      end; { case }
      DisplayScreen(CurrentLine);
    until false;
  end; { DisplayFile }

procedure NewExitProc;far;
  begin
    ExitProc := OldExitProc;
    {$IFDEF TurboPower}
    NormalCursor;
    {$ENDIF}
    window(1,1,80,25);
    TextAttr := OldAttr;
    Clrscr;
  end;

procedure Initialise;
  begin
    CurrentLine := 1;
    if ParamCount <> 1 then begin
      writeln('No file name parameter');
      halt;
    end;
    OldAttr := TextAttr;
    assign(TxtFile,Paramstr(1));
    {$I-}  reset(TxtFile);
    if IOResult <> 0 then begin
      writeln('Unable to open ',Paramstr(1));
      halt;
    end;
    SetTextBuf(TxtFile,TxtBuffer);
    Window(1,23,80,25);
    TextAttr := BlackOnCyan;
    clrscr;
    writeln('              Next Page = [PageDown]     Previous Page = [PageUp]');
    writeln('              Next Line = [DownArrow]    Previous Line = [UpArrow]');
    write('         Start of File = [Home]   End of File = [End]   Quit = [Escape]');
    Window(1,1,80,22);
    TextAttr := LtGrayOnBlue;
    clrscr;
    {$IFDEF TurboPower}
    HiddenCursor;
    {$ENDIF}
    OldExitProc := ExitProc;
    ExitProc    := @NewExitProc;
  end;

begin
  Initialise;
  ReadTxtFile(TxtFile);
  DisplayFile;
end.