Oakland CPM Archive/oakcpm.iso/cpm/bbs/tpbbs10.ark/TPBS10.PAS

Pascal/Delphi Source File | 1986-09-14 | 13.3 KB | 591 lines

program TPBBS {BBS system in Pascal};

label
  loop10,loop;

type
  AllStrings=string[80];
  tagline=string[10];
  msgline=string[65];
  username=string[25];
  citystate=string[15];
  password=string[10];
  date=string[8];
  pswd=string[10];
  about=string[25];
  nameto=string[25];
  charset=set of char;
  datetime=string[18];

  userlist=record
      name:username;
      address:citystate;
      userpassword:password;
      lastmessage:integer;
      lastdate:datetime;
  end;

  stat_list=record
      msgs:integer;
      calls:integer;
      mstart:integer;
      mnum:integer;
  end;

  caller_list=record
      caller:username;
      cfrom:citystate;
      cdate:date;
      ctime:date;
  end;

  comment_list=record
      comment:msgline;
      end;

  summary_list=record
      msgnum:integer;
      person_from:username;
      person_to:nameto;
      subject:about;
      mdate:date;
      mpassword:pswd;
      no_of_lines:integer;
      msg_loc:integer;
  end;

  message_list=record
      msgtext:msgline;
  end;

const

{*************************************************}

