CP/M/CPM_CDROM.iso/beehive/bbs/rover12a.arc/MUNDANE.INC

Text File | 1991-08-11 | 11KB | 482 lines

{** MUNDANE.INC}

{--- system routines ---}

function bye_present: boolean;
begin
  bye_present:= 77 = bdos(32, 241);
end; {bye_present}

function bye_start: boolean;
begin
  bye_start:= mem[$20] = 0;
end; {bye_start}

procedure set_user(st: str2);
{set new user area while in program}
var
  number: integer;
  code: integer;
begin
  if length(st) = 0 then exit;
  val(st, number, code);
  if not (code = 0) then exit;
  if (number< 0) or (number > 15) then exit;
  bdos(32, number);
end; {set_user}

procedure setupdrive;
var
  drive: string[3];
begin
  drive:= area;
  if length(drive) = 0 then exit;
  bdos(14, ord(drive[1]) - $41);
  if length(drive) < 2 then exit;
  delete(drive,1,1);
  set_user(drive);
end; {setupdrive}

function allcaps(st: str30): str30;
var
  I: byte;
begin
  for I:= 1 to length(st) do
    st[I]:= upcase(st[I]);
  allcaps:= st;
end; {allcaps}

function lowCase(ch: char): char;
begin
  if (ch in ['A'..'Z']) then
    ch:= chr(ord(ch) + $20);
  lowCase:= ch;
end; {lowCase}

function fixcaps(st: str80): str80;
{Adjust start of word to upper case,}
{rest of word to lower case}
var
  flag: boolean;
  I: byte;
begin
  flag:= true;
  for I:= 1 to length(st) do
  begin
    if flag then st[I]:= upCase(st[I])
      else st[I]:= lowCase(st[I]);
    flag:= false;
    if (st[I] in [' ', '-']) then flag:= true;
  end;
  fixcaps:= st;
end; {fixcaps}

function byte_to_string(bt: byte): str2;
var
  st: str2;
begin
  str(bt, st);
  if (length(st) < 2) then st:= '0' + st;
  byte_to_string:= st;
end; {byte_to_string}

{--- disk file routines ---}

function exists(filname: str14): boolean;
begin
  assign(oldfil, filname);
  {$I-}
  reset(oldfil);
  {$I+}
  exists:= (IORESULT = 0);
end; {exists}

function existstext(filname: str14): boolean;
begin
  assign(textfil, filname);
  {$I-}
  reset(textfil);
  {$I+}
  existstext:= (IORESULT = 0);
end; {existstext}

function opennewtext(filname: str14): boolean;
begin
  assign(textfil, filname);
  {$I-}
  rewrite(textfil);
  {$I+}
  opennewtext:= (IORESULT = 0);
end; {opennewtext}

procedure opennew(filname: str14);
begin
  assign(newfil, filname);
  rewrite(newfil);
end; {opennew}

procedure openindex;
begin
  assign(ndxfil, 'INDEX.PBS');
  reset(ndxfil);
end; {openindex}

function openfiles: boolean;
label abortloc;
var
  OK: boolean;
begin
  assign(ndxfil, 'INDEX.PBS');
  {$I-}
  reset(ndxfil);
  {$I+}
  OK:= (IORESULT = 0 );
  if not OK then goto abortloc;
  assign(msgndxfil, 'MSGINDEX.PBS');
  {$I-}
  reset(msgndxfil);
  {$I+}
  OK:= OK and (IORESULT = 0 );
  if not OK then goto abortloc;
  assign(messagesfil, 'MESSAGES.PBS');
  {$I-}
  reset(messagesfil);
  {$I+}
  OK:= OK and (IORESULT = 0);
ABORTLOC:
  openfiles:= OK;
end; {openfiles}

procedure closefiles;
begin
  close(messagesfil);
  close(msgndxfil);
  close(textfil);
end; {closefiles}

procedure saveindex;
begin
  writeln('updating INDEX.PBS');
  openindex;
  begin
    {setup buffer}
    with index do
    begin
      {date:   str8;}
      ndxbuffer[4]:= lo(next_messages_rec);
      ndxbuffer[5]:= hi(next_messages_rec);
      ndxbuffer[6]:= lo(next_message_number);
      ndxbuffer[7]:= hi(next_message_number);
      ndxbuffer[8]:= lo(last_msgindex_rec);
      ndxbuffer[9]:= hi(last_msgindex_rec);
    end; {with}
    blockwrite(ndxfil, ndxbuffer, 1);
    close(ndxfil);
  end;
