home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / TBBS22.LBR / TBBS.PQS / TBBS.PAS
Pascal/Delphi Source File  |  2000-06-30  |  11KB  |  421 lines
  1. { TBBS.PAS - Turbo Bulletin Board System }
  2.  
  3. program tbbs;
  4.  
  5. {$C-}
  6.  
  7. {$I TBBSHDR.INC}
  8. {$I ACCESS.BOX}
  9. {$I GETKEY.BOX}
  10. {$I ADDKEY.BOX}
  11. {$I TBBSCOM.INC}
  12. {$I TBBSMSG.INC}
  13.  
  14. procedure list(st: char);
  15. { List a portion of the system message file }
  16. var
  17.   line: StdStr;
  18. begin
  19.   writeln;
  20.   Reset(sysm_file);
  21.   repeat
  22.     readln(sysm_file, line)
  23.   until (EOF(sysm_file)) or ((line[1] = ':') and (line[2] = st));
  24.   repeat
  25.     readln(sysm_file, line);
  26.     if line[1] <> ':'
  27.       then writeln(line)
  28.   until (EOF(sysm_file)) or (line[1] = ':') or (brk);
  29.   Close(sysm_file)
  30. end;
  31.  
  32. procedure get_name;
  33. { Get user name }
  34. const
  35.   st: StdStr = 'Name must have at least two characters.';
  36. begin
  37.   repeat
  38.     fn := trim(prompt('FIRST name: ', len_fn, 'ES'));
  39.     if length(fn) < 2
  40.       then writeln(st)
  41.   until length(fn) >= 2;
  42.   if (fn = 'SYSOP')
  43.     then ln := ''
  44.     else
  45.       repeat
  46.         ln := trim(prompt(' LAST name: ', len_ln, 'ES'));
  47.         if length(ln) < 2
  48.           then writeln(st)
  49.       until length(ln) >= 2
  50. end;
  51.  
  52. procedure get_password(var valid: boolean);
  53. { Accept and validate password.  Everyone gets 'max_tries' to get their
  54.   password right.  If it is still wrong they will be logged out. }
  55. var
  56.   tries: integer;
  57.   temp: StdStr;
  58. begin
  59.   tries := 1;
  60.   repeat
  61.     temp := prompt('  Password: ', Max_Str, 'S');
  62.     tries := tries + 1
  63.   until (temp = pw) or (tries > Max_Tries);
  64.   if temp = pw
  65.     then valid := TRUE                 { valid password }
  66.     else
  67.       begin
  68.         writeln('Only ', Max_Tries, ' tries allowed.');
  69.         list('F');
  70.         valid := FALSE                 { forgetful user }
  71.       end
  72. end;
  73.  
  74. procedure get_nulls_and_case;
  75. { Get nulls and case switch from user }
  76. var
  77.   st: StdStr;
  78. begin
  79.   repeat
  80.     st := prompt('How many nulls do you need [0-9]? ', 1, 'AE');
  81.     nulls := strint(st[1])
  82.   until (nulls >= 0) and (nulls <= 9);
  83.   if ask('Can your terminal display lower case')
  84.     then case_sw := 0
  85.     else case_sw := 32;
  86.   if bye
  87.     then
  88.       begin
  89.         mem[bye_base + 3] := nulls;
  90.         mem[bye_base + 4] := case_sw
  91.       end
  92. end;
  93.  
  94. procedure get_new_user(var continue: boolean);
  95. { Get new user information }
  96. var
  97.   i: integer;
  98.   temp: StdStr;
  99. begin
  100.   continue := FALSE;
  101.   list('P');
  102.   writeln;
  103.   if ask('Are you a new user')
  104.     then
  105.       begin
  106.         get_nulls_and_case;
  107.         ad := prompt('From what CITY and STATE are you calling: ', len_ad, 'E');
  108.         writeln;
  109.         writeln('You are ', fn, ' ', ln, ' from ', ad);
  110.         writeln;
  111.         if ask('Is that correct')
  112.           then
  113.             begin
  114.               writeln;
  115.               writeln('Please select and enter a password of 4-', len_pw, ' characters');
  116.               writeln('to ensure that no one else uses your name on the system.');
  117.               writeln;
  118.               repeat
  119.                 repeat
  120.                   temp := prompt('Password (will NOT display as you type): ', Max_Str, 'S');
  121.                   i := length(temp);
  122.                   if (i < 4) or (i > len_pw)
  123.                     then writeln('Length must be 4-', len_pw, ' characters.');
  124.                 until (4 <= i) and (i <= len_pw);
  125.                 pw := prompt('        Please enter it again to verify: ', Max_Str, 'S');
  126.                 if pw <> temp
  127.                   then writeln('No match.  Try again.');
  128.               until pw = temp;
  129.               writeln;
  130.               writeln('Your password will be required for all future calls.');
  131.               writeln('Please remember it.');
  132.               used        := 0;
  133.               bbs_stat    := def_sta;
  134.               maxdrv      := def_drv;
  135.               maxusr      := def_usr;
  136.               status      := def_sta;
  137.               for i := 0 to 5 do
  138.                 laston[i] := 0;
  139.               time_today  := 0;
  140.               time_total  := 0;
  141.               lasthi      := 0;
  142.               upload      := 0;
  143.               download    := 0;
  144.               continue := TRUE;
  145.               list('I');
  146.               pause;
  147.               list('D');
  148.               pause
  149.             end
  150.       end
  151. end;
  152.  
  153. procedure init_user;
  154. var
  155.   i, caller, mon, hon, old_lasthi: integer;
  156.   t: tad_array;
  157.   this_st, last_st: StdStr;
  158. begin
  159.   GetTAD(t);
  160.   if (t[3] <> laston[3]) or (t[4] <> laston[4]) or (t[5] <> laston[5])
  161.     then time_today := 0;
  162.   mon := t[1] - (time_today mod 60); { effective login time := actual - time_today }
  163.   hon := t[2] - (time_today div 60);
  164.   if mon < 0
  165.     then
  166.       begin
  167.         mon := mon + 60;
  168.         hon := hon - 1;
  169.         if hon < 0
  170.           then hon := hon + 24
  171.       end;
  172.   this_st := systad(t);
  173.   last_st := systad(laston);
  174.   laston := t;
  175.   mem[bye_base + 0] := maxusr;
  176.   mem[bye_base + 1] := maxdrv;
  177.   mem[bye_base + 3] := nulls;
  178.   mem[bye_base + 4] := case_sw;
  179.   mem[$3D] := maxdrv;
  180.   mem[$3F] := maxusr;
  181.   mem[$50] := hon;
  182.   mem[$51] := mon;
  183.   mem[$53] := status;
  184.   mem[$54] := 0;
  185.   mem[$55] := 0;
  186.   if fn = 'SYSOP'
  187.     then
  188.       begin
  189.         mem[$3E] := $FF;
  190.         for i := 0 to 6 do
  191.           mem[$48 + i] := path[i]
  192.       end;
  193.   list('B');            { Give 'em something to read while we update the disk }
  194.  
  195.   reset(calr_file);
  196.   read(calr_file, calr_rec);
  197.   seek(calr_file, 0);
  198.   calr_rec.calr_num := calr_rec.calr_num + 1;
  199.   caller := calr_rec.calr_num;
  200.   calr_rec.calr_tad := t;
  201.   write(calr_file, calr_rec);
  202.   seek(calr_file, filesize(calr_file));
  203.   calr_rec.calr_num := user_loc;
  204.   write(calr_file, calr_rec);
  205.   Close(calr_file);
  206.  
  207.   rewrite(lclr_file);
  208.   writeln(lclr_file, fn, ',', ln);
  209.   Close(lclr_file);
  210.  
  211.   mesg_build_index;
  212.   old_lasthi := lasthi;
  213.   if MesgBase = nil
  214.     then lasthi := 0
  215.     else lasthi := MesgLast^.MesgNo;
  216.  
  217.   put_user;
  218.  
  219.   writeln;
  220.   writeln('Caller number                : ', caller);
  221.   writeln('Last on system               : ', last_st);
  222.   writeln('High message (then/now)      : ', old_lasthi, '/', lasthi);
  223.   writeln('Msgs waiting (public/private): ', msg_all, '/', msg_ind);
  224. {
  225.   writeln('Access time (today/total)    : ', time_today, '/', time_total);
  226.   writeln('File (upload/download)       : ', upload, '/', download);
  227. }
  228.   writeln;
  229.   writeln('Login at ', this_st)
  230. end;
  231.  
  232. procedure login(var fini: boolean);
  233. { Log user into system }
  234. var
  235.   valid, continue: boolean;
  236. begin
  237.   list('W');
  238.   writeln;
  239.   repeat
  240.     get_name;
  241.     user_loc := find_user(fn, ln);
  242.     if user_loc = -1
  243.       then
  244.         begin
  245.           valid := TRUE;
  246.           get_new_user(continue);
  247.           if continue
  248.             then add_user
  249.         end
  250.       else
  251.         begin
  252.           continue := TRUE;
  253.           get_user;
  254.           get_password(valid)
  255.         end
  256.   until continue;
  257.   if valid
  258.     then init_user;
  259.   fini := not valid
  260. end;
  261.  
  262. procedure restart(var fini: boolean);
  263. { Restart previous user }
  264. var
  265.   i: integer;
  266.   st: StdStr;
  267. begin
  268.   reset(lclr_file);
  269.   readln(lclr_file, st);
  270.   Close(lclr_file);
  271.   i := pos(',', st);
  272.   fn := copy(st, 1, i - 1);
  273.   ln := copy(st, i + 1, length(st) - i);
  274.   user_loc := find_user(fn, ln);
  275.   get_user;
  276.   mesg_build_index;
  277.   writeln('Welcome back, ', fn, '.');
  278.   fini := FALSE
  279. end;
  280.  
  281. procedure alter_nulls_and_case;
  282. { Alter nulls and case }
  283. begin
  284.   get_nulls_and_case;
  285.   put_user
  286. end;
  287.  
  288. procedure display_users;
  289. { Display "user" file }
  290. var
  291.   i: integer;
  292.   user_rec: user_list;
  293. begin
  294.   writeln;
  295.   ClearKey(IdxF);
  296.   repeat
  297.     NextKey(IdxF, i, st);
  298.     if OK
  299.       then
  300.         begin
  301.           GetRec(DatF, i, user_rec);
  302.           if (user_rec.user_firstname <> 'SYSOP') and (user_rec.user_bbs_stat > 0)
  303.             then writeln(user_rec.user_firstname, ' ', user_rec.user_lastname)
  304.         end
  305.   until (not OK) or brk
  306. end;
  307.  
  308. procedure exit_to_system(var fini: boolean);
  309. { Exit to system }
  310. var
  311.   t: tad_array;
  312. begin
  313.   if (maxusr > 0) and (bbs_stat > 0)
  314.     then
  315.       begin
  316.         list('E');
  317.         mem[0] := $C3;                 { Clear trap }
  318.         fini := TRUE
  319.       end
  320.     else list('D')
  321. end;
  322.  
  323. procedure goodbye(var fini: boolean);
  324. { Update statistics and log user off system }
  325. var
  326.   t: tad_array;
  327.   hon, mon: integer;
  328. begin
  329.   if ask('Would you like to leave a comment to the sysop')
  330.     then mesg_enter(TRUE);
  331.   GetTAD(t);
  332.   hon := t[2] - mem[$50];
  333.   if hon < 0
  334.     then hon := hon + 24;
  335.   mon := 60 * hon + t[1] - mem[$51];
  336.   if mon < 0
  337.     then mon := mon + 60;
  338.   laston := t;
  339.   time_total := time_total + mon - time_today;
  340.   time_today := mon;
  341.   upload := upload + mem[$54];
  342.   download := download + mem[$55];
  343.   {$I-} erase(lclr_file) {$I+};
  344.   OK := (IOresult = 0);
  345.   put_user;
  346.   list('L');
  347.   fini := TRUE
  348. end;
  349.  
  350. begin { main }
  351. {
  352.  Table of accessible parameters in BYE
  353.  
  354.  |mxusr|mxdrv|toval|nulls|ulcsw|lfeeds|wrtloc|hardon|lostflg|covect| 'BYE'|
  355.  |1 byt|1 byt|1 byt|1 byt|1 byt|1 byte|1 byte|1 byte|1 byte |2 byte|3 byte|
  356.  | +0  | +1  | +2  | +3  | +4  | +5   | +6   | +7   | +8    | +9   | +11  |
  357. }
  358.   bye_base := 256 * mem[2] + mem[1] - 2;                 { Cold boot address }
  359.   bye_base := 256 * mem[bye_base + 1] + mem[bye_base] + 6;   { Table address }
  360.   bye := 'BYE' = chr(mem[bye_base + 11]) + chr(mem[bye_base + 12]) + chr(mem[bye_base + 13]);
  361.   bye_start := mem[$5D] = 0;           { Look to see how we got started }
  362.   bel := FALSE;                        { Prompt bell initially off }
  363.  
  364.   writeln(version);
  365.   if bye                               { Running under BYE? }
  366.     then
  367.       begin
  368.         mem[0] := $CD;                 { Set disconnect trap }
  369.         BDOS(14, 0);                   { Set drive and user }
  370.         BDOS(32, 0);
  371.       end;
  372.  
  373.   InitIndex;                           { Get files ready for use }
  374.   OpenFile(DatF, user_data + ext, SizeOf(user_rec));
  375.   if OK
  376.     then OpenIndex(IdxF, user_indx + ext, len_ln + len_fn, 0);
  377.   assign(summ_file, summ_name + ext);
  378.   reset(summ_file);
  379.   assign(mesg_file, mesg_name + ext);
  380.   reset(mesg_file);
  381.   assign(calr_file, calr_name + ext);
  382.   assign(lclr_file, lclr_name + ext);
  383.   assign(sysm_file, sysm_name + ext);
  384.  
  385.   if bye and (not bye_start)
  386.     then restart(fini)
  387.     else login(fini);
  388.   if fini
  389.     then goodbye(fini)
  390.     else
  391.       repeat                           { Main command acceptor/dispatcher }
  392.         st := '?';
  393.         writeln;
  394.         st := prompt('Function (? for MENU): ', 1, 'AES');
  395.         case st[1] of
  396.           'A': alter_nulls_and_case;
  397.           'B': list('B');
  398.           'C': exit_to_system(fini);
  399.           'E': mesg_enter(FALSE);
  400.           'G': goodbye(fini);
  401.           'H': list('H');
  402.           'I': list('I');
  403.           'K': mesg_read;
  404.           'N': list('N');
  405.           'O': list('O');
  406.           'P': bel := not bel;
  407.           'Q': mesg_quick_scan;
  408.           'R': mesg_read;
  409.           'S': mesg_summary;
  410.           'U': display_users;
  411.           'W': list('W')
  412.           else list('M')
  413.         end;
  414.       until fini;
  415.  
  416.   CloseFile(DatF);
  417.   CloseIndex(IdxF);
  418.   Close(summ_file);
  419.   Close(mesg_file)
  420. end.
  421.