home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FORUM25C.ZIP / BSPONSR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-02-06  |  12.8 KB  |  511 lines
  1. {=============================================================================}
  2.  
  3.   Procedure boardsponsor;
  4.  
  5.     Procedure getbgen (txt:mstr; VAR q);
  6.     VAR s:lstr absolute q;
  7.     begin
  8.       writeln (^B'Current ',txt,': ',s);
  9.       buflen:=30;
  10.       writestr ('Enter new '+txt+':');
  11.       if length(input)>0 then s:=input
  12.     end;
  13.  
  14.     Procedure getbint (txt:mstr; VAR i:integer);
  15.     VAR a:anystr;
  16.     begin
  17.       a:=strr(i);
  18.       getbgen (txt,a);
  19.       i:=valu(a);
  20.       writecurboard
  21.     end;
  22.  
  23.     Procedure getbstr (txt:mstr; VAR q);
  24.     begin
  25.       getbgen (txt,q);
  26.       writecurboard
  27.     end;
  28.  
  29.     Procedure setacc (ac:accesstype; un:integer);
  30.     VAR u:userrec;
  31.     begin
  32.       seek (ufile,un);
  33.       read (ufile,u);
  34.       setuseraccflag (u,curboardnum,ac);
  35.       seek (ufile,un);
  36.       write (ufile,u)
  37.     end;
  38.  
  39.     Function queryacc (un:integer):accesstype;
  40.     VAR u:userrec;
  41.     begin
  42.       seek (ufile,un);
  43.       read (ufile,u);
  44.       queryacc:=getuseraccflag (u,curboardnum)
  45.     end;
  46.  
  47.     Procedure setnameaccess;
  48.     VAR un,n:integer;
  49.         ac:accesstype;
  50.         q,unm:mstr;
  51.     begin
  52.       writestr (^M'Change access for user:');
  53.       un:=lookupuser(input);
  54.       if un=0 then begin
  55.         writeln ('No such user!');
  56.         exit
  57.       end;
  58.       unm:=input;
  59.       ac:=queryacc(un);
  60.       writeln (^B^M'Current access: ',accessstr[ac]);
  61.       getacflag (ac,q);
  62.       if ac=invalid then exit;
  63.       if un=unum then writeurec;
  64.       setacc (ac,un);
  65.       if un=unum then readurec;
  66.       case ac of
  67.         letin:n:=1;
  68.         keepout:n:=2;
  69.         bylevel:n:=3
  70.       end;
  71.       writelog (5,n,unm)
  72.     end;
  73.  
  74.     Procedure setallaccess;
  75.     VAR cnt:integer;
  76.         ac:accesstype;
  77.         q:mstr;
  78.     begin
  79.       writehdr ('Set Everyone''s Access');
  80.       getacflag (ac,q);
  81.       if ac=invalid then exit;
  82.       writeurec;
  83.       setallflags (curboardnum,ac);
  84.       readurec;
  85.       writeln ('Done.');
  86.       writelog (5,4,accessstr[ac])
  87.     end;
  88.  
  89.     Procedure listaccess;
  90.  
  91.       Procedure listacc (all:boolean);
  92.       VAR cnt:integer;
  93.           a:accesstype;
  94.           u:userrec;
  95.  
  96.         Procedure writeuser;
  97.         begin
  98.           if all
  99.             then
  100.               begin
  101.                 tab (u.handle,30);
  102.                 if a=bylevel
  103.                   then writeln ('Level='+strr(u.level))
  104.                   else writeln ('Let in')
  105.               end
  106.             else writeln (u.handle)
  107.         end;
  108.  
  109.       begin
  110.         seek (ufile,1);
  111.         for cnt:=1 to numusers do begin
  112.           read (ufile,u);
  113.           a:=getuseraccflag (u,curboardnum);
  114.           case a of
  115.             letin:writeuser;
  116.             bylevel:if all and (u.level>=curboard.level) then writeuser
  117.           end;
  118.           if break then exit
  119.         end
  120.       end;
  121.  
  122.     begin
  123.       writestr (
  124. 'List A)ll users who have access, or only those with S)pecial access? *');
  125.       if length(input)=0 then exit;
  126.       case upcase(input[1]) of
  127.         'A':listacc (true);
  128.         'S':listacc (false)
  129.       end
  130.     end;
  131.  
  132.     Procedure getblevel;
  133.     VAR Post:bulrec;
  134.     begin
  135.       getbint ('level',curboard.level);
  136.       writelog (5,12,strr(curboard.level))
  137.     end;
  138.  
  139.     Procedure getautodel;
  140.     VAR Post:bulrec;
  141.     begin
  142.       with curboard do begin
  143.         getbint ('auto-delete',autodel);
  144.         if autodel<10
  145.           then
  146.             begin
  147.               writeln (^B'HEY!  It can''t be less than ten!');
  148.               autodel:=numbuls+1;
  149.               if autodel<10 then autodel:=10;
  150.               writeln (^B'Setting autodelete to ',autodel);
  151.               writecurboard
  152.             end
  153.           else
  154.             if autodel<=numbuls
  155.               then
  156.                 begin
  157.                   writeln (^B'Deleting bulletins...');
  158.                   while autodel<=numbuls do delbul (2,true)
  159.                 end
  160.       end;
  161.       writelog (5,11,strr(curboard.autodel))
  162.     end;
  163.  
  164.     Procedure getfiletitle;
  165.     VAR fn:integer;
  166.         f:filerec;
  167.     begin
  168.       fn:=getfilenumber ('change the title of');
  169.       if fn<>0 then begin
  170.         seekffile (fn);
  171.         read (ffile,f); che;
  172.         writeln (^B'Old description: ',f.descrip);
  173.         writestr ('New description [or CR]:');
  174.         if length(input)>0 then begin
  175.           f.descrip:=input;
  176.           seekffile (fn);
  177.           write (ffile,f);
  178.           writelog (5,9,f.descrip)
  179.         end
  180.       end
  181.     end;
  182.  
  183.     Procedure movefile;
  184.     VAR f:filerec;
  185.         tcb:boardrec;
  186.         tcbn,dbn,fn:integer;
  187.         tcbname:sstr;
  188.     begin
  189.       writehdr ('File Move');
  190.       fn:=getfilenumber ('move');
  191.       if fn=0 then exit;
  192.       seekffile (fn);
  193.       read (ffile,f);
  194.       writestr ('Move "'+f.descrip+'" to which board? *');
  195.       if length(input)=0 then exit;
  196.       tcb:=curboard;
  197.       tcbn:=curboardnum;
  198.       tcbname:=curboardname;
  199.       dbn:=searchboard(input);
  200.       if dbn=-1 then begin
  201.         writeln ('No such board!');
  202.         exit
  203.       end;
  204.       writeln ('Moving...');
  205.       delfile (fn);
  206.       close (bfile);
  207.       close (ffile);
  208.       seek (bdfile,dbn);
  209.       read (bdfile,curboard);
  210.       curboardnum:=dbn;
  211.       curboardname:=curboard.shortname;
  212.       openbfile;
  213.       addfile (f);
  214.       close (bfile);
  215.       close (ffile);
  216.       curboard:=tcb;
  217.       curboardname:=tcbname;
  218.       curboardnum:=tcbn;
  219.       openbfile;
  220.       writelog (5,6,f.descrip);
  221.       writeln (^B'Done!')
  222.     end;
  223.  
  224.     Procedure movebulletin;
  225.     VAR Post:bulrec;
  226.         tcb:boardrec;
  227.         tcbn,dbn,bnum:integer;
  228.         tcbname,dbname:sstr;
  229.     begin
  230.       writehdr ('Bulletin Move');
  231.       getbnum ('move');
  232.       if not checkcurbul then exit;
  233.       bnum:=Cur_bul;
  234.       seekbfile (bnum);
  235.       read (bfile,Post);
  236.       writestr ('Move "'+Post.title+'" posted by '+Post.leftby+
  237.         ' to which board? *');
  238.       if length(input)=0 then exit;
  239.       tcbname:=curboardname;
  240.       dbname:=input;
  241.       dbn:=searchboard(dbname);
  242.       if dbn=-1 then begin
  243.         writeln ('No such board!');
  244.         exit
  245.       end;
  246.       writeln ('Moving...');
  247.       delbul (bnum,false);
  248.       close (bfile);
  249.       close (ffile);
  250.       curboardname:=dbname;
  251.       openbfile;
  252.       addbul (Post);
  253.       close (bfile);
  254.       close (ffile);
  255.       curboardname:=tcbname;
  256.       openbfile;
  257.       writelog (5,13,Post.title);
  258.       writeln (^B'Done!')
  259.     end;
  260.  
  261.     Procedure wipeoutfile;
  262.     VAR un,fn:integer;
  263.         f:filerec;
  264.         q:file;
  265.         n:mstr;
  266.         u:userrec;
  267.     begin
  268.       writehdr ('File Wipe-out');
  269.       fn:=getfilenumber ('wipe out');
  270.       if fn=0 then exit;
  271.       seekffile (fn);
  272.       read (ffile,f);
  273.       writestr ('Wipe out: "'+f.descrip+'" ? *');
  274.       if not yes then exit;
  275.       writestr ('Erase disk file '+f.fname+'? *');
  276.       if yes then begin
  277.         assign (q,f.fname);
  278.         erase (q);
  279.         un:=ioresult
  280.       end;
  281.       delfile (fn);
  282.       writelog (5,7,f.descrip);
  283.       n:=f.sentby;
  284.       un:=lookupuser(n);
  285.       if un<>0
  286.         then
  287.           begin
  288.             seek (ufile,un);
  289.             read (ufile,u);
  290.             u.nup:=u.nup-1;
  291.             writeln (n,' now has ',u.nup,' uploads.');
  292.             seek (ufile,un);
  293.             write (ufile,u)
  294.           end
  295.     end;
  296.  
  297.     Procedure setsponsor;
  298.     VAR un:integer;
  299.         Post:bulrec;
  300.     begin
  301.       writestr ('New sponsor:');
  302.       if length(input)=0 then exit;
  303.       un:=lookupuser (input);
  304.       if un=0
  305.         then writeln ('No such user.')
  306.         else
  307.           begin
  308.             curboard.sponsor:=input;
  309.             writelog (5,8,input);
  310.             writecurboard
  311.           end
  312.     end;
  313.  
  314.     Procedure renameboard;
  315.     VAR sn:sstr;
  316.         nfp,nbf,nff:lstr;
  317.         qf:file;
  318.         d:integer;
  319.     begin
  320.       getbstr ('board name',curboard.boardname);
  321.       sn:=curboard.shortname;
  322.       getbgen ('access name/number',sn);
  323.       writelog (5,5,curboard.boardname+' ['+sn+']');
  324.       if match(sn,curboard.shortname) then exit;
  325.       if not validbname(sn) then begin
  326.         writeln ('Invalid board name!');
  327.         exit
  328.       end;
  329.       if boardexist(sn) then begin
  330.         writeln ('Sorry!  Board already exists!');
  331.         exit
  332.       end;
  333.       curboard.shortname:=sn;
  334.       writecurboard;
  335.       close (bfile);
  336.       close (ffile);
  337.       nfp:=boarddir+sn+'.';
  338.       nbf:=nfp+'BUL';
  339.       nff:=nfp+'FIL';
  340.       assign (qf,nbf);
  341.       erase (qf);
  342.       d:=ioresult;
  343.       assign (qf,nff);
  344.       erase (qf);
  345.       d:=ioresult;
  346.       rename (bfile,nbf);
  347.       rename (ffile,nff);
  348.       setfirstboard;
  349.       q:=9
  350.     end;
  351.  
  352.     Procedure killboard;
  353.     VAR cnt:integer;
  354.         f:file;
  355.         fr:filerec;
  356.         bd:boardrec;
  357.     begin
  358.       writestr ('Kill board:  Are you sure? *');
  359.       if not yes then exit;
  360.       writelog (5,10,'');
  361.       writeln (^B^M'Deleting messages...');
  362.       for cnt:=numbuls downto 1 do
  363.         begin
  364.           delbul(cnt,true);
  365.           write (cnt,' ')
  366.         end;
  367.       writeln (^B^M'Deleting files...');
  368.       for cnt:=numfiles downto 1 do
  369.         begin
  370.           seekffile (cnt);
  371.           read (ffile,fr);
  372.           assign (f,fr.fname);
  373.           erase (f);
  374.           if ioresult<>0 then writeln (^B'Error erasing ',fr.fname);
  375.           delfile (cnt);
  376.           write (cnt,' ')
  377.         end;
  378.       writeln (^B^M'Deleting sub-board files...');
  379.       close (bfile);
  380.       assignbfile;
  381.       erase (bfile);
  382.       if ioresult<>0 then writeln (^B'Error erasing board file.');
  383.       close (ffile);
  384.       assignffile;
  385.       erase (ffile);
  386.       if ioresult<>0 then writeln (^B'Error erasing file directory file.');
  387.       writeln (^M'Removing sub-board...');
  388.       delboard (curboardnum);
  389.       writeln (^B'Sub-board erased!');
  390.       setfirstboard;
  391.       q:=9
  392.     end;
  393.  
  394.     Procedure sortboards;
  395.     VAR cnt,mark,temp:integer;
  396.         bd1,bd2:boardrec;
  397.         bn1,bn2:sstr;
  398.         bo:boardorder;
  399.     begin
  400.       writestr ('Sort sub-boards: Are you sure? *');
  401.       if not yes then exit;
  402.       Clear_order(bo);
  403.       mark := filesize(bdfile)-1;
  404.       REPEAT
  405.         IF mark <> 0 THEN begin
  406.           temp:=mark;
  407.           mark:=0;
  408.           for cnt:=0 to temp-1 do begin
  409.             seek (bifile,cnt);
  410.             read (bifile,bn1);
  411.             read (bifile,bn2);
  412.             if upstring(bn1)>upstring(bn2) then begin
  413.               mark:=cnt;
  414.               switchboards (cnt,cnt+1,bo)
  415.             end
  416.           end
  417.         end
  418.       until mark=0;
  419.       carryout (bo);
  420.       writelog (5,16,'');
  421.       setfirstboard;
  422.       q:=9
  423.     end;
  424.  
  425.     Procedure orderboards;
  426.     VAR numb,curb,newb:integer;
  427.         bo:boardorder;
  428.     label exit;
  429.     begin
  430.       Clear_order(bo);
  431.       writehdr('Re-order sub-boards');
  432.       numb:=filesize (bdfile);
  433.       thereare (numb,'sub-board','sub-boards');
  434.       for curb:=0 to numb-2 do begin
  435.         repeat
  436.           writestr ('New board #'+strr(curb+1)+' [?=List, CR to quit]:');
  437.           if length(input)=0 then goto exit;
  438.           if input='?'
  439.             then
  440.               begin
  441.                 listboards;
  442.                 newb:=-1
  443.               end
  444.             else
  445.               begin
  446.                 newb:=searchboard(input);
  447.                 if newb<0 then writeln ('Not found!  Please re-enter...')
  448.               end
  449.         until (newb>=0);
  450.         switchboards (curb,newb,bo)
  451.       end;
  452.       exit:
  453.       carryout (bo);
  454.       writelog (5,14,'');
  455.       q:=9;
  456.       setfirstboard
  457.     end;
  458.  
  459.     Procedure addresident;
  460.     VAR f:filerec;
  461.     begin
  462.       writestr ('Filename (including path):');
  463.       if hungupon or (length(input)=0) then exit;
  464.       if devicename(input) then begin
  465.         writeln ('That''s a DOS device name !');
  466.         exit
  467.       end;
  468.       if not exist(input) then begin
  469.         writeln ('File not found.');
  470.         exit
  471.       end;
  472.       f.sentby:=unam;
  473.       f.fname:=input;
  474.       writestr ('Description:');
  475.       if length(input)=0 then exit;
  476.       f.descrip:=input;
  477.       f.downloaded:=0;
  478.       f.when:=now;
  479.       addfile (f);
  480.       writelog (5,15,f.fname)
  481.     end;
  482.  
  483.   begin
  484.     if (not Sponsor_on) and (not issysop) then begin
  485.       writeln ('Nice try, except you aren''t the sponsor.');
  486.       exit
  487.     end;
  488.     writelog (4,3,curboard.boardname+' ['+curboard.shortname+']');
  489.     repeat
  490.       q:=menu ('Sponsor','SPONSOR','DLSTMWUEQRKC@BO@VA@H');
  491.       case q of
  492.         1:getautodel;
  493.         2:getblevel;
  494.         3:setsponsor;
  495.         4:getfiletitle;
  496.         5:movefile;
  497.         6:wipeoutfile;
  498.         7:setnameaccess;
  499.         8:setallaccess;
  500.         10:renameboard;
  501.         11:killboard;
  502.         12:sortboards;
  503.         13:movebulletin;
  504.         14:orderboards;
  505.         15:listaccess;
  506.         16:addresident;
  507.         17:help ('Sponsor.hlp')
  508.       end
  509.     until (q=9) or hungupon
  510.   end;
  511.