end; {saveindex}

function opensnapfile(numb: integer): boolean;
var
  numbstr: string[3];
  newname: string[14];
  result: boolean;
begin
  close(snapfil);
  str(numb, numbstr);
  case length(numbstr) of
    1: numbstr:= '00' + numbstr;
    2: numbstr:= '0'  + numbstr;
  end; {case}
  newname:= snapfilename + '.' + numbstr;
  assign(snapfil, newname);
  {$I-}
  reset(snapfil);
  {$I+}
  result:= (IORESULT = 0);
  if result then writeln('transfering ' + newname);
  opensnapfile:= result;
end; {opensnapfile}

{--- more system routines ---}

procedure finis(bt: byte);
begin
  case bt of
    0: begin
         writeln('Usage:  ROVER [stm?]');
         writeln('Where:      s = scan/export only (default)');
         writeln('            t = toss/import only');
         writeln('            m = menu (default)');
         writeln('            ? = usage prompt');
         writeln;
         writeln('Defaults to menu and export when command file not present.');
       end;
    3: begin
         writeln;
         writeln;
         writeln('Session terminated by user');
       end;
  end; {case}
  if bt in [0, 3] then halt;

  closefiles;
  case bt of
    1: writeln('Done');
    2: writeln('++ Cannot open files, aborting ++', ^G);
  end; {case}
  halt;
end; {finis}

function readKey: char;
var
  ch: char;
begin
  read(kbd, ch);
  readKey:= ch;
end; {readKey}

function readKeyETX: char;
var
  ch: char;
begin
  ch:= readKey;
  if (ch= ETX) then finis(3);
  readKeyETX:= ch;
end; {readkeyetx}

(*
procedure load(fname: str14);
begin
  if open(fname) then begin mem[0]:= $C3; execute(fil); end
    else writeln('++ file BBS.COM not found ++');
end; {load}
*)

{--- buffering routines ---}

function buffertostring(buffer: bufftype; pos, numb: byte): str30;
label endbuf;
var
  I, v : byte;
  st: str30;
begin
  st:= '';
  for I:= (pos) to (pos + numb - 1) do
  begin
    v:= buffer[I];
    if (v = 0) then goto endbuf;
    st:= st + chr(v);
  end;
ENDBUF:
  buffertostring:= st;
end; {buffertostring}

function padstr0(st: str30; numb: byte): str30;
var
  I, len: byte;
begin
  len:= length(st);
  if (numb > 30) then numb:= 30;
  if len < 30 then
    for I:= len + 1 to numb
      do st:= st + NUL;
  padstr0:= st;
end; {padstr0}

function fillstr16(ch: str2): str16;
{fill 16 char string with single char}
var
  a: byte;
  st: str16;
begin
  st:= '';
  for a:= 1 to 16 do
    st:= st + ch;
  fillstr16:= st;
end; {fillstr16}

procedure transfertobuffer;
{transfer string array to byte array}
var
  b, j, p: byte;
  st: str16;
begin
  for b:= 1 to 8 do
  begin
    st:= line1[b];
    p:= (b-1) * 16;
    for j:= 1 to 16 do
      filebuffer[j + p]:= ord(st[j]);
   end;
end; {filebuffer}

{--- record routines ---}

procedure update_msgindexrec;
begin
  msgindex.receiver:= receiver;
  msgindex.date:= date;
  msgindex.time:= time;
  msgindex.subject:= subject;
  msgindex.sender:= sender;
  with msgindex do
  begin
    msg_no:= index.next_message_number;
    start_rec_no:= index.next_messages_rec;
    nextrecord:= start_rec_no + num_of_recs;
    msgindex_rec_no:= index.last_msgindex_rec + 1;
    mirecord:= msgindex_rec_no;
    msgindexrec:= mirecord;
   { public:= 0; }
   { folder:= 4; }
    deleted:= 0;
    null:= 0;
  end; {with}
end; {update_msgindexrec}

procedure update_indexrec;
begin
  with index do
  begin
    date:= msgindex.date;
    next_messages_rec:= next_messages_rec + msgindex.num_of_recs;
    next_message_number:= next_message_number + 1;
    last_msgindex_rec:= msgindex.msgindex_rec_no;
  end; {with}