{ User defined options }

  system='Osborne TPBBS';     {System name}
  drive1='A:';                {BYE.COM on this drive}
  drive2='A:';                {text,BBS stat files on this drive}
  drive3='A:';                {message system files on this drive}
  ext='';                     {Extension for BBS system files}
  syspass1='BOSACK';          {Immediate system access}
  syspass2='DRAWOH';          {Sysop's password}
  opencpm=false;              {CP/M access open or queried?}
  query='What is the CP/M access code?';
                              {CP/M access question}
  answer='BOSACK';               {CP/M access answer}
  clock=false;                 {Real-time clock/calendar avail.}

{*************************************************}

  version='TurboPascal BBS v1.0  c1984';
  date1='Original 30 APR 1984';
  alphaset:charset = [' '..'}'];  {Printable chars}

var
  summary_file:file of summary_list;
  summary_rec:summary_list;
  user_file:file of userlist;
  user_rec:userlist;
  stat_file:file of stat_list;
  stat_rec:stat_list;
  message_file:file of message_list;
  message_rec:message_list;
  caller_file:file of caller_list;
  caller_rec:caller_list;
  comment_file:file of comment_list;
  comment_rec:comment_list;
  comfile:file;
  chainfile:file;
  f1,f:text;
  laston,temp,temp2,pass1,pass2,city,pword,frtemp,qqstring,bstring,line1,pp,line:allstrings;
  pdate,ptime:string[8];
  save,temp3:msgline;
  filename:string[14];
  messbuff: array[1..15] of msgline;
  msghead: array[1..5] of msgline;
  lastname,firstname,whoto,subto,passto:allstrings;
  mfirst,mlast,message_pointer,rnum,knum,ls,gg,lmsgs,code,message,zz,flag,d,ff,sp,c,a,b,n,bi,bk,i,x,y,z,lento,lc,ln:integer;
  eflag:integer;
  timer:real;
  ok,page,brk,uppercase,xpr,bel,fflag:boolean;
  dd,option,aa: char;

procedure get_command; forward;
{$I TPFUNC.INC}
{$I TPMESG.INC}

procedure list_stats;
label skip;
begin
  assign(stat_file,drive2+'COUNTERS'+ext);
  reset(stat_file);
  read(stat_file,stat_rec);
  with stat_rec do
  begin
    if flag=4 then
      begin
        seek(stat_file,filepos(stat_file)-1);
        message_pointer:=msgs;
        msgs:=message_pointer;
        calls:=calls+1;
        mfirst:=mstart;
        mlast:=mnum;
        mstart:=mfirst;
        mnum:=mlast;
        write(stat_file,stat_rec);
        goto skip;
      end;
    if ls<>1 then
    begin
      line:='You were last on ='+laston;
      printstring;
      str(lmsgs,temp);
      line:='Last high message='+temp;
      printstring;
      end;
    str(msgs,temp);
    line:='Active # of msgs ='+temp;
    printstring;
    str(calls,temp);
    line:='You are caller # ='+temp;
    printstring;
    str(mnum+1,temp);
    line:='Next msg number  ='+temp;
    printstring;
  end;
skip:close(Stat_file);
end;

procedure do_command;
begin
case ff of

 1: begin
      uppercase:=not uppercase;
     end;

 2: begin
     filename:=drive2+'BULLETIN';
     prnttext;
    end;

 3: begin
     eflag:=1;
    end;

 4: begin
     filename:=drive2+'WELCOME';
     prnttext;
    end;

 5: begin
     goodbye;
    end;

 6: begin
     exit_to_cpm;
    end;

 7: begin
      prntuser;
     end;
 8: begin
      bel:=not bel;
     end;

 9: begin
      xpr:=not xpr;
     end;

 10: begin
      filename:=drive2+'OTHERSYS.LST';
      prnttext;
     end;

 11: begin
      list_stats;
     end;

 12: begin
      filename:=drive2+'TPMENU';
      prnttext;
     end;

end;
end;

procedure get_command;
label start;
begin
  start:line1:='Function:';
  if not xpr then
    line1:=line1+'A,B,M,W,G,C,U,P,X,O,(? for HELP)';
  line1:=line1+'?';
  n:=1;
  printstring;
  n:=0;
  ff:=0;
  c:=1;
  getstring;
  c:=0;
  if bstring='' then
    goto start;
  ff:=pos(bstring,'ABMWGCUPXOL?');
  if ff=0 then
    begin
      line:='I don'+''''+'t understand '+''''+bstring+''''+', '+firstname+'.';
      printstring;
      printstring;
      save:='';
      goto start;
    end;
end;

procedure login;
label loop,logcal,msgchk,match,skip,stop;
begin
  if not clock then
   begin
    line:='Date format example=>05/28/84';
    printstring;
    loop:line1:='Enter today''s date  (MM/DD/YY) =>';
    n:=1;printstring;n:=0;
    getstring;
    if bstring='' then goto loop;
    if length(bstring)<>8 then goto loop;
    if pos('/',bstring)=0 then goto loop;
    pdate:=bstring;
    ptime:=' ';
   end;
  if clock then
   begin
    getdate;
    gettime;
    line:='On at: '+ptime+'  '+pdate;
    printstring;
   end;
  line:='Logging your call to the disk, '+firstname+'....';
  printstring;

{Make a new LASTCALR file}
assign(f,drive2+'LASTCALR');
rewrite(f);
temp:=pdate+','+ptime+','+firstname+','+lastname;
writeln(f,temp);
close(f);

{Get user info and log his use}
 assign(user_file,drive2+'USER'+ext);
  reset(user_file);
  while not eof(user_file) do
   begin
    read(user_file,user_rec);
    with user_rec do
    begin
      if name=firstname+' '+lastname then
        begin
          seek(user_file,filepos(user_file)-1);
          name:=firstname+' '+lastname;
          address:=city;
          userpassword:=pword;
          laston:=lastdate;
          lastdate:=pdate+'  '+ptime;
          lmsgs:=lastmessage;
          lastmessage:=mlast;
          write(user_file,user_rec);
          goto logcal;
        end;
    end;
   end;
   seek(user_file,filesize(user_file));
   with user_rec do
   begin
     name:=firstname+' '+lastname;
     address:=city;
     userpassword:=pword;
     laston:=lastdate;
     lastdate:=pdate;
     lmsgs:=lastmessage;
     lastmessage:=mlast;
     write(user_file,user_rec);
   end;

{Log the caller}
logcal:
  close(user_file);
  assign(caller_file,drive2+'CALLERS'+ext);
  reset(caller_file);
  read(caller_file,caller_rec);
  with caller_rec do
   begin
    bstring:=caller;
    makenum;
    i:=x;
    seek(caller_file,filepos(caller_file)-1);
    x:=x+1;
    str(x,temp);
    caller:=temp;
    write(caller_file,caller_rec);
    seek(caller_file,i);
    caller:=firstname+' '+lastname;
    cfrom:=city;
    cdate:=pdate;
    ctime:=ptime;
    write(caller_file,caller_rec);
   end;
  close(caller_file);

{Check for messages}
msgchk:
fflag:=false;
close(user_file);
line:='Checking for messages...';
printstring;
assign(summary_file,drive3+'SUMMARY'+ext);
{$I-}
reset(summary_file);
{$I+}
if ioresult<>0 then goto stop;
while not eof(summary_file) do
 begin
  read(summary_file,summary_rec);
  with summary_rec do
   begin
    if msgnum<>0 then
     begin
      temp:=stupcase(person_to);
      if (firstname='SYSOP') and (pos('SYSOP',temp)<>0) then goto match;
      if temp<>firstname+' '+lastname then goto skip;
      match:
      str(msgnum,temp);
      pad(temp,4);
      line:=temp+': '+mdate+'  From >> '+person_from;
      printstring;
      fflag:=true;
      skip:
     end;
   end;
 end;
writeln;
if fflag then
 begin
  writeln;
  line:='Please Retrieve and Kill these messages.'+chr(7);
  printstring;
 end;
if not fflag then
 begin
  line:='No messages found.';
  printstring;
 end;
writeln;
close(summary_file);

stop:
end;

procedure newuser;
  label start,stop,passloop;
  begin
start:flag:=1;
    line:='Enter your City and State =>';
    n:=1;
    printstring;
    n:=0;
    getstring;
    city:=bstring;
    line:='You are '+firstname+' '+lastname+' from '+city;
    printstring;
    line:='Is that correct?';n:=1;
    printstring;
    getstring;
    bstring:=copy(bstring,1,1);
    bstring:=stupcase(bstring);
    if bstring<>'Y' then goto start;
    line:='As a new user of '+system+' you must enter';
    printstring;
    line:='a password of 4-10 characters. This is to ensure';
    printstring;
    line:='that no one else uses your name on the system.';
    printstring;
    passloop:
    line:='Please enter YOUR password now =>';
    n:=1;
    printstring;
    n:=0;
    c:=1;getstring;c:=0;
    temp2:=bstring;
    if (length(temp2)<4) or (length(temp2)>10) then
      begin
       line:='Invalid password entered!';
       printstring;
       line:='Please re-enter...';
       goto passloop;
      end;
    writeln(chr(12));
    line:='Now enter it again =>';n:=1;
    printstring;
    n:=0;
    c:=1;getstring;c:=0;
    if bstring<>temp2 then
     begin
      line:='No match. Try again.';
      printstring;
      goto passloop;
     end;
    pword:=bstring;
    filename:=drive2+'NEWUSER';
    prnttext;
    stop:if flag=1 then login;
  end;

procedure signon;
  label stop2,stop1,stop,getpassword,badpassword,loop1;
  begin
    firstname:='';save:='';
    loop1:line1:='Enter your FIRST name =>';n:=1;
    printstring;
    bstring:='';n:=1;
    getstring;
    firstname:=StUpCase(bstring);
    if firstname=pass1 then
      getcpm;
    if (length(firstname)<2) or (firstname<'A') then
      goto loop1;
    line:='   And your LAST name =>';n:=1;
    printstring;
    getstring;
    lastname:=StUpCase(bstring);
    if (firstname='SYSOP') and (lastname=pass2) then
      begin
        lastname:='';
        city:='';
        goto stop;
      end;
    if firstname='SYSOP' then goto loop1;
    if (length(lastname)<2) or (lastname<'A') then
      goto loop1;
    line:='Checking user file...';
    printstring;
    assign(user_file,drive2+'USER'+ext);
    reset(user_file);
    while not eof(user_file) do
      begin
        read(user_file,user_rec);
        with user_rec do
          begin
            if name<>firstname+' '+lastname then goto stop1;
            zz:=0;
            getpassword:line1:='Enter your password =>';
            n:=1;
            printstring;
            n:=0;
            c:=1;getstring;c:=0;
            if bstring<>userpassword then
              begin
                zz:=zz+1;
                if zz>2 then
                  begin
                    flag:=0;
                    goto badpassword;
                  end;
                goto getpassword;
              end;{if}
            pword:=bstring;
            city:=address;
          end;{with}
        goto stop;
      stop1:end; {WHILE}
  line:='Are you a new user ?';n:=1;
  printstring;
  getstring;
  bstring:=copy(bstring,1,1);
  bstring:=stupcase(bstring);
  if bstring<>'Y' then
    begin
      line:='OK let'+''''+'s try it again!';
      printstring;
      goto loop1;
    end;
  ls:=1;
  newuser;
  if flag=2 then goto loop1;
  goto stop;
  badpassword:line:='You have only three attempts to get the correct';
  close(user_file);
  printstring;
  line:='password. Since you have not been able to enter the';
  printstring;
  line:='proper password, your call is being terminated.';
  printstring;
  line:='Please try again later.';
  printstring;
  byebye;
  stop:close(user_file);
  if flag=1 then goto stop2;

login;
stop2:end;



begin

      {KILL CTRL-C}
  if mem[$80]=$FF then goto loop10;

  mem[0]:=$CD;

      {SET USER PARAMETERS}
  ln:=62;             {Line input length}
  page:=true;         {Paged output option}
  uppercase:=false;   {upper and lowercase on}
  xpr:=false;         {novice mode on}
  bel:=true;          {prompt bell on}
  pass1:=syspass1;
  pass2:=syspass2;
      {GET SYSOP'S PASSWORDS}
  filename:=drive2+'PASSWORD'+ext;
  assign(f,filename);
  {$I-}
  reset(f);
  {$I+}
  if ioresult=0 then  {if no file will skip this routine}
    begin
     readln(f,pass1,pass2);
     close(f);
    end;

      {BEGIN COMMUNICATING WITH REMOTE}
  writeln;
  writeln(version);
  writeln;
  writeln(system);
  writeln;
  filename:=drive2+'WELCOME'; {print WELCOME file}
  prnttext;
  flag:=4;
  list_stats;
  flag:=0;
  signon;                     {get user's name,etc}
  list_stats;                 {show status of messages}
  eflag:=0;
  loop10:
  while eflag=0 do
  begin
    get_command;              {goto function prompt}
    do_command;               {do that function until}
  end;
  while eflag>0 do
  begin
    get_mcommand;
    do_mcommand;
  end;
  goto loop10;                {user leaves the BBS}

end.
eflag>0 do
  begin