home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
t
/
tcsel003.zip
/
READTEXT.PAS
< prev
next >
Wrap
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 +61 91 73 2026 Data +61 91 73 2569 }
{ 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.