end; {update_indexrec}

{--- read/write routines ---}

procedure readindex;

procedure set_index_record;
begin
  with index do
  begin
    {date:   str8;}
    next_messages_rec:= ndxbuffer[4] + ndxbuffer[5]*256;
    next_message_number:= ndxbuffer[6] + ndxbuffer[7]*256;
    last_msgindex_rec:= ndxbuffer[8] + ndxbuffer[9]*256;
  end; {with}
  close(ndxfil);
end; {set_index_record}

begin;
  blockread(ndxfil, ndxbuffer, 1);
  set_index_record;
end; {readindex}

procedure wrtmsg(msgline: msgtype; numb: integer);
var
  I: byte;
  more: boolean;
  msgbuffer: bufftype;
  dummy: msgtype;
begin
  more:= {not} odd(numb);
  numb:= trunc(numb / 2); {round}

  if more then
  begin
  seek(messagesfil, numb);
  blockread(messagesfil, msgbuffer, 1);
  for I:= 1 to 64 do
    msgbuffer[I + 64]:= msgline[I];
  end
  else
  begin
    for I:= 1 to 64 do
      msgbuffer[I]:= msgline[I];
    for I:= 1 to 64 do
      msgbuffer[I + 64]:= 1;
  end;

  seek(messagesfil, numb);
  blockwrite(messagesfil, msgbuffer, 1);
end; {wrtmsg}

procedure writemsgindex;
var
  physicalrecord: integer;
  mioffset: byte;
  I, newoffset: byte;
  buf: array[1..100] of byte;

procedure build_buffer;
var
  k, c: byte;
  int, int1: integer;
begin
  with msgindex do
  begin
    for k:= 1 to 100 do
      buf[k]:= 5;
    receiver:= padstr0(receiver, 30);
    for k:= 1 to 30 do
      buf[k]:= ord(receiver[k]);
    buf[31]:= lo(msg_no); buf[32]:= hi(msg_no);

    {date}
    val(copy(date,1,2),int,int1);
    if (int1 > 0) then int:= int1;
    buf[33]:= int;
    val(copy(date,4,2),int,int1);
    if (int1 > 0) then int:= int1;
    buf[34]:= int;
    val(copy(date,7,2),int,int1);
    if (int1 > 0) then int:= int1;
    buf[35]:= int;
    buf[36]:= num_of_recs;
    buf[37]:= lo(start_rec_no); buf[38]:= hi(start_rec_no);
    buf[39]:= lo(msgindex_rec_no); buf[40]:= hi(msgindex_rec_no);
    subject:= padstr0(subject, 26);
    for k:= 41 to 66 do
      buf[k]:= ord(subject[k - 40]);
    sender:=  padstr0(sender, 30);
    for k:= 67 to 96 do
       buf[k]:= ord(sender[k-66]);
    buf[97]:= public;
    buf[98]:= folder;
    buf[99]:= deleted;
    buf[100]:= null;
  end; {with}
end; {build_buffer}

begin
  physicalrecord:= trunc((100/128) * mirecord);
  mioffset:= round(frac((100/128) * mirecord) * 128) + 1;
  writeln('writing  MSGINDEX.PBS');
  build_buffer;

  if (mioffset> 1) then
  begin
    seek(msgndxfil, physicalrecord);
    blockread(msgndxfil, msgindexbuffer, 1);
  end;

  if (mioffset < 30) then
  for I:= mioffset to 99 + mioffset do
    msgindexbuffer[I]:= buf[I - mioffset + 1];
  {** else **}
  if (mioffset > 29) then
  begin
    for I:= mioffset to 128 do
      msgindexbuffer[I]:= buf[I - mioffset + 1];
  end;

  seek(msgndxfil, physicalrecord);
  blockwrite(msgndxfil, msgindexbuffer, 1);

 { mioffset:= mioffset - 28;} {next physcial record}
  if (mioffset > 29) then
  begin
    physicalrecord:= physicalrecord + 1;
    for I:= 1 to (mioffset - 29) do
      msgindexbuffer[I]:= buf[I + 129 - mioffset];
    for I:= (mioffset - 28) to 128 do {fill extra space}
      msgindexbuffer[I]:= 0;
    seek(msgndxfil, physicalrecord);
    blockwrite(msgndxfil, msgindexbuffer, 1);
  end;
end; {writemsgindex}