ftp.wwiv.com/ftp.wwiv.com.zip/ftp.wwiv.com/pub/BBS/CEL141.ZIP/CEL141C.ZIP/TOOLKIT.ZIP/TEXTTOOL.PAS

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.

*)