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 / TUTL.PQS / TUTL.PAS
Pascal/Delphi Source File  |  2000-06-30  |  13KB  |  504 lines
  1. { TUTL.PAS - Turbo Bulletin Board System utility program }
  2.  
  3. program tutl;
  4.  
  5. {$C-}
  6.  
  7. {$I TBBSHDR.INC}
  8. {$I ACCESS.BOX}
  9. {$I GETKEY.BOX}
  10. {$I ADDKEY.BOX}
  11. {$I DELKEY.BOX}
  12. {$I TBBSCOM.INC}
  13.  
  14. var
  15.   prt: boolean;
  16.  
  17. procedure print(line: StdStr);
  18. { Print line on screen or printer }
  19. begin
  20.   if prt
  21.     then writeln(LST, line)
  22.     else writeln(line)
  23. end;
  24.  
  25. procedure print_user;
  26. { Print the "user" file }
  27. var
  28.   i: integer;
  29.   t: tad_array;
  30.   st: StdStr;
  31. begin
  32.   if prt
  33.     then
  34.       begin
  35.         GetTAD(t);
  36.         st := systad(t);
  37.         print(^L + 'User file as of: ' + st);
  38.         print('')
  39.       end
  40.     else ClrScr;
  41.   ClearKey(IdxF);
  42.   repeat
  43.     NextKey(IdxF, i, st);
  44.     if OK
  45.       then
  46.         begin
  47.           GetRec(DatF, i, user_rec);
  48.           print(user_rec.user_firstname + ' ' + user_rec.user_lastname +
  49.             ' from ' + user_rec.user_address + ' last on ' +
  50.             systad(user_rec.user_laston))
  51.         end
  52.   until (not OK) or brk;
  53.   if not prt
  54.     then pause
  55. end;
  56.  
  57. procedure print_unvalidated;
  58. { Print the unvalidated users }
  59. var
  60.   i: integer;
  61.   t: tad_array;
  62.   st: StdStr;
  63. begin
  64.   if prt
  65.     then
  66.       begin
  67.         GetTAD(t);
  68.         st := systad(t);
  69.         print(^L + 'Unvalidated users as of: ' + st);
  70.         print('')
  71.       end
  72.     else ClrScr;
  73.   ClearKey(IdxF);
  74.   repeat
  75.     NextKey(IdxF, i, st);
  76.     if OK
  77.       then
  78.         begin
  79.           GetRec(DatF, i, user_rec);
  80.           if user_rec.user_bbs_stat = 0
  81.             then print(user_rec.user_firstname + ' ' + user_rec.user_lastname +
  82.               ' from ' + user_rec.user_address + ' last on ' +
  83.               systad(user_rec.user_laston))
  84.         end
  85.   until (not OK) or brk;
  86.   if not prt
  87.     then pause
  88. end;
  89.  
  90. procedure print_caller;
  91. { Print the "caller" file }
  92. var
  93.   t: tad_array;
  94.   st: StdStr;
  95.   nclr_file: file of calr_list;
  96. begin
  97.   if prt
  98.     then
  99.       begin
  100.         GetTAD(t);
  101.         st := systad(t);
  102.         print(^L + 'Caller file as of: ' + st);
  103.         print('')
  104.       end
  105.     else ClrScr;
  106.   seek(calr_file, 1);
  107.   while (not EOF(calr_file)) and (not brk) do
  108.     begin
  109.       read(calr_file, calr_rec);
  110.       GetRec(DatF, calr_rec.calr_num, user_rec);
  111.       print(systad(calr_rec.calr_tad) + '  ' +
  112.         user_rec.user_firstname + ' ' + user_rec.user_lastname);
  113.     end;
  114.   if ask('Do you want to reset the caller file')
  115.     then
  116.       begin
  117.         writeln('Resetting ', calr_name, ext);
  118.         assign(nclr_file, calr_name + '$$$');
  119.         rewrite(nclr_file);
  120.         seek(calr_file, 0);
  121.         read(calr_file, calr_rec);
  122.         write(nclr_file, calr_rec);
  123.         close(calr_file);
  124.         close(nclr_file);
  125.         erase(calr_file);
  126.         rename(nclr_file, calr_name + ext);
  127.         reset(calr_file)
  128.       end
  129. end;
  130.  
  131. procedure print_messages;
  132. { Print the "message" file }
  133. var
  134.   i: integer;
  135.   t: tad_array;
  136.   st: StdStr;
  137.   to_fn, fr_fn: firstname;
  138.   to_ln, fr_ln: lastname;
  139. begin
  140.   if prt
  141.     then
  142.       begin
  143.         GetTAD(t);
  144.         st := systad(t);
  145.         print(^L + 'Message file as of: ' + st);
  146.         print('')
  147.       end
  148.     else ClrScr;
  149.   seek(summ_file, 1);
  150.   while (not EOF(summ_file)) and (not brk) do
  151.     begin
  152.       read(summ_file, summ_rec);
  153.       with summ_rec do
  154.         begin
  155.           if summ_to_num = mesg_pub
  156.             then
  157.               begin
  158.                 to_fn := 'ALL';
  159.                 to_ln := ''
  160.               end
  161.           else if summ_to_num = mesg_era
  162.             then
  163.               begin
  164.                 to_fn := 'MESSAGE';
  165.                 to_ln := 'ERASED'
  166.               end
  167.             else
  168.               begin
  169.                 GetRec(DatF, summ_to_num, user_rec);
  170.                 to_fn := user_rec.user_firstname;
  171.                 to_ln := user_rec.user_lastname
  172.              end;
  173.           GetRec(DatF, summ_from_num, user_rec);
  174.           fr_fn := user_rec.user_firstname;
  175.           fr_ln := user_rec.user_lastname;
  176.           st := systad(summ_date);
  177.           print('Message number ' + intstr(summ_num) + ' entered ' + st + '.');
  178.           print('From: ' + fr_fn + ' ' + fr_ln);
  179.           print('  To: ' + to_fn + ' ' + to_ln);
  180.           print('  Re: ' + summ_subject);
  181.           seek(mesg_file, summ_st_rec);
  182.           for i := 1 to summ_size do
  183.             begin
  184.               read(mesg_file, mesg_rec);
  185.               print(mesg_rec.mesg_text)
  186.             end;
  187.           if prt
  188.             then print('')
  189.             else
  190.               begin
  191.                 pause;
  192.                 ClrScr
  193.               end
  194.         end
  195.     end
  196. end;
  197.  
  198. procedure pack_messages;
  199. { Pack the message files }
  200. var
  201.   i: integer;
  202.   nsum_rec  :         summ_list;
  203.   nsum_file : file of summ_list;
  204.   nmsg_rec  :         mesg_list;
  205.   nmsg_file : file of mesg_list;
  206. begin
  207.   write('Packing');
  208.   assign(nsum_file, summ_name + '$$$');
  209.   assign(nmsg_file, mesg_name + '$$$');
  210.   rewrite(nsum_file);
  211.   rewrite(nmsg_file);
  212.   seek(summ_file, 0);
  213.   read(summ_file, summ_rec);      { copy message counter to new file }
  214.   write(nsum_file, summ_rec);
  215.   while not EOF(summ_file) do
  216.     begin
  217.       read(summ_file, summ_rec);
  218.       if summ_rec.summ_to_num <> mesg_era
  219.         then
  220.           begin
  221.             seek(mesg_file, summ_rec.summ_st_rec);
  222.             summ_rec.summ_st_rec := filesize(nmsg_file);
  223.             write(nsum_file, summ_rec);
  224.             for i := 1 to summ_rec.summ_size do
  225.               begin
  226.                 read(mesg_file, mesg_rec);
  227.                 write(nmsg_file, mesg_rec)
  228.               end
  229.           end
  230.     end;
  231.   close(summ_file);
  232.   close(mesg_file);
  233.   close(nsum_file);
  234.   close(nmsg_file);
  235.  
  236.   erase(summ_file);
  237.   erase(mesg_file);
  238.   rename(nsum_file, summ_name + ext);
  239.   rename(nmsg_file, mesg_name + ext);
  240.  
  241.   reset(summ_file);
  242.   reset(mesg_file)
  243. end;
  244.  
  245. procedure display_user;
  246. var
  247.   st: StdStr;
  248. begin
  249.   ClrScr;
  250.   with user_rec do
  251.     begin
  252.       writeln('Name     : ', user_firstname, ' ', user_lastname);
  253.       writeln('Address  : ', user_address);
  254.       writeln('Password : ', user_pw);
  255.       writeln('Max drive: ', user_maxdrv);
  256.       writeln('Max user : ', user_maxusr);
  257.       writeln('Sys Stat : ', user_sys_stat);
  258.       writeln('BBS Stat : ', user_bbs_stat);
  259.       writeln('Nulls    : ', user_nulls);
  260.       writeln('U/L case : ', user_case_sw);
  261.       st := systad(user_laston);
  262.       writeln('Last on  : ', st);
  263.       writeln('On today : ', user_time_today);
  264.       writeln('On total : ', user_time_total);
  265.       writeln('Last hi  : ', user_lasthi);
  266.       writeln('Uploads  : ', user_up);
  267.       writeln('Downloads: ', user_down)
  268.     end;
  269.   gotoxy(1, 22)
  270. end;
  271.  
  272. procedure change_user;
  273.  
  274. procedure accept(x, y: integer; var st: StdStr; len: integer; mode: StdStr);
  275. begin
  276.   GotoXY(x, y);
  277.   getstring(st, len, 'E' + mode)
  278. end;
  279.  
  280. begin { change_user }
  281.   with user_rec do
  282.     begin
  283.       accept(12,  2, st, len_ad, '');
  284.       if st <> ''
  285.         then user_address := st;
  286.       accept(12,  3, st, len_pw, 'S');
  287.       if st <> ''
  288.         then user_pw := st;
  289.       accept(12,  4, st, 1, '');
  290.       if st <> ''
  291.         then user_maxdrv := strint(st);
  292.       accept(12,  5, st, 1, '');
  293.       if st <> ''
  294.         then user_maxusr := strint(st);
  295.       accept(12,  6, st, 1, '');
  296.       if st <> ''
  297.         then user_sys_stat := strint(st);
  298.       accept(12,  7, st, 1, '');
  299.       if st <> ''
  300.         then user_bbs_stat := strint(st);
  301.       accept(12,  8, st, 1, '');
  302.       if st <> ''
  303.         then user_nulls := strint(st);
  304.       accept(12,  9, st, 2, '');
  305.       if st <> ''
  306.         then user_case_sw := strint(st);
  307.       accept(12, 11, st, 2, '');
  308.       if st <> ''
  309.         then user_time_today := strint(st);
  310.       accept(12, 12, st, 7, '');
  311.       if st <> ''
  312.         then user_time_total := strint(st);
  313.       accept(12, 13, st, 7, '');
  314.       if st <> ''
  315.         then user_lasthi := strint(st);
  316.       accept(12, 14, st, 3, '');
  317.       if st <> ''
  318.         then user_up := strint(st);
  319.       accept(12, 15, st, 3, '');
  320.       if st <> ''
  321.         then user_down := strint(st)
  322.     end
  323. end;
  324.  
  325. procedure edit_user;
  326. var
  327.   st, key: StdStr;
  328. begin
  329.   writeln;
  330.   fn := prompt('First name: ', len_fn, 'ES');
  331.   ln := prompt(' Last name: ', len_ln, 'ES');
  332.   key := pad(ln, len_ln) + pad(fn, len_fn);
  333.   FindKey(IdxF, user_loc, key);
  334.   if OK
  335.     then
  336.       begin
  337.         GetRec(DatF, user_loc, user_rec);
  338.         display_user;
  339.         while ask('Edit this user') do
  340.           begin
  341.             change_user;
  342.             display_user
  343.           end;
  344.         PutRec(DatF, user_loc, user_rec)
  345.       end
  346.     else
  347.       begin
  348.         writeln('User not found');
  349.         delay(2000)
  350.       end
  351. end;
  352.  
  353. procedure delete_user;
  354. var
  355.   key: StdStr;
  356. begin
  357.   writeln;
  358.   fn := prompt('First name: ', len_fn, 'ES');
  359.   ln := prompt(' Last name: ', len_ln, 'ES');
  360.   if ask('Delete')
  361.     then
  362.       begin
  363.         key := pad(ln, len_ln) + pad(fn, len_fn);
  364.         DeleteKey(IdxF, user_loc, key);
  365.         if OK
  366.           then DeleteRec(DatF, user_loc)
  367.           else
  368.             begin
  369.               writeln('User not found');
  370.               delay(2000)
  371.             end
  372.       end
  373. end;
  374.  
  375. procedure purge_user;
  376. var
  377.   age, mon: integer;
  378.   t: tad_array;
  379.   st: StdStr;
  380. begin
  381.   writeln;
  382.   GetTAD(t);
  383.   age := strint(prompt('Allowable age [months]: ', 10, 'E'));
  384.   user_loc := 1;
  385.   while user_loc < FileLen(DatF) do
  386.     begin
  387.       GetRec(DatF, user_loc, user_rec);
  388.       mon := t[4] - user_rec.user_laston[4];
  389.       if t[5] > user_rec.user_laston[5]
  390.         then mon := mon + 12;
  391.       if (user_rec.user_used = 0) and ((mon > age) or ((mon = age)
  392.         and (t[3] > user_rec.user_laston[3])))
  393.         then
  394.           begin
  395.             writeln('Deleting ', user_rec.user_firstname, ' ',
  396.               user_rec.user_lastname);
  397.             st := pad(user_rec.user_lastname, len_ln) +
  398.               pad(user_rec.user_firstname, len_fn);
  399.             DeleteKey(IdxF, user_loc, st);
  400.             DeleteRec(DatF, user_loc)
  401.           end;
  402.       user_loc := user_loc + 1
  403.     end;
  404.   pause
  405. end;
  406.  
  407. begin { main }
  408.   writeln(version);
  409.   bel := FALSE;
  410.   prt := FALSE;
  411.   fini := FALSE;
  412.  
  413.   InitIndex;
  414.   OpenFile(DatF, user_data + ext, SizeOf(user_rec));
  415.   if OK
  416.     then OpenIndex(IdxF, user_indx + ext, len_ln + len_fn, 0);
  417.   if not OK
  418.     then
  419.       begin
  420.         write(^G, 'User files missing.  Creating ', user_data, ext);
  421.         MakeFile(DatF, user_data + ext, SizeOf(user_rec));
  422.         writeln(', ', user_indx, ext);
  423.         MakeIndex(IdxF, user_indx + ext, len_ln + len_fn, 0)
  424.       end;
  425.  
  426.   assign(calr_file, calr_name + ext);
  427.   {$I-} reset(calr_file) {$I+};
  428.   OK := (IOresult = 0);
  429.   if not OK
  430.     then
  431.       begin
  432.         writeln(^G, 'Caller file missing.  Creating ', calr_name, ext);
  433.         rewrite(calr_file);
  434.         calr_rec.calr_num := 0;
  435.         write(calr_file, calr_rec)
  436.       end;
  437.  
  438.   assign(summ_file, summ_name + ext);
  439.   assign(mesg_file, mesg_name + ext);
  440.   {$I-} reset(summ_file) {$I+};
  441.   OK := (IOresult = 0);
  442.   if OK
  443.     then
  444.       begin
  445.         {$I-} reset(mesg_file) {$I+};
  446.         OK := (IOresult = 0)
  447.       end;
  448.   if not OK
  449.     then
  450.       begin
  451.         write(^G, 'Message files missing.  Creating ', summ_name, ext);
  452.         rewrite(summ_file);
  453.         summ_rec.summ_num := 0;
  454.         write(summ_file, summ_rec);
  455.         writeln(', ', mesg_name, ext);
  456.         rewrite(mesg_file)
  457.       end;
  458.  
  459.   repeat
  460.     ClrScr;
  461.     writeln('Turbo Bulletin Board System Utilities');
  462.     writeln;
  463.     write  ('  P: Printer (o');
  464.     if prt
  465.       then writeln('n)')
  466.       else writeln('ff)');
  467.     writeln;
  468.     writeln('  U: User list');
  469.     writeln('  N: uNvalidated user list');
  470.     writeln('  C: Caller list');
  471.     writeln('  M: Message list');
  472.     writeln;
  473.     writeln('  E: Edit user');
  474.     writeln('  D: Delete user');
  475.     writeln('  G: Purge users');
  476.     writeln;
  477.     writeln('  R: Repack messages');
  478.     writeln;
  479.     writeln('  Q: Quit');
  480.     writeln;
  481.     writeln(FileLen(DatF), ' records, ', UsedRecs(DatF), ' users in file.');
  482.     writeln;
  483.     st := prompt('Function: ', 1, 'AES');
  484.     case st[1] of
  485.       'P': prt := not prt;
  486.       'U': print_user;
  487.       'N': print_unvalidated;
  488.       'C': print_caller;
  489.       'M': print_messages;
  490.       'E': edit_user;
  491.       'D': delete_user;
  492.       'G': purge_user;
  493.       'R': pack_messages;
  494.       'Q': fini := TRUE;
  495.       else
  496.     end
  497.   until fini;
  498.   CloseFile(DatF);
  499.   CloseIndex(IdxF);
  500.   close(summ_file);
  501.   close(mesg_file);
  502.   close(calr_file)
  503. end.
  504.