home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.wwiv.com
/
ftp.wwiv.com.zip
/
ftp.wwiv.com
/
pub
/
BBS
/
CEL141.ZIP
/
CEL141C.ZIP
/
TOOLKIT.ZIP
/
TEXTTOOL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-08-14
|
8KB
|
379 lines
procedure reloadtext (sector:integer; var q:message);
function maketext (var q:message):integer;
procedure trimmessage (var m:message);
procedure TextToFile(m:message;filename:lstr);
procedure setbam (sector,val:integer);
begin
seek (mapfile,sector);
write (mapfile,val)
end;
procedure reloadtext (sector:integer; var q:message);
var k:char;
sectorptr,tmp,n:integer;
buff:buffer;
x:boolean;
procedure chk;
begin
iocode:=ioresult;
if iocode<>0 then writeln (usr,'(Error ',iocode,' reading message)')
end;
begin {reloadtext}
sectorptr:=32767;
n:=1;
q.text[1]:='';
repeat
if sectorptr>sectorsize then begin
if sector<0 then exit;
if (sector>filesize(tfile)) or (sector>filesize(mapfile)) then begin
writeln('**Seek past end of EOF**');
exit;
end;
seek (tfile,sector); chk;
read (tfile,buff); chk;
seek (mapfile,sector); chk;
read (mapfile,tmp); chk;
if tmp=-2 then begin
tmp:=-1;
seek (mapfile,sector); chk;
write (mapfile,tmp); chk;
end;
sector:=tmp;
sectorptr:=1
end;
k:=buff[sectorptr];
case k of
#0,#10:;
#13:if n>=maxmessagesize
then k:=#0
else begin
n:=n+1;
q.text[n]:=''
end
else q.text[n]:=q.text[n]+k
end;
sectorptr:=sectorptr+1
until k=#0;
q.numlines:=n;
chk;
end;
procedure deletetext (sector:integer);
var next:integer;
begin
while sector>=0 do begin
seek (mapfile,sector);
read (mapfile,next);
setbam (sector,-2);
sector:=next
end
end;
function maketext (var q:message):integer;
var line,pos,sector,prev:integer;
bufptr:integer;
curline:anystr;
k:char;
buff:buffer;
function nextblank (first:integer; linkit:boolean):integer;
var cnt,i,blank:integer;
begin
nextblank:=-1;
if first<-1 then first:=-1;
if first>=numsectors then exit;
seek (mapfile,first+1);
for cnt:=first+1 to numsectors do begin
read (mapfile,i);
if i=-2 then begin
blank:=cnt;
if (first>=0) and linkit then setbam (first,blank);
nextblank:=blank;
exit
end
end
end;
function firstblank:integer;
begin
firstblank:=nextblank (-1,false)
end;
procedure ensuretfilesize (sector:integer);
var cnt:integer;
buff:buffer;
begin
if sector<filesize(tfile) then exit;
if (sector<0) or (sector>numsectors) then exit;
fillchar (buff,sizeof(buff),'┼');
seek (tfile,filesize(tfile));
for cnt:=filesize(tfile) to sector do write (tfile,buff);
fillchar (buff,sizeof(buff),'═')
end;
procedure writesector (sector:integer; var q:buffer);
var n:integer;
begin
if (sector<0) or (sector>numsectors) then exit;
seek (mapfile,sector);
read (mapfile,n);
if n<>-2 then begin
error ('Overwrite error sector=%1!','',strr(sector));
exit
end;
ensuretfilesize (sector);
seek (tfile,sector);
write (tfile,q)
end;
procedure flushbuf;
begin
writesector (sector,buff);
prev:=sector;
sector:=nextblank(prev,true);
bufptr:=1;
end;
procedure outofroom;
begin
writeln (^B'Sorry, out of room!');
maketext:=-1
end;
begin {Maketext}
if q.numlines=0 then begin
writeln (^B'No Data to Save');
maketext:=-1;
exit
end;
prev:=-1;
if prev<>-2 then begin
firstfree:=firstblank;
sector:=firstfree
end;
maketext:=sector;
if sector=-1 then begin
outofroom;
exit
end;
bufptr:=1;
for line:=1 to q.numlines do begin
curline:=q.text[line]+^M;
if line=q.numlines then curline:=curline+chr(0);
for pos:=1 to length(curline) do begin
k:=curline[pos];
buff[bufptr]:=k;
bufptr:=bufptr+1;
if bufptr>sectorsize then begin
flushbuf;
if sector=-1 then begin
outofroom;
exit
end
end
end
end;
if bufptr>1 then flushbuf;
setbam (prev,-1);
firstfree:=nextblank(firstfree,false);
if firstfree=-1 then firstfree:=firstblank;
if isauthor then writeln(usr,'[Writing at sector ',sector,']');
end;
function copytext (sector:integer):integer;
var me:message;
begin
reloadtext (sector,me);
copytext:=maketext (me)
end;
procedure trimmessage (var m:message);
var cnt,cnt2:integer;
s: lstr;
begin
s:='';
for cnt:=1 to 80 do s:=s+'╬';
for cnt:=1 to m.numlines do
while m.text[cnt][length(m.text[cnt])]=' ' do
m.text[cnt][0]:=pred(m.text[cnt][0]);
while (m.numlines>0) and (m.text[m.numlines]='') do
m.numlines:=m.numlines-1;
for cnt:=m.numlines+2 to maxmessagesize do
m.text[cnt]:=s;
end;
function charhit:boolean;
var k:char;
begin
if modeminlock then while numchars>0 do k:=GrabChar;
if hungupon or keyhit
then charhit:=true
else if online
then charhit:=(not modeminlock) and (numchars>0)
else charhit:=false
end;
procedure WVT52(t:anystr);
var cnt:integer;
begin
if modemoutlock then exit;
if t[2]=#234 then delete (t,1,1);
for cnt:=1 to length(t) do sendchar (t[cnt]);
end;
function charready:boolean;
var k:char;
begin
if modeminlock then while numchars>0 do k:=Grabchar;
if hungupon or keyhit
then charready:=true
else if online
then charready:=(not modeminlock) and (numchars>0)
else charready:=false;
while numchars>0 do k:=Grabchar;
end;
procedure waitforchar;
var t:integer;
k:char;
begin
t:=timer+setup.mintimeout;
if t>=1440 then t:=t-1440;
repeat
if timer>=t then forcehangup:=true
until (charready or hungupon);
chainstr:='';
while numchars>0 do k:=GrabChar;
end;
procedure PrintLine(line:anystr);
var i,cnt:byte;
color:sstr;
begin
i:=0;
while i<(length(line)) do begin
inc(i);
if line[i]='|' then begin
color:=line[i+1]+line[i+2];
ansicolor(valu(color));
i:=i+2;
end
else
write(line[i]);
end;
{ if length(line)<80 then }write(#13);
end;
function QuoteLine(s:string):boolean;
var Posit:integer;
begin
QuoteLine:=false;
Posit:=pos('>',s);
if (Posit>0) and (Posit<5) then
QuoteLine:=true;
if copy (s,1,3)='---' then
QuoteLine:=true;
end;
procedure ShowMessage(q:message);
var n,m,b,mm,DelayTime:integer;
p:byte;
a:sstr;
s:char;
quoting:boolean;
begin
LastMessage:=q;
n:=1;
Quoting:=false;
repeat
if not rawmode then begin
mm:=0;
if quoting and not (QuoteLine(q.text[n])) then begin
quoting:=false;
ansicolor(urec.sixthcolor);
end;
Quoting:=QuoteLine(q.text[n]);
if quoting then
ansicolor(urec.seventhcolor);
repeat
if length(q.text[n])>0 then begin
mm:=mm+1;
s:=q.text[n,mm];
write (s);
end; {if q.text[n]>0}
until mm>=length(q.text[n]);
end
else write(q.text[n]);
writeln;
inc(n);
until break or (n>q.numlines) or hungupon;
ansicolor (urec.regularcolor)
end;
procedure printtext (sector:integer);
var q:message;
begin
reloadtext (sector,q);
ShowMessage(q);
end;
procedure TextToFile(m:message;filename:lstr);
var f:text;
cnt:word;
begin
{$I-}
assign(f,filename);
rewrite(f);
for cnt:=1 to m.numlines do
writeln(f,m.text[cnt]);
textclose(f);
close(f);
end;
begin
end.
(*
This unit contains the asinine forum-style text storage and retreival
system. It is not efficient, it is not simple, and it is not easy to
use.
Reloadtext will load text from "sector" (the address of the text) into
a MESSAGE variable.
Maketext will store text to a data file from a message variable, and
return the address.
CopyText will copy text from one source to another, and return the
address of the copy.
TrimMessage sets all unused bytes in a message variable to one character,
as to improve compression on zip and v.42bis.
TexttoFile converts a message variable to a text file.
PrintMessage displays a text file.
*)