[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]
{
From: russell@alpha3.ersys.edmonton.ab.ca (Russell Schulz)
>Can Someone tell me how the DOS program MORE works?
dos does the redirection part. more just reads from stdin -- readln(s);
>I would really like to write a MORE replacement
there are already a bunch of good ones. ask archie for `less'.
also, with this old code of mine, you can type `l80 filespec.*' or
`dir |l80' as well. it keeps everything in the lower 640k.
}
program l80; {less-like program, 80-char limitation}
uses
dos,crt;
const
maxlines=24;
botlinelen=70;
blankstring=' ';
type
ptr=^node;
node=record
line: string[79];
next: ptr;
end;
var
infile: text;
ch: char;
filename: string;
line: string;
toplineno: longint;
prevtoplineno: longint;
done: boolean;
head, tail, prev, curr: ptr;
topline, botline: ptr;
numlines: longint;
rep: longint;
userep: longint;
searchstr: string;
dosearch: boolean;
atend: boolean;
refresh: boolean;
scrollno: integer;
doscroll: boolean;
newtoplineno: longint;
msg: string;
filespec: string;
temp: integer;
savepos: pointer;
i: integer;
fileinfo: searchrec;
procedure wipeline;
begin
write(^M,blankstring,^M);
end;
function expand(str: string): string;
var
work: string[79];
i,j: integer;
begin
if (pos(^I,str)=0) and (pos(^J,str)=0) and (pos('_',str)=0) then
expand := str
else
begin
work := '';
i := 1;
while i<=length(str) do
begin
if str[i]=^I then
for j := 1 to 8-(length(work) and 7) do
work := work+' '
else
if (length(str)>i) and (str[i] in ['_',^H,#127]) and
(str[i+1] in ['_',^H,#127]) and not
((str[i]='_') and (str[i+1]='_')) then
inc(i)
else
if str[i]<>^J then
work := work+str[i];
inc(i);
end;
expand := work;
end;
end;
function pline(p: ptr): string;
begin
if p=nil then
pline := '~'
else
pline := p^.line;
end;
procedure add(var head,tail: ptr; line: string);
var
n: ptr;
begin
new(n);
n^.line := expand(line);
n^.next := nil;
if head=nil then
head := n;
if tail<>nil then
tail^.next := n;
tail := n;
inc(numlines);
end;
function lookup(aline: integer): ptr;
var
curr: ptr;
begin
if aline>=numlines then
lookup := tail
else if aline<1 then
lookup := head
else
begin
curr := head;
while aline>1 do
begin
dec(aline);
curr := curr^.next;
end;
lookup := curr;
end;
end;
function gets(var line: string): boolean;
var
tmp: integer;
ch: char;
valid: boolean;
begin
valid := true;
line := '';
write(^M,'/');
repeat
ch := readkey;
if ch=^I then ch := ' ';
if ch<>^M then
if (ch=^H) and (line='') then
valid := false
else if ch=^H then
begin
if length(line)=1 then line := ''
else line := copy(line,1,length(line)-1);
write(ch,' ',ch);
end
else if length(line)<botlinelen then
begin
line := line+ch;
write(ch);
end;
until (ch=^M) or not valid;
wipeline;
gets := valid;
end;
function isin(shortstr,longstr: string): boolean;
begin
isin := pos(shortstr,longstr)<>0;
end;
function searchf(var curr: ptr; var toplineno: longint): boolean;
var
tmp: ptr;
lin: longint;
found: boolean;
awrap: boolean;
begin
found := false;
awrap := false;
prevtoplineno := toplineno;
prev := curr;
write('/');
lin := toplineno;
tmp := curr;
if tmp<>nil then
repeat
if tmp^.next=nil then
begin
awrap := true;
tmp := head;
lin := 1;
end
else
begin
tmp := tmp^.next;
inc(lin);
end;
if isin(searchstr,tmp^.line) then
found := true;
until found or (tmp=curr);
if found then
begin
curr := tmp;
toplineno := lin;
scrollno := toplineno-prevtoplineno;
if (scrollno>=0) and (scrollno<maxlines)
and (prevtoplineno+scrollno<=numlines-maxlines+1) then
begin
curr := prev;
toplineno := prevtoplineno;
doscroll := true;
end;
end;
if awrap then
msg := '(wrap)';
searchf := found;
wipeline;
end;
procedure prtscreen(p: ptr);
var
lineat: integer;
begin
atend := false;
lineat := 1;
while lineat<=maxlines do
begin
inc(lineat);
if p=nil then
begin
writeln('~');
atend := true;
end
else
begin
writeln(pline(p));
if lineat<=maxlines then
p := p^.next;
end;
end;
if (p=nil) or (p^.next=nil) then atend := true;
botline := p;
end;
procedure scroll(scrollno: integer);
var
lineat: integer;
begin
atend := false;
lineat := 1;
while lineat<=scrollno do
begin
inc(lineat);
if botline=nil then
begin
writeln('~');
atend := true;
end
else
begin
botline := botline^.next;
writeln(pline(botline));
end;
if topline<>nil then
begin
topline := topline^.next;
inc(toplineno);
end;
end;
if botline=nil then atend := true;
end;
function inrange(n: longint): longint;
begin
if n<1 then inrange := 1
else if n>numlines then inrange := numlines
else inrange := n;
end;
procedure showfile(filename: string);
begin
assign(infile,filename);
{$I-}
reset(infile);
{$I+}
if IOResult<>0 then
begin
writeln('error opening ''',filename,'''');
halt;
end;
head := nil;
tail := nil;
numlines := 0;
searchstr := '';
msg := '';
while not eof(infile) do
begin
readln(infile,line);
add(head,tail,line);
end;
close(infile);
toplineno := 1;
done := false;
topline := head;
prev := nil;
refresh := true;
doscroll := false;
while not done do
begin
if doscroll then
scroll(scrollno)
else if refresh then
prtscreen(topline);
refresh := true;
doscroll := false;
write(^M,' ',msg);
msg := '';
if atend then
write(^M,'--END--')
else
write(^M,'--L80--');
rep := 0;
prevtoplineno := toplineno;
repeat
repeat
ch := readkey;
until ch in [^M,'j','q',' ','G','0'..'9',^G,'b','u','/','n'];
if (ch in ['0'..'9']) and (rep<maxlongint div 10) then
rep := rep*10+ord(ch)-ord('0')
else if ch=^G then
begin
wipeline;
write('''',filename,''': ');
newtoplineno := inrange(toplineno+maxlines);
write('line ',newtoplineno:0,' of ',numlines:0,' ');
if numlines=0 then
write('--100%--')
else
write('--',100*newtoplineno div numlines:0,'%','--');
end
else
begin
wipeline;
if rep=0 then
userep := 1
else
userep := rep;
case ch of
'q': done := true;
' ':
begin
newtoplineno := inrange(toplineno+maxlines*userep);
if newtoplineno=toplineno then
refresh := false
else
begin
topline := lookup(newtoplineno);
toplineno := newtoplineno;
end;
end;
^M,'j':
begin
newtoplineno := inrange(toplineno+userep);
if newtoplineno=toplineno then
refresh := false
else
if userep<maxlines then
begin
doscroll := true;
scrollno := userep;
end
else
begin
topline := lookup(newtoplineno);
toplineno := newtoplineno;
end;
end;
'G', 'b', 'u':
begin
if ch='G' then
begin
newtoplineno := rep;
if (newtoplineno>numlines-maxlines)
or (newtoplineno<1) then
newtoplineno := numlines-maxlines+1;
end
else
newtoplineno := inrange(toplineno-maxlines*userep);
topline := lookup(newtoplineno);
toplineno := newtoplineno;
end;
'/', 'n':
begin
line := '';
if (ch='n') or gets(line) then
begin
dosearch := true;
if line='' then
if searchstr='' then
begin
msg := 'no previous string';
dosearch := false;
refresh := false;
end;
if line<>'' then
searchstr := line;
if dosearch then
if not searchf(topline,toplineno) then
begin
msg := 'not found';
refresh := false;
end;
end;
end;
end;
end;
until ch in [^M, 'j', 'q', ' ', 'G', 'b', '/', 'n', 'u'];
end;
end;
begin
if paramcount>0 then
if paramstr(1)='-?' then
begin
writeln('usage: l80 {filename}');
halt;
end;
mark(savepos);
if paramcount=0 then
showfile('')
else
begin
for i := 1 to paramcount do
begin
filespec := paramstr(i);
findfirst(filespec,archive,fileinfo);
temp:=length(filespec);
repeat
dec(temp);
until (filespec[temp]='\') or (filespec[temp]=':') or (temp=1);
if (pos('\',filespec)=0) and (pos(':',filespec)=0) then
filespec:=''
else
filespec:=copy(filespec,1,temp);
while doserror=0 do
begin
release(savepos);
showfile(concat(filespec,fileinfo.name));
findnext(fileinfo);
end;
end;
end;
end.
[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]