{ TBBSCOM.INC - Turbo Bulletin Board System common subroutines }

var
  DatF: DataFile;
  IdxF: IndexFile;

procedure GetTAD(var t: tad_array); {** THIS ROUTINE IS SYSTEM DEPENDENT **}
{ Return a 6 element integer array of the current system time in
  seconds, minutes, hours, day, month, and year. }
var
  i: integer;
begin
  for i := 0 to 5 do
    t[i] := mem[i + $FF7C];
  t[3] := succ(t[3]);
  t[4] := succ(t[4])
end;

function intstr(n: integer): StdStr;
{ Convert integer to string }
var
  s: StdStr;
begin
  str(n, s);
  intstr := s
end;

function intstr0(n: integer): StdStr;
{ Convert integer to string - leading '0' }
var
  s: StdStr;
begin
  str(n, s);
  if (length(s) = 1)
    then s := '0' + s;
  intstr0 := s
end;

function strint(st: StdStr): integer;
{ Convert string to integer }
var
  x, code: integer;
begin
  if st[1] = '+'
    then delete(st, 1, 1);
  if st = ''
    then code := 1
    else val(st, x, code);
  if code = 0
    then strint := x
    else strint := maxint       {error, so return error}
end;

function zeller(day, month, year: integer): integer;
{ Compute the day of the week using Zeller's Congruence }
var
  century: integer;
begin
  if month > 2
    then month := month - 2
    else
      begin
        month := month + 10;
        year := year - 1
      end;
  century := year div 100;
  year := year mod 100;
  zeller := (day - 1 + ((13 * month - 1) div 5) + (5 * year div 4) +
            century div 4 - 2 * century + 1) mod 7;
end;

function systad(t: tad_array): StdStr;
{ Format the time and date }
const
  day: array [0..6] of string[6] =
    ('Sun','Mon','Tues','Wednes','Thurs','Fri','Satur');
  month: array [1..12] of string[3] =
    ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
begin
  if t[4] > 0
    then systad := intstr0(t[2]) + ':' + intstr0(t[1]) + '  ' +
      day[zeller(t[3], t[4], t[5] + 1900)] + 'day  ' +
      intstr(t[3]) + '-' + month[t[4]] + '-' + intstr0(t[5])
    else systad := ''
end;

procedure getkey(var ch: char; shiftlock: boolean);
{ Get key typed at keyboard, no echo }
begin
  read(kbd, ch);
  if eoln(kbd)
    then ch := CR
    else if shiftlock and (ch in ['a'..'z'])
      then ch := UpCase(ch)
end;

procedure getstring(var inpstr: StdStr; maxlen: integer; mode: StdStr);
{ Get a valid input string from the user }
const
  editset: charset = [BS, RUB, CAN, TAB];
  termset: charset = [LF, CR];
  dispset: charset = [' '..'~'];
var
  autotab, echo, shiftlock: boolean;
  ch: char;
  i, len: integer;
begin
  if maxlen > Max_Str                { ensure length of field is not too big }
    then maxlen := Max_Str;
  autotab   := (pos('A', mode) > 0);
  echo      := (pos('E', mode) > 0);
  shiftlock := (pos('S', mode) > 0);
  inpstr := '';
  len := 0;
  repeat
    getkey(ch, shiftlock);
    if (ch in dispset) and (len <= maxlen)
      then
        begin
          inpstr := inpstr + ch;
          if echo
            then write(ch)
        end
    else if ch = TAB
      then
        repeat
          inpstr := inpstr + ' ';
          if echo
            then write(' ')
        until (0 = length(inpstr) mod 8) or (length(inpstr) >= maxlen)
    else if ((ch = RUB) or (ch = BS)) and (len > 0)
      then
        begin
          delete(inpstr, len, 1);
          if echo
            then write(BS, ' ', BS)
        end
    else if ch = CAN
      then
        begin
          inpstr := '';
          if echo
            then for i := 1 to len do
                   write(BS, ' ', BS)
        end;
    len := length(inpstr)
  until (ch in termset) or ((len >= maxlen) and autotab)
        or ((ch = ' ') and (len >= (maxlen - 6)) and autotab);
  writeln
end;

function prompt(st: StdStr; len: integer; mode: StdStr): StdStr;
{ Prompt user and get response }
var
  reply: StdStr;
begin
  write(st);
  if bel
    then write(^G);
  getstring(reply, len, mode);
  prompt := reply
end;

function ask(st: StdStr): boolean;
{ Ask yes-or-no question and return 'true' for 'Y', 'false' otherwise }
begin
  writeln;
  ask := (prompt(st + ' [Y/N]? ', 1, 'AES') = 'Y')
end;

procedure pause;
{ Pause for user response before continuing }
var
  temp: StdStr;
begin
  writeln;
  temp := prompt('Press any key to continue', 1, 'A')
end;

function brk: boolean;
{ Check for break or pause. }
var
  ch: char;
begin
  brk := FALSE;
  if keypressed
    then
      begin
        read(Kbd, ch);
        if ch = ^C
          then brk := TRUE
        else if ch = ^S
          then
            repeat
            until keypressed
      end
end;

function trim(st: StdStr): StdStr;
{ Trim leading and trailing blanks }
var
 i, j: integer;
begin
  i := 1;
  j := length(st);
  while (st[i] = ' ') and (i <= j) do
    i := succ(i);
  while (st[j] = ' ') and (j >= i) do
    j := pred(j);
  trim := copy(st, i, j - i + 1)
end;

function pad(line: StdStr; i: integer): StdStr;
{ Pad line with spaces to length of i }
begin
  while length(line) < i do
    line := line + ' ';
  pad := line
end;

function find_user(fn: firstname; ln: lastname): integer;
{ Find location of user in user file.  Return -1 if not found. }
var
  i: integer;
begin
  st := pad(ln, len_ln) + pad(fn, len_fn);
  FindKey(IdxF, i, st);
  if OK
    then find_user := i
    else find_user := -1
end;

procedure get_user;
{ Get user data from disk }
begin
  GetRec(DatF, user_loc, user_rec);
  with user_rec do
    begin
      used       := user_used;
      fn         := user_firstname;
      ln         := user_lastname;
      ad         := user_address;
      pw         := user_pw;
      bbs_stat   := user_bbs_stat;
      maxdrv     := user_maxdrv;
      maxusr     := user_maxusr;
      status     := user_sys_stat;
      nulls      := user_nulls;
      case_sw    := user_case_sw;
      laston     := user_laston;
      time_today := user_time_today;
      time_total := user_time_total;
      lasthi     := user_lasthi;
      upload     := user_up;
      download   := user_down
    end
end;

procedure put_user;
{ Put user data to disk }
begin
  with user_rec do
    begin
      user_used       := used;
      user_firstname  := fn;
      user_lastname   := ln;
      user_address    := ad;
      user_pw         := pw;
      user_bbs_stat   := bbs_stat;
      user_maxdrv     := maxdrv;
      user_maxusr     := maxusr;
      user_sys_stat   := status;
      user_nulls      := nulls;
      user_case_sw    := case_sw;
      user_laston     := laston;
      user_time_today := time_today;
      user_time_total := time_total;
      user_lasthi     := lasthi;
      user_up         := upload;
      user_down       := download
    end;
  PutRec(DatF, user_loc, user_rec);
  CloseFile(DatF);           { in case user hangs up }
  OpenFile(DatF, user_data + ext, SizeOf(user_rec))
end;

procedure add_user;
{ Add dummy user record to disk }
begin
  AddRec(DatF, user_loc, user_rec);
  AddKey(IdxF, user_loc, st);
  CloseIndex(IdxF);          { in case user hangs up }
  CloseFile(DatF);
  InitIndex;                 { not documented, but seems necessary }
  OpenFile(DatF, user_data + ext, SizeOf(user_rec));
  if OK
    then OpenIndex(IdxF, user_indx + ext, len_ln + len_fn, 0)
end;