READ.LIB

{ Sample Message Read Function }
{ (c) Copyright 1988 Searchlight Software }


{ The following procedures will display the text of a message in the
  MESSAGE.BBS file.  It is assumed that the message file is opened as
  msgfile: file of textype.  To use this routine, call UnpackMsg(rec)
  where 'rec' is the record number in the message file containing the
  first block of message text (NOT the header record).  You should
  include both FILEDEF.LIB and this file in your program.

  Searchlight BBS compresses messages with the COMPRESS function before
  storing them; the UNCOMPRESS routine is used to read them back.  If you
  store data in the message file, it is not necessary to compress it
  first, but we include the COMPRESS function below if you want to.   }



{ -- String Compression Functions -------------------------------------- }


const eol = #13;                 { CR character }
type longstr = string[255];      { maximum length string }


Procedure Compress (var str: longstr);

  { compress a text string. 2 methods:
    1) collapse multicharacter sequences to 3-byte codes;
    2) remove spaces by setting 8th bit of succeeding byte.
       only performed if string contains no 8-bit bytes.    }

var i,p: byte;
    eightbit,comp: boolean;

Begin
  eightbit:=false;   { 8-bit character flag }

  p:=1;
  while (p<=length(str)-4) do begin        { run-length encoding }
    eightbit:=eightbit or (str[p]>#127);
    if (str[p]=str[p+1]) then
      if (str[p]=str[p+2]) then
        if (str[p]=str[p+3]) then
        begin
          i:=p+2;
          repeat i:=i+1
          until (i=length(str)) or (str[i+1]<>str[p]);
          delete(str,p+3,i-p-2);
          str[p]:=#01;
          str[p+1]:=chr(i-p+1);
          if str[p+1]=eol then str[p+1]:=#0;
          p:=p+2;
        end;
    p:=p+1;
  end;
  for p:=p to length(str) do
    eightbit:=eightbit or (str[p]>#127);

  if not eightbit then begin               { space replacement }
    comp:=false;
    i:=pos(' ',str);
    while (i>0) and (i<length(str)) and (str[i+1]<#128) do begin
      comp:=true;
      delete(str,i,1);
      str[i]:=chr(byte(str[i]) or 128);
      i:=pos(' ',str);
    end;
    if comp then insert(#02,str,1);
  end;

end;



Procedure Uncompress (var str: longstr);
  { un-compress string packed by compress routine }
var i: byte;
    c: char;
    object: longstr;

Begin

  if str[1]=#02 then begin      { reverse space-delete compression }
    delete(str,1,1);
    i:=1;
    while (i<=length(str)) do begin
      if str[i]<#128 then i:=i+1
      else begin
        str[i]:=chr(byte(str[i]) and 127);
        insert(' ',str,i);
        i:=i+2;
      end;
    end;
  end;

  i:=pos(#01,str);              { reverse run-length compression }
  while (i>0) do begin
    object[0]:=str[i+1];
    if object[0]=#0 then object[0]:=eol;
    c:=str[i+2];
    fillchar(object[1],length(object),c);
    delete(str,i,3);
    insert(object,str,i);
    i:=pos(#01,str);
  end;

end;



Procedure UnpackMsg (rec: integer);
  { unpack message and display it on the screen }

var temprec: textype;
    newline: boolean;
    eolpos,lasteol: integer;
    tempstr: longstr;


Begin
  tempstr[0]:=#0;      { clear temp string }

  while (rec<>0) do begin
    seek(msgfile,rec);
    read(msgfile,temprec);      { read next record from file }

    if not temprec.header then     { skip header }
    begin

      lasteol:=0;
      repeat

        eolpos:=pos(eol,temprec.data);       { check for CR }
        if eolpos=0 then begin
          eolpos:=length(temprec.data)+1;
          newline:=false;
        end
        else newline:=true;

        tempstr:=tempstr+copy(temprec.data,lasteol+1,eolpos-lasteol-1);

        if newline then temprec.data[eolpos]:=#0;
        lasteol:=eolpos;

        if newline then begin
          uncompress(tempstr);      { uncompress string }
          writeln(tempstr);         { print it }
          tempstr[0]:=#0;           { clear for next line }
        end;

      until (eolpos>=length(temprec.data));

    end;
    rec:=temprec.next;

  end;

end;