Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBBS/eco_hdsn.pas

Pascal/Delphi Source File | 1993-04-12 | 36.9 KB | 1,397 lines

(*
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   The ECO_HDSN Toolkit was conceived, designed     ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   and written by Floor A.C. Naaijkens for          ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   UltiHouse Software / The ECO Group.              ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   (C) MCMXCII by EUROCON PANATIONAL CORPORATION.   ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   All Rights Reserved for The ECO Group.           ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   Interface to RA/Hudson message database.         ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
*)
{$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
unit eco_hdsn;


interface

uses
  dos, eco_text;


{$I rastruct.inc}


type
  msgattrs = set of (
    m_del, m_transit, m_netm, m_priv, m_rcvd, m_echotr, m_local, m_r1
  );
  netattrs = set of (
    n_kill, n_sent, n_file, n_crash, n_reqrec, n_audreq, n_retrec, n_r2
  );
  namestring = string[35];
  subjstring = string[72];


type
  lastcall = record
    line   :            byte;
    name   :  msgtoidxrecord;
    city   :      string[25];
    baud   :            word;
    times  :         longint;
    logon  :       string[5];
    logoff :       string[5];
  end;


  msgboardsarray = array[1..200] of messagerecord;
  msgboardsarrayptr = ^msgboardsarray;




const
  boardlim = 200;       {maximum number of boards}
  ok = 0;               {ioresult value}

  defaultmsgattr: array[msgtype] of msgattrs=(          {may be modified}
        [m_transit, m_netm],     {netmail}
        [m_echotr],             {echomail}
        [m_local]);             {local mail}
  defaultnetattr: array[msgtype] of netattrs=(
        [],                     {netmail}
        [],                     {echomail}
        []);                    {local mail}

  {- set the location of the *.bbs files, default is current directory -}
  procedure setbbspath(path: pathstr);

  {- set the location of the users*.bbs files, default is current directory -}
  procedure setuserspath(path: pathstr);

  {- set the user related files support -}
  procedure setusersupport(name: namestring;  lastread, current: boolean);

  {-
    open all the files associated with the quickbbs message base.
    this function looks for the files in the bbspath directory and
    returns 0 iff everything went ok.
  -}

  function openmsgbase: integer;
  function flushmsgbase: integer;
  function closemsgbase: integer;


  {- create a header for a new message -}
  procedure createnewheader(var hdr: msghdrrecord;  whofrom, whoto: namestring;
                            subj: subjstring;  brd: byte;  typ: msgtype);

  {- update a header before calling writemessage after changing a message -}
  procedure changeheader(var hdr: msghdrrecord);

  {- create a new message or modify an old message -}
  function writemessage(var hdr: msghdrrecord;  var t: textbuffer): integer;

  {- read a message -}
  function readmessage(msgno: integer; var hdr: msghdrrecord;  var t: textbuffer): integer;

  {- get information about messages from index files -}
  function firstmsg(brd: byte): integer;
  function lastmsg(brd: byte): integer;
  function countmsg(brd: byte): integer;
  function lastreadmsg(brd: byte): integer;
  function curmsg(brd: byte): integer;
  function boardmsg(brd: byte;  cur: integer): integer;

  {- set message pointers -}
  procedure setlastread(brd: byte;  msgno: integer);
  procedure setcur(brd: byte;  msgno: integer);

  {- get next/previous message, returns 0 if empty, -1 if not found -}
  function msgnext(brd: byte;  cur: integer): integer;
  function msgprev(brd: byte;  cur: integer): integer;

  {- return true iff there is a message at 'msgno' in board 'brd' -}
  function msgat(brd: byte;  msgno: integer): boolean;

  {- read and write a message header, return 0 iff ok -}
  function readheader(msgno: integer;  var hdr: msghdrrecord): integer;
  function writeheader(var hdr: msghdrrecord): integer;

  {- read message text, return 0 iff ok.  return empty buffer on error. -}
  function readtext(var hdr: msghdrrecord; var t: textbuffer): integer;

  {- search for a message to a person -}
  function searchto(
    board: byte; var msgnum: integer; name: namestring
  ): integer;

  {- delete a message -}
  function msgdelete(msgnum: integer): integer;




implementation


const
  filenotfound = 2;             {ioresult value}

  maxsize = 65520;              {max size for a structure}
  maxidx = maxsize div sizeof(msgidxrecord);
  maxtoss = maxsize div sizeof(integer);

type
  timestr = string[5];
  datestr = string[8];
  tossarray = array[0..maxtoss] of integer;
  tossarrayptr = ^tossarray;

  idxarray = array[0..maxidx] of msgidxrecord;
  idxarrayptr = ^idxarray;
  qfrange = (qidx, qinfo, qhdr, qtxt, qtoidx, qcurrent, qlastread{, qboards});

const
  qfname: array[qfrange] of string[8+1+3]=(
    'msgidx.bbs', 'msginfo.bbs', 'msghdr.bbs', 'msgtxt.bbs',
    'msgtoidx.bbs', 'current.bbs', 'lastread.bbs'{, 'messages.ra'}
  );
  qfsize: array[qfrange] of integer=(sizeof(msgidxrecord),
    sizeof(msginforecord), sizeof(msghdrrecord), sizeof(msgtxtrecord),
    sizeof(msgtoidxrecord), sizeof(lastreadrecord), sizeof(lastreadrecord){,
    sizeof(msgboardsarray)}
  );

  currentdirty :  boolean = false;  {dirty bits 4 current.bbs and lastread.bbs}
  lastreaddirty:  boolean = false;
  msgbaseopened:  boolean = false;

var
  userspath    : pathstr;       {- path for *.bbs files, '\' terminated -}
  bbspath      : pathstr;       {- path for *.bbs files, '\' terminated -}
  usernum      : integer;       {current user number for lastread.bbs}
  username     : namestring;    {for checking msgtoidx.bbs}
  highmsgread  : integer;       {for current user, only if username<>''}
  uselastread  : boolean;       {must be set before openmsgbase}
  usecurrent   : boolean;

  qf           : array[qfrange] of file;
  msginfo      : msginforecord;

  msgidx       : record
    len        : integer;       {length of msgidx}
    alloc      : integer;       {current allocated length in elements}
    idx        : idxarrayptr;   {may be partially allocated}
  end;

  lastread     : lastreadrecord;
  current      : lastreadrecord;

{- set the size of the msgidx dynamic array.  doesn't actually modify the
   values in the array, only the size. -}



  procedure setmsgidxsize(size: integer);
  const overalloc = 16; {overallocate this much to decrease fragmentation}
  var
    newidx: idxarrayptr;
    newalloc: integer;
  begin
    if (size > msgidx.alloc) then begin         {allocate more space}
      newalloc := size+overalloc;
      getmem(newidx, word(newalloc*sizeof(newidx^[0])));        {allocate new}
      fillchar(newidx^, word(newalloc*sizeof(newidx^[0])), 0);  {and clear it}
      if (msgidx.idx <> nil) then begin                         {copy old part}
        move(msgidx.idx^, newidx^, word(msgidx.len*sizeof(newidx^[0])));
        freemem(msgidx.idx, word(msgidx.alloc*sizeof(newidx^[0])));  {free old}
      end; {if}
      msgidx.alloc := newalloc;                                 {set new}
      msgidx.idx := newidx;                                     {new pointer}
    end; {if}

    msgidx.len := size;
  end; {setmsgidxsize}

{- update the directory entry of a file, return 0 iff ok -}



  function flushfile(var f: file): integer;
  var reg: registers;
  begin
    reg.ah := $45;      {dup handle}
    reg.bx := filerec(f).handle;
    msdos(reg);
    flushfile := reg.ax;
    if odd(reg.flags) then exit;        {cf set -> error}

    reg.bx := reg.ax;                   {new handle}
    reg.ah := $3e;      {close file}
    msdos(reg);
    flushfile := reg.ax;
    if odd(reg.flags) then exit;        {error}

    flushfile := ok;
  end; {flushfile}

{- open a file, optionally creating it.  return 0 iff ok -}



  function open(
    var f: file; name: pathstr; recsize: integer; create, bbs: boolean
  ): integer;
  var result: integer;
  begin
    if bbs then assign(f, bbspath + name) else assign(f, userspath + name);
    {$i-} reset(f, recsize); {$i+}
    result := ioresult;
    if create and (result=filenotfound) then begin
      {$i-} rewrite(f, recsize); {$i+}
      result := ioresult;
    end; {if}
    open := result;
  end; {open}



  function upper(s: string): string;
  var p: byte;
  begin
    for p := 1 to length(s) do
      s[p] := upcase(s[p]);
    upper := s;
  end; {upper}



  function openmsgbase: integer;
  var
    qfstep: qfrange;
    result: integer;
    offset: longint;

  procedure forceintorange(var a: lastreadrecord);
    var
      c: byte;
      temp: integer;
    begin
      for c := 1 to boardlim do begin
        temp := lastmsg(c);
        if (a[c] > temp) then
          a[c] := temp
        else begin
          temp := firstmsg(c);
          if (a[c] < temp) then
            a[c] := temp;
        end; {else}
      end; {for}
    end; {forceintorange}




  {- search for a user in users.bbs, returns ioresult.  offset is record
     number of user in users.bbs, or -1 if not found -}

    function searchuser(name: namestring;  var offset: longint;
                      var high: integer): integer;
    label error;
    var
      result: integer;
      users: file;
      user: usersrecord;
      found: boolean;

    begin
      offset := -1; {not found}
      high := 0;
      result := open(users, 'users.bbs', sizeof(usersrecord), false, false);
      if result <> ok then begin
        searchuser := result;
        exit;
      end; {if}

      found := false;
      name := upper(name);
{$I-} while not eof(users) and not found do begin
        blockread(users, user, 1);
{$I+}   result := ioresult;
        if result <> ok then goto error;
        found := (name = upper(user.name));
      end; {while}
      result := ioresult;   {for eof, will be ok if ok}

      if found then begin
        offset := filepos(users)-1; {we read past, remember?}
        high := user.lastread;
      end; {if}

  error:
      close(users);
      searchuser := result;
    end; {searchuser}

  begin {openmsgbase}
    if (username <> '') then begin
      result := searchuser(username, offset, highmsgread);
      if (result <> ok) then begin
        openmsgbase := result;
        exit;
      end; {if}
      if (offset = -1) then begin
        openmsgbase := -2;  {user not found}
        exit;
      end; {if}
      usernum := offset;
    end else usernum := 0;

    for qfstep := qidx to qtoidx do begin
      result := open(qf[qfstep], qfname[qfstep], qfsize[qfstep], true, false);
      if (result <> ok) then begin
        openmsgbase := result;
        exit;
      end; {if}
    end; {for}

    if uselastread then begin
      result := open(
        qf[qlastread], qfname[qlastread], qfsize[qlastread], true, false
      );
      if (result <> ok) then begin
        openmsgbase := result;
        exit;                   {fail}
      end; {if}
    end; {if}

    if usecurrent then begin
      result := open(
        qf[qcurrent], qfname[qcurrent], qfsize[qcurrent], true, true
      );
      if (result <> 0) then begin
        openmsgbase := result;
        exit;                   {fail}
      end; {if}
    end; {if}

    fillchar(msgidx, sizeof(msgidx), 0);
    setmsgidxsize(filesize(qf[qidx]));
    {$i-} blockread(qf[qidx], msgidx.idx^, msgidx.len); {$i+}
    result := ioresult;
    if (result <> ok) then begin
      openmsgbase := result;
      exit;                     {fail}
    end; {if}

    fillchar(msginfo, sizeof(msginfo), 0);
    blockread(qf[qinfo], msginfo, 1, result);      {ignore short read}

    fillchar(lastread, sizeof(lastread), 0);
    if uselastread then begin
      seek(qf[qlastread], usernum);              {current user}
      blockread(qf[qlastread], lastread, 1, result);       {ignore short read}
      forceintorange(lastread);
    end; {if}

    fillchar(current, sizeof(current), 0);
    if usecurrent then begin
      seek(qf[qcurrent], usernum);              {current user}
      blockread(qf[qcurrent], current, 1, result); {ignore short read}
      forceintorange(current);
    end; {if}

    msgbaseopened := true;
    openmsgbase := ok;
  end; {openmsgbase}

{- update lastread.bbs, current.bbs and users.bbs -}




  function updatecurlast: integer;
  var
    result: integer;
    users: file;
    user: usersrecord;
  begin
    updatecurlast := ok;

    if (username <> '') then begin
      result := open(users, 'users.bbs', sizeof(usersrecord), false, false);
      seek(users, usernum);
      blockread(users, user, 1);
      if (highmsgread > user.lastread) then begin
        user.lastread := highmsgread;
        seek(users, usernum);
        blockwrite(users, user, 1);
      end; {if}
      close(users);
    end; {if}

    if (usecurrent and currentdirty) then begin
      {$i-} seek(qf[qcurrent], usernum); {$i+}
      {$i-} blockwrite(qf[qcurrent], current, 1); {$i+}
      updatecurlast := ioresult;
    end; {if}

    if (uselastread and lastreaddirty) then begin
      for result := 1 to boardlim do
        if (lastreadmsg(result) > lastmsg(result)) then
          setlastread(result, lastmsg(result));
      {$i-} seek(qf[qlastread], usernum); {$i+}
      {$i-} blockwrite(qf[qlastread], lastread, 1); {$i+}
      updatecurlast := ioresult;
    end; {if}
  end; {updatecurlast}



  function closemsgbase: integer;
  var
    qfstep: qfrange;
    result: integer;
    isopen: set of qfrange;
  begin
    closemsgbase := updatecurlast;

    isopen := [qidx..qtoidx];
    if usecurrent then isopen := isopen+[qcurrent];
    if uselastread then isopen := isopen+[qlastread];
    for qfstep := qidx to qlastread do
      if qfstep in isopen then begin
        {$i-} close(qf[qfstep]); {$i+}
        result := ioresult;
        if (result <> ok) then
          closemsgbase := result;
      end; {for}

    if (msgidx.idx <> nil) then
      freemem(msgidx.idx, word(msgidx.alloc*sizeof(msgidx.idx^[0])));
    fillchar(msgidx, sizeof(msgidx), 0);

    msgbaseopened := false;
  end; {closemsgbase}




  function flushmsgbase: integer;
  var
    qfstep: qfrange;
    result: integer;
  begin
    flushmsgbase := updatecurlast;

    for qfstep := qidx to qlastread do begin
      result := flushfile(qf[qfstep]);
      if (result <> ok) then
        flushmsgbase := result;
    end; {for}
  end; {flushmsgbase}

{- find the first and last message in a board -}




  function firstmsg(brd: byte): integer;
  var
    step: integer;
  begin
    firstmsg := 0;
    if (countmsg(brd) = 0) then exit;

    for step := 0 to msgidx.len-1 do
      with msgidx.idx^[step] do
        if (board = brd) and (msgnum <> -1) then begin
          firstmsg := msgnum;
          exit;
        end; {if}

    {return 0 if not found}
  end; {firstmsg}




  function lastmsg(brd: byte): integer;
  var
    step: integer;
  begin
    lastmsg := 0;
    if (countmsg(brd) = 0) then exit;

    for step := msgidx.len-1 downto 0 do
      with msgidx.idx^[step] do
        if (board = brd) and (msgnum <> -1) then begin
          lastmsg := msgnum;
          exit;
        end; {if}

    {return 0 if not found}
  end; {lastmsg}




  function countmsg(brd: byte): integer;
  begin
    countmsg := msginfo.totalonboard[brd]; (* msginfo.activemsgs[brd]; *)
  end; {countmsg}

{-
  work out the relative position of a message in it's board
  return 0 if the message is not found
  this is a slow linear search which is used by msged/q to display the
  relative message number in the current message board.  it is not useful
  for any other purpose.
-}




  function boardmsg(brd: byte;  cur: integer): integer;
  var step, count: integer;
  begin
    count := 0;
    for step := 0 to msgidx.len-1 do
      with msgidx.idx^[step] do
        if (board = brd) and (msgnum <> -1) then
          if (msgnum = cur) then begin
            boardmsg := count+1;
            exit;
          end else begin
            inc(count);
          end; {else}
    boardmsg := 0;
  end; {boardmsg}




  function curmsg(brd: byte): integer;
  begin
    curmsg := current[brd];
  end; {curmsg}



  procedure setcur(brd: byte;  msgno: integer);
  begin
    currentdirty := true;
    current[brd] := msgno;
  end; {setcur}




  procedure setlastread(brd: byte;  msgno: integer);
  begin
    lastreaddirty := true;
    lastread[brd] := msgno;
  end; {setlastread}



  function lastreadmsg(brd: byte): integer;
  begin
    lastreadmsg := lastread[brd];
  end; {lastreadmsg}



  function maximum(a, b: longint): longint;
  begin
    if (a > b) then
      maximum := a
    else
      maximum := b;
  end; {maximum}

{-
 binary search in msgidx
 handles deleted entries (out of sort) by skipping alternatingly
 left and right from the middle until a non-deleted entry is found.
 may become slower when there are a lot of deleted entries.
-}




  function binidx(num: integer;  var found: boolean): integer;
  var left, right, mid, stab, skip, skipend: integer;
  begin
    left := 0;  right := msgidx.len-1;
    found := true;

    while (left <= right) do begin
      skip := 1;
      mid := (left+right) div 2;
      skipend := maximum(mid-left, right-mid)*2 + 1;
      repeat
        if (mid >= left) and (mid <= right) then
          stab := msgidx.idx^[mid].msgnum
        else stab := -1;

        if (stab = -1) then begin       {deleted or out of range}
          inc(mid, skip);                {step sideways}
          if (skip < 0) then
            skip := -skip+1
          else skip := -(skip+1);       { +1 -2 +3 -4 +5 -6 ... }
        end; {if}
      until (stab <> -1) or (abs(skip) > skipend);

      if (stab = -1) then begin
        found := false;  binidx := left;  exit;
      end; {if}

      if (num = stab) then begin
        binidx := mid;  exit;
      end; {if}

      if (num < stab) then
        right := mid-1
      else
        left := mid+1;
    end; {while}

    found := false;  binidx := left;  exit;
  end; {binidx}




  function msgnext(brd: byte;  cur: integer): integer;
  var
    step: integer;
    found: boolean;
  begin
    msgnext := 0;
    if (countmsg(brd) = 0) then exit;

    step := binidx(cur, found)+1;

    while (step < msgidx.len) do begin
      with msgidx.idx^[step] do
        if (brd = board) and (msgnum > cur) then begin
          msgnext := msgnum;
          exit;
        end; {if}
      inc(step);
    end; {while}

    (* msgnext := lastmsg(brd); *)
    msgnext := -1;
  end; {msgnext}




  function msgprev(brd: byte;  cur: integer): integer;
  var
    step: integer;
    found: boolean;
  begin
    msgprev := 0;
    if (countmsg(brd) = 0) then exit;

    step := binidx(cur, found)-1;

    while (step >= 0) do begin
      with msgidx.idx^[step] do
        if (brd = board) and (msgnum <> -1) and (msgnum < cur) then begin
          msgprev := msgnum;
          exit;
        end; {if}
      dec(step);
    end; {while}

    msgprev := -1;
  end; {msgprev}

{- return header file record number from message number, -1 on error -}



  function filemsg(msgno: integer): integer;
  var
    step: integer;
    found: boolean;
  begin
    filemsg := -1;
    if (msgno > msginfo.highmsg) or (msgno < msginfo.lowmsg) then exit;
    step := binidx(msgno, found);
    if found then filemsg := step;
  end; {filemsg}

{- return true iff there is a message at 'msgno' in board 'brd' -}




  function msgat(brd: byte;  msgno: integer): boolean;
  var fmsg: integer;
  begin
    msgat := false;
    if (msgno = -1) then exit;
    fmsg := filemsg(msgno);
    if (fmsg = -1) then exit;
    msgat := (msgidx.idx^[fmsg].board = brd);
  end; {msgat}

{- read a message header -}




  function readheader(msgno: integer;  var hdr: msghdrrecord): integer;
  var
    n: integer;
  begin
    readheader := -1;
    n := filemsg(msgno);
    if (n = -1) then exit;
    {$i-} seek(qf[qhdr], n); {$i+}
    {$i-} blockread(qf[qhdr], hdr, 1); {$i+}
    readheader := ioresult;
  end; {readheader}




  function writeheader(var hdr: msghdrrecord): integer;
  var
    n: integer;
  begin
    writeheader := -1;
    n := filemsg(hdr.msgnum);
    if (n = -1) then exit;
    {$i-} seek(qf[qhdr], n); {$i+}
    {$i-} blockwrite(qf[qhdr], hdr, 1); {$i+}
    writeheader := ioresult;
  end; {writeheader}

{- add or modify a record of msgtoidx.bbs -}




  function writetoidx(fmsg: integer;  whoto: msgtoidxrecord): integer;
  begin
    {$i-} seek(qf[qtoidx], fmsg); {$i+}
    {$i-} blockwrite(qf[qtoidx], whoto, 1); {$i+}
    writetoidx := ioresult;
  end; {writetoidx}

{- increment message counters in msginfo.bbs -}




  function incmsginfo(brd: byte): integer;
  begin
    inc(msginfo.highmsg);
    inc(msginfo.totalmsgs);  (* inc(msginfo.totalactive); *)
    inc(msginfo.totalonboard[brd]); (* inc(msginfo.activemsgs[brd]); *)

    {$i-} seek(qf[qinfo], 0); {$i+}
    {$i-} blockwrite(qf[qinfo], msginfo, 1); {$i+}
    incmsginfo := ioresult;
  end; {incmsginfo}

{- add or modify a record of msgidx.bbs -}



  function writemsgidx(fmsg, msgno: integer;  brd: byte): integer;
  begin
    if (fmsg >= msgidx.len) then
      setmsgidxsize(fmsg+1);

    with msgidx.idx^[fmsg] do begin
      msgnum := msgno;
      board := brd;
    end; {with}

    {$i-} seek(qf[qidx], fmsg); {$i+}
    {$i-} blockwrite(qf[qidx], msgidx.idx^[fmsg], 1); {$i+}

    writemsgidx := ioresult;
  end; {writemsgidx}




  function writetext(var hdr: msghdrrecord;  var t: textbuffer;  old: boolean): integer;
  var
    buf: textbuffer;
    result: integer;
    oldhdr: msghdrrecord;
    step: textnodeptr;
    line: string;

  begin
    unwrapbuffer(t, buf);
    hdr.numblocks := bufferlength(buf); (* hdr.numrecs := bufferlength(buf); *)
    if old then begin
      result := readheader(hdr.msgnum, oldhdr);
      if (result <> ok) then begin
        writetext := result;
        exit;
      end; {if}
    end else oldhdr.numblocks := 0;

    {$i-}
    if (not old) or (hdr.numblocks > oldhdr.numblocks) then
      hdr.startblock := filesize(qf[qtxt])      {need more, was numrecs }
    else
      hdr.startblock := oldhdr.startblock;   {rec := block}
    {$i+}

    {$i-} seek(qf[qtxt], hdr.startblock); {$i+}
    result := ioresult;
    if (result <> ok) then begin
      writetext := result;
      exit;
    end; {if}

    step := buf.first;
    while (step <> nil) do begin
      fillchar(line, sizeof(line), 0);
      line := step^.line^;
      {$i-} blockwrite(qf[qtxt], line, 1); {$i+}
      result := ioresult;
      if (result <> ok) then begin
        writetext := result;
        exit;
      end; {if}
      step := step^.next;
    end; {while}

    deletebuffer(buf);

    writetext := ok;
  end; {writetext}

{- write to echomail.bbs or netmail.bbs -}



  function updatetosslog(num: integer;  echom, delete: boolean): integer;
  const name: array[boolean] of string[12]=('netmail.bbs', 'echomail.bbs');
  var
    result, pos: integer;
    f: file;
    toss: tossarrayptr;
    size, alloc: word;
  begin
    result := open(f, name[echom], 1, true, true);
    if (result <> ok) then begin
      updatetosslog := result;
      exit;
    end; {if}

    size := filesize(f);
    alloc := size;
    if alloc <> 0 then
      getmem(toss, alloc)
    else
      toss := nil;

    if (toss <> nil) then begin
      {$i-} blockread(f, toss^, size); {$i+}
      pos := size div 2 - 1;
      while (pos >= 0) and (toss^[pos] <> num) do
        dec(pos);
    end else pos := -1;

    if delete then begin
      if (pos >= 0) then begin
        if (size-pos*2 > 2) then
          move(toss^[pos+1], toss^[pos], size-pos*2-2);   {delete}
        {$i-} seek(f, 0); {$i+}
        dec(size, 2);
        {$i-} blockwrite(f, toss^, size); {$i+}
        {$i-} truncate(f); {$i+}
      end; {if}
    end else begin
      if (pos < 0) then begin
        {$i-} seek(f, filesize(f)); {$i+}        {to end}
        {$i-} blockwrite(f, num, 2); {$i+}
        inc(size, 2);
      end; {if}
    end; {if}

    if (toss <> nil) then freemem(toss, alloc);

    result := ioresult;
    {$i-} close(f); {$i+}
    {$i-} if (size = 0) then erase(f); {$i+}
    updatetosslog := ioresult;
  end; {updatetosslog}



  procedure asctime(var time: timestr;  var date: datestr);
  type numstr = string[8];
  var
    hour, min, sec, sec100, year, month, day, dayofweek: word;

  function padnum(num: word): numstr;
    var temp: numstr;
    begin
      str(num:2, temp);
      if temp[1]=' ' then temp[1] := '0';
      padnum := temp;
    end; {padnum}

  begin
    gettime(hour, min, sec, sec100);
    getdate(year, month, day, dayofweek);
    time := padnum(hour)+':'+padnum(min);
    date := padnum(month)+'-'+padnum(day)+'-'+padnum(year mod 100);
  end; {asctime}




  procedure createnewheader(
    var hdr: msghdrrecord;  whofrom, whoto: namestring;
    subj: subjstring;  brd: byte;  typ: msgtype
  );
  begin
    fillchar(hdr, sizeof(hdr), 0);
    hdr.msgnum := msginfo.highmsg+1;
    hdr.whofrom := whofrom;
    hdr.whoto := whoto;
    hdr.subject := subj; { subject ipv subj }
    asctime(hdr.posttime, hdr.postdate);
    hdr.board := brd;
    hdr.msgattr := byte(defaultmsgattr[typ]);
    hdr.netattr := byte(defaultnetattr[typ]);
  end; {createnewheader}

{- update a header before re-writing (changing) a message -}

procedure changeheader(var hdr: msghdrrecord);
  begin
    asctime(hdr.posttime, hdr.postdate);

    if m_netm in msgattrs(hdr.msgattr) then begin               {is netmail}
      msgattrs(hdr.msgattr) := msgattrs(hdr.msgattr) + [m_transit];
    end else
      if not (m_local in msgattrs(hdr.msgattr)) then begin      {not local}
        msgattrs(hdr.msgattr) := msgattrs(hdr.msgattr) + [m_echotr]; {is echom}
      end; {else}

    netattrs(hdr.netattr) := netattrs(hdr.netattr) - [n_sent];
  end; {changeheader}




  function writemessage(var hdr: msghdrrecord;  var t: textbuffer): integer;
  var
    result: integer;
    fmsg: integer;
    oldmsg: boolean;
  begin
    fmsg := filemsg(hdr.msgnum);

    oldmsg := (fmsg <> -1);
    if not oldmsg then
      fmsg := msgidx.len;               {next message index}

    result := writetoidx(fmsg, hdr.whoto);
    if (result <> ok) then begin
      writemessage := result;
      exit;
    end; {if}

    if not oldmsg then begin
      result := incmsginfo(hdr.board);
      if (result <> ok) then begin
        writemessage := result;
        exit;
      end; {if}
    end; {if}

    result := writemsgidx(fmsg, hdr.msgnum, hdr.board);
    if (result <> ok) then begin
      writemessage := result;
      exit;
    end; {if}

    result := writetext(hdr, t, oldmsg);
    if (result <> ok) then begin
      writemessage := result;
      exit;
    end; {if}

    result := writeheader(hdr);
    if (result <> ok) then begin
      writemessage := result;
      exit;
    end; {if}

    if m_netm in msgattrs(hdr.msgattr) then begin               {is netmail}
      result := updatetosslog(fmsg, false, false);
    end else
      if not (m_local in msgattrs(hdr.msgattr)) then begin      {not local}
        result := updatetosslog(fmsg, true, false);               {is echom}
      end; {else}
    if (result <> ok) then begin
      writemessage := result;
      exit;
    end; {if}

    writemessage := ok;
  end; {writemessage}

function readtext(var hdr: msghdrrecord; var t: textbuffer): integer;
  var
    line: msgtxtrecord;
    count: word;
    result: integer;
  begin
    newbuffer(t);

    {$i-} seek(qf[qtxt], hdr.startblock); {$i+}  { block ipv rec }
    result := ioresult;
    if (result <> ok) then begin
      readtext := result;
      exit;
    end; {if}

    for count := 1 to hdr.numblocks do begin  { numblocks ipv numrecs }
      {$i-} blockread(qf[qtxt], line, 1); {$i+}
      result := ioresult;
      if (result <> ok) then begin
        deletebuffer(t);
        readtext := result;
        exit;
      end; {if}
      addtoend(t, line);
    end; {for}

    readtext := ok;
  end; {readtext}

{- update msgtoidx.bbs if the message is received -}

function checkrcvd(var hdr: msghdrrecord): integer;
  var
    fmsg, result: integer;
    s, t: namestring;

  begin
    checkrcvd := ok;
    if (username='') or (m_rcvd in msgattrs(hdr.msgattr)) then exit;
                                        {already received or n/a}
    checkrcvd := -1;
    fmsg := filemsg(hdr.msgnum);
    if (fmsg = -1) then exit;

    s := upper(username);
    t := upper(hdr.whoto);
    t[0] := s[0];               {truncate t to s's length}

    if (s = t) then begin       {is addressed to current user, mark rcvd}
      msgattrs(hdr.msgattr) := msgattrs(hdr.msgattr) + [m_rcvd];
      result := writeheader(hdr);
      if (result <> ok) then begin
        checkrcvd := result;
        exit;
      end; {if}

      result := writetoidx(fmsg, '* Received *');        {flag it for quickbbs}
      if (result <> ok) then begin
        checkrcvd := result;
        exit;
      end; {if}
    end; {if}

    checkrcvd := ok;
  end; {checkrcvd}



{- read a message -}

  function readmessage(
  msgno: integer; var hdr: msghdrrecord; var t: textbuffer
): integer;
  var
    result: integer;
  begin
    result := readheader(msgno, hdr);
    if (result <> ok) then begin
      readmessage := result;
      exit;
    end; {if}

    result := readtext(hdr, t);
    if (result <> ok) then begin
      readmessage := result;
      exit;
    end; {if}

    result := checkrcvd(hdr);
    if (result <> ok) then begin
      readmessage := result;
      exit;
    end; {if}

    if (msgno > highmsgread) then
      msgno := highmsgread;

    readmessage := ok;
  end; {readmessage}

{-
  search through a board in msgtoidx.bbs for a name
  starts at msgnum and stops at the last message in the board
  returns zero result if there was no error and -1 or an ioresult if there was
  an error.
  if there was no error (i.e. 0 was returned) then msgnum can be examined to
  determine if a message to the named person was found.  if msgnum = -1 then
  no message was found, else a message was found and msgnum is the number of
  the found message.
-}


  function searchto(
    board: byte;  var msgnum: integer;  name: namestring
  ): integer;
  var
    fmsg, result: integer;
    get: namestring;

  {- read from msgtoidx.bbs, can be used to find mail addressed to a user
     note:  uses a header record number, not a message number -}

  function readtoidx(fmsg: integer;  var msgto: msgtoidxrecord): integer;
    var result: integer;
    begin
      {$i-} seek(qf[qtoidx], fmsg); {$i+}
      result := ioresult;
      if (result <> ok) then begin
        readtoidx := result;
        exit;
      end; {if}

      {$i-} blockread(qf[qtoidx], msgto, 1); {$i+}
      readtoidx := ioresult;

    end; {readtoidx}

  begin
    name := upper(name);
    repeat
      searchto := 0;
      if (msgnum = -1) then exit;       {return "no error" and "not found"}
      searchto := -1;
      fmsg := filemsg(msgnum);
      if fmsg = -1 then exit;           {return "error -1"}
      result := readtoidx(fmsg, get);
      if (result <> ok) then begin      {return "error IOresult"}
        searchto := result;
        exit;
      end; {if}
      get := upper(get);
      get[0] := name[0];                {truncate get to name's length}

      searchto := 0;                    {return "no error" and "found"}
      if (get = name) then exit;        {found it, msgnum is number}

      msgnum := msgnext(board, msgnum);
    until false;
  end; {searchto}

{- delete a message -}

function msgdelete(msgnum: integer): integer;
  label error;
  var
    result, fmsg: integer;
    board: byte;
    hdr: msghdrrecord;

{- set the deleted bit in msghdr.bbs.  return false iff error, result is set -}

  function setdeletedbit(var hdr: msghdrrecord): boolean;
    begin
      setdeletedbit := false;
      result := readheader(msgnum, hdr);
      if (result <> ok) then exit;

      if not (m_del in msgattrs(hdr.msgattr)) then begin
        msgattrs(hdr.msgattr) := msgattrs(hdr.msgattr)+[m_del];
        result := writeheader(hdr);
        if (result <> ok) then exit;
      end; {if}

      setdeletedbit := true;
    end; {setdeletedbit}

  function updatelinks(var hdr: msghdrrecord): boolean;
  {- this code could be bettered, it creates weird links sometimes -}
    var
      nto, nfrom:  word;
      tohdr, fromhdr: msghdrrecord;

    begin
      updatelinks := false;
      nto := hdr.nextreply; (* nto := hdr.replyto; *)
      nfrom := hdr.prevreply;

      if (nto <> 0) then
        if (readheader(nto, tohdr) <> ok) then
          nto := 0;

      if (nfrom <> 0) then
        if (readheader(nfrom, fromhdr) <> ok) then
          nfrom := 0;

      fromhdr.nextreply := nto;
      tohdr.prevreply := nfrom;

      if (nto <> 0) then begin
        result := writeheader(tohdr);
        if (result <> ok) then exit;
      end; {if}

      if (nfrom <> 0) then begin
        result := writeheader(fromhdr);
        if (result <> ok) then exit;
      end; {if}

      updatelinks := true;
    end; {updatelinks}

  function updatemsginfo: boolean;
    begin
      updatemsginfo := false;
      dec(msginfo.totalmsgs);  (* totalactive);  *)
      dec(msginfo.totalonboard[board]); (* activemsgs[board]); *)
      if (msgnum = msginfo.lowmsg) then
        inc(msginfo.lowmsg);            {not too good}

      {$i-} seek(qf[qinfo], 0); {$i+}
      {$i-} blockwrite(qf[qinfo], msginfo, 1); {$i+}
      result := ioresult;
      updatemsginfo := (result = ok);
    end; {updatemsginfo}

  begin
    fmsg := filemsg(msgnum);
    result := -1;
    if (fmsg = -1) then goto error;

    board := msgidx.idx^[fmsg].board;

    if not setdeletedbit(hdr) then goto error;  {result is set inside}
    if not updatelinks(hdr) then goto error;

    result := writemsgidx(fmsg, -1, 0);
    if (result <> ok) then goto error;

    if not updatemsginfo then goto error;

    result := writetoidx(fmsg, '* Deleted *');
    if (result <> ok) then goto error;

    if m_netm in msgattrs(hdr.msgattr) then begin               {is netmail}
      result := updatetosslog(fmsg, false, true);
    end else
      if not (m_local in msgattrs(hdr.msgattr)) then begin      {not local}
        result := updatetosslog(fmsg, true, true);                {is echom}
      end; {else}
    {result falls through}

  error:
    msgdelete := result;

  end; {msgdelete}





  procedure setbbspath(path: pathstr);
  var dir: string;
  begin
    if (path='') then begin getdir(0, dir); path := dir end; {if}
    bbspath := fexpand(path);
    if (bbspath[length(bbspath)] <> '\') then bbspath := bbspath + '\';
  end; {setbbspath}



  procedure setuserspath(path: pathstr);
  var dir: string;
  begin
    if (path='') then begin getdir(0, dir); path := dir end; {if}
    userspath := fexpand(path);
    if (userspath[length(userspath)] <> '\') then userspath := userspath + '\';
  end; {setbbspath}



  procedure setusersupport(name: namestring;  lastread, current: boolean);
  begin
    username := name;
    usernum := 0;
    highmsgread := 0;
    uselastread := lastread;
    usecurrent := current;
  end; {setusersupport}



  procedure setdefaults;
  begin
    setbbspath('');           {default to current directory}
    setuserspath('');         {default to current directory}
    setusersupport('', false, false); {users.bbs off, lastread and current off}
  end; {setdefaults}



var
  oldexitproc: pointer;



{$F+}
  procedure cleanup;
  var dummy: integer;
  begin
    exitproc := oldexitproc;
    if msgbaseopened then
      dummy := closemsgbase;
  end; {cleanup}



begin
  setdefaults; oldexitproc := exitproc; exitproc := @cleanup;
end.