GEMini Atari/GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso/files/bbs/turbobbs/bbs.pas

Pascal/Delphi Source File | 1985-08-24 | 18.0 KB | 684 lines

program TurboBBS100;

(*******************************************************************)
(*                                                                 *)
(*  Turbo Bulletin Board System    -    Distribution Version 1.00  *)
(*                                                                 *)
(*  (c) 1985 by Robert H. Maxwell                                  *)
(*              201 - 2275 West 7th Avenue,                        *)
(*              Vancouver, British Columbia, CANADA                *)
(*              V6K 1Y3                                            *)
(*  Original System running 300/1200 baud, 24hrs: [phone]   *)
(*  Written for a Kaypro 2-84 using Rixon 212A Intelligent modem   *)
(*                                                                 *)
(*  If you like this program, it would most appreciated if you     *)
(*  sent $30 to the above address. If you choose to operate a BBS  *)
(*  with it, please forward the details so you can be kept up to   *)
(*  date with changes to the program.                              *)
(*                                                                 *)
(*  Files required for compile: BBS.PAS    (this file),            *)
(*                              IO.INC     (machine dependent I/O) *)
(*                              CLOCK.INC  (real-time clock I/O)   *)
(*                              MAILSYS.INC (Sections named here)  *)
(*                              FILESYS.INC (XMODEM code here)     *)
(*                                                                 *)
(*  Information files required: WELCOME.TXT (pre-sign-on message)  *)
(*                              BBSLIST.TXT (list of other BBS's)  *)
(*                              BBSHELP.TXT (command explanation)  *)
(*                              SYSINFO.TXT (info on the system)   *)
(*  Message #1 is a permanent / MESS0001.TXT (Message Help file)   *)
(*  message... do not delete! \ MESSAGES.BBS (Message table)       *)
(*                              FILES.BBS   (Files table)          *)
(*  Clear these periodically: / COMMENTS.BBS (Comments for Sysop)  *)
(*  They can grow quickly...  \ LOG.BBS     (call log file)        *)
(*                              IDS.BBS     (user list)            *)
(*                                                                 *)
(*  .TXT files are WordStar editable; .BBS files are program data  *)
(*  maintained by the program.                                     *)
(*  User SYSOP is predeclared on IDS file: the password is TURBO   *)
(*                                                                 *)
(*******************************************************************)

const
  clockin = true;  { Compile-time flags:          }
  sectsin = true;  { Use to turn features on/off. }

  noecho    = false;
  echo      = true;
  null      = #0;
  abort     = #3;
  bell      = #7;
  bksp      = #8;
  tab       = #9;
  lnfd      = #10;
  cr        = #13;
  pause     = #19;
  esc       = #27;
  space     = ' ';

type
  name      = string[14];
  rate      = (slow,fast);
  line      = string[80];
  person    = string[27];
  long      = string[150];
  sysid     = record
                user: person;
                exfl: byte;
                lsto: name;
                lstm: integer;
                pass: name;
                acc:  byte;
                clr:  name;
                bsp:  char;
                lnf:  char;
                upc:  boolean;
                wid:  byte;
              end;
  log       = record
                who:  integer;
                when: name;
                done: name;
              end;
  yesno     = array[boolean] of string[3];

const yn: yesno = ('NO','YES');

var
  logfile:    file of log;
  logrec:     log;
  idfile:     file of sysid;
  idrec:      sysid;
  usernum:    integer;
  caller:     person;
  password,
  timeon,
  timeoff,
  cs,
  message:    name;
  baud:       rate;
  buffer:     long;
  exitchar:   char;
  access:     byte;
  lastmess,
  charcount,
  lastspace,
  bufpointer,
  width:      integer;
  controls,
  printon,
  local,
  filesopen,
  messopen,
  caps,
  expert:     boolean;
  bl, lf, bs: char;
  sec,   onsec,   offsec   : byte;
  min,   onmin,   offmin   : byte;
  hour,  onhour,  offhour  : byte;
  date,  ondate,  offdate  : byte;
  month, onmonth, offmonth : byte;
  usesec, usemin, usehour  : integer;

{$I IO.INC}
{$I CLOCK.INC}

procedure outfile(fname: name);

  var
    wfile : text;
    fchar : char;

  begin
    assign(wfile,fname);
    {$I-} reset(wfile) {$I+};
    if IOresult <> 0 then lineout('Can''t find ' + fname + '!') else begin
      clearsc;
      repeat
        read(wfile, fchar);
        if fchar <> #$8D then begin { <-- Allows no-wrap using WordStar files}
          fchar := chr(ord(fchar) and 127);
          if fchar <> lnfd then charout(fchar);
          if fchar = cr then charout(lf);
        end;
      until cancelled or eof(wfile) or not cts;
      close(wfile);
      unload;
    end;
  end;

function findid(caller: person): integer;

  var
    usernum: integer;
    index: integer;

  begin
    usernum := 0;
    index := 0;
    lineout('Searching userlist...');
    reset(idfile);
    if not eof(idfile) then begin
      repeat
        index := index + 1;
        read(idfile, idrec);
        if idrec.user = caller then usernum := index;
      until (usernum > 0) or eof(idfile);
    end;
    findid := usernum;
  end;

{$I MAILSYS.INC}
{$I FILESYS.INC}

procedure definecs;

  var
    ch: char;
    prompt: line;

  begin
    ch := null;
    while cts and not (ch in ['Q','Y']) do begin
      lineout('The following input is NOT echoed until CR (RETURN) is pressed!');
      prompt := 'Enter character(s) that will clear your screen (end with CR): ';
      controls := true;
      cs := getinput(prompt, 11, noecho);
      controls := false;
      clearsc;
      ch := getcap(cr + lf + 'Did that do it (Y/N/Quit)? ');
    end;
    if ch = 'Q' then cs := lnfd;
  end;

procedure definebs;

  begin
    repeat
      flush;
      controls := true;
      stringout('Type your backspace key: ');
      bs := charin(echo);
      controls := false;
      lineout(space);
    until not ((bs in [cr, tab, space, '0'..'9', 'A'..'Z', 'a'..'z']) and cts);
  end;

procedure setwidth;

  var temp: name;
      test, innum: integer;

  begin
    repeat
      temp := getinput('Enter your terminal width (chars/line): ', 14, echo);
      val(temp, innum, test);
    until ((test=0) and (innum in [22..132])) or (temp='') or not cts;
    if test = 0 then width := innum;
  end;

procedure setvideo;

  var loop: byte;
      inch: char;
      temp: name;

  function ctlchar(ch: char): name;

    begin
      if ch > #127 then ch := chr(ord(ch) and 127);
      case ch of
        null..#31   : ctlchar := '^' + chr(ord(ch) + 64);
        space..#126 : ctlchar := ch;
        #127        : ctlchar := '<DEL>';
      end;
    end;

  procedure dispcontrol(ch: char);

    begin
      if ch < #128 then stringout(ctlchar(ch))
        else stringout(ctlchar(ch) + '(with 8th bit set)');
    end;

  begin
    inch := '1';
    while (inch in ['1'..'9']) and cts do begin
      clearsc;
      lineout('Terminal parameters:' + cr + lf);
      lineout('1 - Upper case only: ' + yn[caps]);
      lineout('2 - Line feeds sent: ' + yn[lf = lnfd]);
      lineout('3 - Prompt bell ON : ' + yn[bl = bell]);
      stringout('4 - Backspace char.: ');
      dispcontrol(bs);
      lineout(space);
      stringout('5 - Clear Screen   : ');
      for loop := 1 to length(cs) do dispcontrol(cs[loop]);
      lineout(space);
      str(width:3, temp);
      lineout('6 - Terminal width : ' + temp);
      lineout(space);
      inch := getcap('Enter number of parameter to change (0 to quit): ');
      case inch of
        '1': caps := not caps;
        '2': if lf = lnfd then lf := null else lf := lnfd;
        '3': if bl = bell then bl := null else bl := bell;
        '4': definebs;
        '5': definecs;
        '6': setwidth;
      end;
    end;
    lineout('New definitions will be saved when [G]oodbye is executed.');
  end;

procedure getcomments;

  var
    comfile: file of line;
    linenum: integer;
    temp:    line;

  begin
    clearsc;
    lineout('Enter comment: up to 15 lines, enter empty line to quit.');
    lineout(space);
    linenum := 0;
    assign(comfile, 'COMMENTS.BBS');
    reset(comfile);
    seek(comfile, filesize(comfile));
    temp := caller;
    if clockin then temp := temp + '  ' + timeon;
    write(comfile, temp);
    repeat
      linenum := linenum + 1;
      str(linenum:2, temp);
      stringout(temp + ': ');
      temp := inputstring(echo);
      if temp <> '' then write(comfile, temp);
    until (temp = '') or (linenum = 15) or not cts;
    close(comfile);
  end;

function nextuser: integer;

  var temp: integer;

  begin
    stringout('Finding space for new user: ');
    temp := findid('***');
    if temp = 0 then nextuser := 1 + filesize(idfile) else nextuser := temp;
  end;

procedure savedefaults;

  begin
    if usernum = 0 then usernum := nextuser;
    with idrec do begin
      user := caller;
      if expert then exfl := 0 else exfl := 255;
      if clockin then lsto := timeon;
      lstm := messtable[count].number;
      pass := password;
      clr := cs;
      acc := access;
      bsp := bs;
      lnf := lf;
      upc := caps;
      wid := width;
    end;
    seek(idfile, usernum - 1);
    write(idfile, idrec);
  end;

procedure disconnect;

  var
    ch: char;

  begin
    clearsc;
    lineout('Answering question with other than "Y" or "N" returns to BBS:');
    ch := getcap('Do you want to leave comments to the Sysop (Y/N)? ');
    if ch = 'Y' then getcomments;
    if (ch = 'N') or (ch = 'Y') or not cts then begin
      connecttime;
      lineout('Thanks for calling, ' + caller);
      savedefaults;
      hangup;
    end;
  end;

procedure chat;

  var
    count  : byte;
    inch   : char;

  begin
    inch := null;
    clearsc;
    lineout('Entering chat mode: CTL-C aborts at any time.');
    lineout('Summoning Sysop...');
    flush;
    count := 1;
    repeat
      count := count + 1;
      charout(bell);
      delay(1000);
      if inready then inch := charin(noecho);
    until (count > 10) or (inch <> null);
    while cts and (inch <> abort) do begin
      inch := charin(echo);
      if inch = cr then sendout(lf);
    end;
  end;

procedure newpass;

  var
    temp   : name;
    prompt : line;

  begin
    repeat
      prompt := 'Enter the password you want on this system: ';
      password := allcaps(getinput(prompt, 14,noecho));
      prompt := cr + lf + 'Enter it again, to be sure: ';
      temp := allcaps(getinput(prompt, 14, noecho));
    until (temp = password) or not cts;
    lineout('New password is saved when the [G]oodbye command is executed.');
  end;

procedure listusers;

  var
    tempid: sysid;
    inch:   name;

  begin
    if cts then begin
      clearsc;
      reset(idfile);
      repeat
        read(idfile,tempid);
        if access = 5 then begin
          str(tempid.acc:1, inch);
          stringout(inch + '  ');
        end;
        lineout(tempid.user);
      until eof(idfile) or cancelled or not cts;
      unload;
    end;
  end;

procedure userlog;

  var
    call:   person;
    loop:   integer;

  begin
    if cts then begin
      clearsc;
      reset(logfile);
      while cts and (not cancelled) and not eof(logfile) do begin
        read(logfile,logrec);
        if logrec.who < 1 then call := ('Not on userlist')
          else call := getname(logrec.who);
        if clockin then for loop := length(call)+1 to 25 do call := call+space;
        stringout(call);
        if clockin then stringout(logrec.when + ' to ' + logrec.done);
        lineout(space);
      end;
      if access = 5 then begin
        if getcap('Kill (Y/N)? ') = 'Y' then rewrite(logfile);
      end;
      close(logfile);
      unload;
    end;
  end;

procedure sysoponly;

  var
   inch : char;
   number: integer;
   temp: name;
   comment: line;
   comfile: file of line;

  begin
    if cts then begin
      clearsc;
      assign(comfile, 'COMMENTS.BBS');
      reset(comfile);
      while cts and (not cancelled) and not eof(comfile) do begin
        read(comfile,comment);
        lineout(comment);
      end;
      if getcap('Kill (Y/N)? ') = 'Y' then rewrite(comfile);
      close(comfile);
      unload;
    end;
    repeat
      number := getid('User name? ');
      if number > 0 then begin
        str(idrec.acc:2, temp);
        lineout('Access:' + temp);
        inch := getinput('New level? ', 1, echo);
        if inch in ['0'..'5'] then idrec.acc := integer(inch) - integer('0');
        reset(idfile);
        seek(idfile, number - 1);
        write(idfile, idrec);
        unload;
      end;
    until number = 0;
  end;

procedure menu;

  begin
    if cts then begin
      cancelled := false;
      lineout(cr + lf + 'Information files:');
      lineout('[H]elp...... user[L]og... [O]thersys.. [U]serlist.. [W]elcome... s[Y]sinfo...');
      lineout(cr + lf + 'Message system:');
      lineout('[E]nter..... [K]ill...... [R]ead...... [S]can...... [#]:Status..');
      lineout(cr + lf + 'Functions:');
      lineout('[C]hat...... [F]iles..... [G]oodbye... [I]nstall... [P]assword.. e[X]pert....');
    end;
  end;

procedure command;

  var
    prompt: line;
    inch  : char;
    first : boolean;

  begin
    first := true;
    while cts do begin
      if first and not expert then menu;
      prompt := cr + lf + 'Command: ';
      if not expert
        then prompt := prompt + 'C,E,F,G,H,I,K,L,O,P,R,S,U,W,X,Y,# ? '
        else prompt := prompt + '(? for menu) ? ';
      flush;
      inch := getcap(prompt);
      first := true;
      case inch of
        'K': deletex;
        'E': enter;
        'R': receive;
        'S': quickscan;
        '#': begin status; showtime; connecttime; first := false; end;
        'I': setvideo;
        'F': filesys;
        'G': disconnect;
        'H': outfile('BBSHELP.TXT');
        'Y': outfile('SYSINFO.TXT');
        'W': outfile('WELCOME.TXT');
        '?': if expert then menu;
        'X': begin expert := not expert; first := false; end;
        'C': chat;
        'U': listusers;
        'L': userlog;
        'O': outfile('BBSLIST.TXT');
        'P': newpass;
        '@': if access=5 then sysoponly else first := false;
        '!': if access=5 then printon := not printon else first := false;
        else first := false;
      end; {case}
    end; {while cts}
  end; {command}

procedure enterpass;

  var
    temp:  name;
    tries: byte;

  begin
    tries := 0;
    lineout(space);
    repeat
      if tries > 0 then stringout('Incorrect - try again: ');
      tries := tries + 1;
      temp := allcaps(getinput('Enter your password: ', 14, noecho));
    until (temp = idrec.pass) or (tries = 3) or not cts;
    if (temp <> idrec.pass) then hangup;
  end;

procedure getdefaults;

  begin
    enterpass;
    if cts then begin
      with idrec do begin
        password := pass;
        expert := (exfl = 0);
        access := acc;
        cs := clr;
        bs := bsp;
        lf := lnf;
        caps := upc;
        width := wid;
        lastmess := lstm;
        if clockin then lineout('Last on: ' + lsto);
      end;
    end;
  end;

procedure newuser;

  begin
    lineout(cr + lf + 'Getting new user password & terminal info:');
    if cts then begin
      newpass;
      setvideo;
      access := 1;
    end;
  end;

procedure signon(var caller: person);

  var ch: char;

  begin
    ch := space;
    repeat
      repeat
        caller := allcaps(getinput('What is your full name? ', 28, echo));
      until (length(caller) > 4) or not cts;
      if cts then begin
        usernum := findid(caller);
        if usernum=0 then ch:=getcap(caller + ': is this correct (Y/N)? ');
      end;
    until (usernum > 0) or (ch = 'Y') or not cts;
    if cts then begin
      if usernum = 0 then newuser else getdefaults;
      dispcaller;
      if access = 0 then begin
        lineout('User ' + caller + ' has been denied system access.');
        hangup;
      end;
    end;
  end;

procedure logcall;

  begin
    reset(logfile);
    seek(logfile, filesize(logfile));
    with logrec do begin
      who := usernum;
      if clockin then begin
        when := timeon;
        done := timeoff;
      end;
    end;
    write(logfile, logrec);
    close(logfile);
  end;

procedure defaults;

  begin
    lf := lnfd;
    bl := null;
    cs := lnfd;
    bs := bksp;
    expert := false;
    caps := false;
    width := 80;
    access := 1;
    assign(idfile, 'IDS.BBS');
    assign(logfile, 'LOG.BBS');
    lastmess := 0;
    caller := space;
    usernum := 0;
    messopen := false;
    filesopen := false;
    printon := false;
    inbuffer := '';
    cancelled := false;
    controls := false;
  end;

begin
  exitchar := space;
  local := false;
  resetbuff;
  setup;
  defaults;
  awaitcall;
  repeat
    if clockin then begin
      clock(onmonth, ondate, onhour, onmin, onsec);
      timeon := time(onmonth, ondate, onhour, onmin, onsec);
      showtime;
    end;
    flush;
    if cts then outfile('WELCOME.TXT');
    if cts then signon(caller);
    if cts then initmess;
    if cts and (usernum > 0) then begin
      lineout('Checking for mail...');
      messagesearch(1,0,usernum,0);
    end;
    if cts then command;
    writeln('hung up...');
    if clockin then begin
      clock(offmonth, offdate, offhour, offmin, offsec);
      timeoff := time(offmonth, offdate, offhour, offmin, offsec);
    end;
    logcall;
    if messopen then closemess;
    close(idfile);
    unload;
    defaults;
    awaitcall;
  until exitchar = abort;
end.
əəəəəəə