home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 341.img / TCS161S.ZIP / RUMORS.PAS < prev    next >
Pascal/Delphi Source File  |  1989-06-26  |  11KB  |  456 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit rumors;
  5.  
  6. interface
  7.  
  8. uses crt,dos,
  9.      gentypes,configrt,modem,statret,gensubs,subs1,windows,subs2;
  10.  
  11. procedure rumormenu;
  12. procedure randomrumor;
  13.  
  14. implementation
  15.  
  16. procedure rumormenu;
  17. var r,ar:rumorrec;
  18.  
  19.   function numrumors:integer;
  20.   begin
  21.     numrumors:=filesize(rfile)
  22.   end;
  23.  
  24.   procedure seekrfile (n:integer);
  25.   begin
  26.     seek (rfile,n-1)
  27.   end;
  28.  
  29.   procedure openrfile;
  30.   var n:integer;
  31.   begin
  32.     n:=ioresult;
  33.     assign (rfile,'Rumors.Dat');
  34.     reset (rfile);
  35.     if ioresult<>0 then begin
  36.       close (rfile);
  37.       n:=ioresult;
  38.       rewrite (rfile)
  39.     end
  40.   end;
  41.  
  42.   procedure listrumors;
  43.   var cnt:integer;
  44.       b:boolean;
  45.       n1,n2:integer;
  46.   begin
  47.     writeln;
  48.     ansireset;
  49.     if numrumors<1 then begin
  50.      writeln ('There are no Rumors!');
  51.      exit;
  52.     end;
  53.     b:=true;
  54.     seekrfile (1);
  55.     writehdr ('Rumors List');
  56.     parserange (numrumors,n1,n2);
  57.     if n1=0 then exit;
  58.      for cnt:=n1 to n2 do begin
  59.         read (rfile,r);
  60.         if b then begin
  61.          writeln
  62.          (^P'#'^S'   Title                         '^U'Date      '^R'Author');
  63.          if ascii then
  64.          writeln
  65.          (^S'────────────────────────────────────────────────────────────────────────'^M^R);
  66.          b:=false
  67.         end;
  68.         ansicolor (urec.promptcolor);
  69.         tab (strr(cnt),4);
  70.         ansicolor (urec.statcolor);
  71.         tab (r.title,30);
  72.         ansicolor (urec.inputcolor);
  73.         tab (datestr(r.when),10);
  74.         ansicolor (urec.regularcolor);
  75.         if r.author='...!@ANON#$...' then
  76.         begin
  77.          write ('<Anonymous>');
  78.          if ulvl>=readanonlvl then write (^R,' ('^S,r.author2,^R')');
  79.          writeln;
  80.         end
  81.         else writeln (^S,r.author);
  82.         ansireset;
  83.         if break then exit;
  84.         ansicolor (urec.regularcolor);
  85.     end;
  86.     if b then writestr ('There are no Rumors!')
  87.   end;
  88.  
  89.   function getrnum (txt:mstr):integer;
  90.   var n:integer;
  91.   begin
  92.     getrnum:=0;
  93.     repeat
  94.       writeln;
  95.       writestr ('Rumor Number to '+txt+' [?/List]:');
  96.       if length(input)=0 then exit;
  97.       if upcase(input[1])='?'
  98.         then listrumors
  99.         else begin
  100.           n:=valu(input);
  101.           if (n<1) or (n>numrumors) then begin
  102.             writestr (^M'Number out of range!');
  103.             exit
  104.           end;
  105.           seekrfile (n);
  106.           read (rfile,r);
  107.           if (ulvl<r.level) and (not issysop) then exit;
  108.           getrnum:=n;
  109.           exit
  110.         end
  111.     until hungupon
  112.   end;
  113.  
  114. procedure showrumor (n:integer);
  115. var rr:rumorrec;
  116. begin
  117.    seekrfile (n);
  118.    read (rfile,rr);
  119.    if ulvl<rr.level then exit;
  120.    writeln;
  121.    ansicolor (11);
  122.    write ('"');
  123.    ansicolor (9);
  124.    write (rr.rumor);
  125.    ansicolor (11);
  126.    writeln ('"');
  127.    ansireset;
  128. end;
  129.  
  130.   procedure addrumor;
  131.   var x,b:boolean;
  132.       y,t:text;
  133.       cdir,cddir:lstr;
  134.       n:integer;
  135.       z:anystr;
  136.       apecks:rumorrec;
  137.  
  138.   function matchtitle (f:sstr):integer;
  139.   var cnt:integer;
  140.       monark:rumorrec;
  141.   begin
  142.     for cnt:=1 to numrumors do begin
  143.       seekrfile (cnt);
  144.       read (rfile,monark);
  145.       if match (monark.title,f) then begin
  146.         matchtitle:=cnt;
  147.         ansireset;
  148.         exit
  149.       end
  150.     end;
  151.     matchtitle:=0
  152.   end;
  153.  
  154.     begin
  155.     if ulvl<2 then begin
  156.      reqlevel (2);
  157.      exit
  158.     end;
  159.     if numrumors>=999 then begin
  160.      writeln;
  161.      writeln ('Sorry, there are too many rumors now!');
  162.      writeln ('Ask your Sysop to delete some.');
  163.      exit
  164.     end;
  165.     ansireset;
  166.     writehdr ('Add a Rumor');
  167.     buflen:=30;
  168.     writeln ('      [------------------------------]');
  169.     writestr('Title: &');
  170.     apecks.title:=input;
  171.     if length(input)=0 then exit;
  172.     if matchtitle(apecks.title)>0 then begin
  173.      writeln;
  174.      writeln ('Sorry, that Rumor already exists! Try another Title!');
  175.      exit
  176.     end;
  177.     apecks.level:=1;
  178.     apecks.author:=unam;
  179.     apecks.author2:=unam;
  180.     writeln;
  181.     if ulvl>=anonymouslevel then begin
  182.      writestr ('Post Rumor Anonymous [y/n]? &');
  183.      if yes then apecks.author:='...!@ANON#$...' else
  184.      apecks.author:=unam;
  185.     end;
  186.     apecks.when:=now;
  187.     ansireset;
  188.     writeln;
  189.     writestr ('Level required to read Rumor [CR/1]: &');
  190.     if length(input)=0 then apecks.level:=1 else
  191.     apecks.level:=valu(input);
  192.     writeln;
  193.     writeln ('Enter Rumor [CR to Abort]');
  194.     buflen:=78;
  195.     writeln (' [---------------------------------------------------------------------------]');
  196.     writestr('> &');
  197.     if input='' then exit;
  198.     b:=true;
  199.     apecks.rumor:=input;
  200.     seekrfile (numrumors+1);
  201.     write (rfile,apecks);
  202.     if b then writeln (^M'Rumor created!');
  203.     if not b then begin
  204.     exit
  205.     end;
  206.   end;
  207.  
  208.   procedure deleterumor;
  209.   var cnt,n:integer;
  210.       f:file;
  211.   begin
  212.     n:=getrnum ('Delete');
  213.     if n=0 then exit;
  214.     seekrfile (n);
  215.     read (rfile,r);
  216.     if not issysop then
  217.     if not match(r.author2,unam) then
  218.     begin
  219.      writeln;
  220.      writeln ('You didn''t post that!!');
  221.      writeln;
  222.      exit
  223.     end;
  224.     writeln;
  225.     ansicolor (11);
  226.     write ('"');
  227.     ansicolor (9);
  228.     write (r.rumor);
  229.     ansicolor (11);
  230.     writeln ('"');
  231.     writeln;
  232.     writestr ('Delete this Rumor [y/n]? *');
  233.     if not yes then exit;
  234.     for cnt:=n+1 to numrumors do begin
  235.      seekrfile (cnt);
  236.      read (rfile,r);
  237.      seekrfile (cnt-1);
  238.      write (rfile,r);
  239.     end;
  240.     seekrfile (numrumors);
  241.     truncate (rfile);
  242.     writelog (1,8,r.title)
  243.   end;
  244.  
  245.   const beenaborted:boolean=false;
  246.  
  247.   function aborted:boolean;
  248.   begin
  249.     if beenaborted then begin
  250.       aborted:=true;
  251.       exit
  252.     end;
  253.     aborted:=xpressed or hungupon;
  254.     if xpressed then begin
  255.       beenaborted:=true;
  256.       writeln (^B'Newscan aborted!')
  257.     end
  258.   end;
  259.  
  260.   procedure rumorsnewscan;
  261.   var first,cnt:integer;
  262.       nd:boolean;
  263.       re:rumorrec;
  264.   begin
  265.     writehdr ('Rumors Newscan');
  266.     if numrumors<1 then exit;
  267.     for cnt:=1 to numrumors do begin
  268.      seekrfile (cnt);
  269.      read (rfile,re);
  270.      if (re.when>laston) and (ulvl>=re.level) then begin
  271.       ansicolor (urec.inputcolor);
  272.       tab (strr(cnt)+'.',4);
  273.       ansicolor (urec.promptcolor);
  274.       write  (re.title);
  275.       ansicolor (urec.regularcolor);
  276.       write (' by ');
  277.       ansicolor (urec.inputcolor);
  278.       if re.author='...!@ANON#$...' then
  279.       write ('<Anonymous>') else write (re.author2);
  280.       writeln;
  281.       write (' "');
  282.       ansicolor (urec.statcolor);
  283.       write (re.rumor);
  284.       ansicolor (urec.regularcolor);
  285.       writeln ('"');
  286.      end;
  287.     end;
  288.   end;
  289.  
  290.   procedure searchfortext;
  291.   var x:integer;
  292.       mixmasterfag:boolean;
  293.       s:anystr;
  294.       rr:rumorrec;
  295.   begin
  296.    if numrumors<1 then begin
  297.     writeln (^M'No Rumors Exist!'^M);
  298.     exit;
  299.    end;
  300.    writehdr ('Search for Text in all Rumors');
  301.    writeln ('Enter Text to search for:');
  302.    writestr ('-> &');
  303.    writeln;
  304.    if length(input)=0 then exit;
  305.    s:=input;
  306.    s:=upstring(s);
  307.    for x:=1 to numrumors do begin
  308.     mixmasterfag:=false;
  309.     seekrfile (x);
  310.     read (rfile,rr);
  311.     if pos(s,upstring(rr.title))>0 then mixmasterfag:=true;
  312.     if pos(s,upstring(rr.rumor))>0 then mixmasterfag:=true;
  313.     if pos(s,upstring(rr.author))>0 then mixmasterfag:=true;
  314.     if ((ulvl>=readanonlvl) and (pos(s,upstring(rr.author2))>0)) then mixmasterfag:=true;
  315.     if (mixmasterfag=true) and (ulvl>=rr.level) then begin
  316.      ansicolor (urec.inputcolor);
  317.      tab (strr(x)+'.',4);
  318.      ansicolor (urec.promptcolor);
  319.      write  (rr.title);
  320.      ansicolor (urec.regularcolor);
  321.      write (' by ');
  322.      ansicolor (urec.inputcolor);
  323.      if rr.author='...!@ANON#$...' then
  324.      write ('<Anonymous>') else write (rr.author2);
  325.      writeln;
  326.      write (' "');
  327.      ansicolor (urec.statcolor);
  328.      write (rr.rumor);
  329.      ansicolor (urec.regularcolor);
  330.      writeln ('"');
  331.     end;
  332.    end;
  333.   end;
  334.  
  335.   procedure explainrumors;
  336.   begin
  337.    if exist (textfiledir+'Rumors.Hlp') then
  338.    printfile (textfiledir+'Rumors.Hlp') else
  339.    begin
  340.     writehdr ('Rumors Explanation');
  341.     writeln;
  342.     writeln ('Rumors are sayings that a user can make and the rumor will');
  343.     writeln ('randomly appear at the Main Menu prompt. You can Add, View,');
  344.     writeln ('and Delete rumors (you can only Delete rumors if you are a');
  345.     writeln ('Sysop or if you posted that rumor). You can also set a level');
  346.     writeln ('required to see that particular rumor. ');
  347.     writeln;
  348.    end;
  349.   end;
  350.  
  351. label later;
  352. var prompt:lstr;
  353.     n,q,b:integer;
  354.     k:char;
  355.     mp:boolean;
  356. begin
  357.   if not userumor then begin
  358.    writeln;
  359.    writeln ('Rumors are not in use!');
  360.    writeln;
  361.    exit;
  362.   end;
  363.   openrfile;
  364.   mp:=moreprompts in urec.config;
  365.   if mp then urec.config:=urec.config-[moreprompts];
  366.   repeat
  367.     q:=menu ('Rumors Menu','RUMOR','LAD#EQNS');
  368.     writeln;
  369.     if q<0 then begin
  370.      b:=-q;
  371.      if (b<0) or (b>numrumors) then
  372.      writeln (^M'Number out of range!') else
  373.      showrumor (b);
  374.     end else
  375.     case q of
  376.      1:listrumors;
  377.      2:addrumor;
  378.      3:deleterumor;
  379.      5:explainrumors;
  380.      7:rumorsnewscan;
  381.      8:searchfortext;
  382.     end;
  383.   until (q=6) or (hungupon);
  384.   later:
  385.   close (rfile);
  386.   if mp then urec.config:=urec.config+[moreprompts];
  387. end;
  388.  
  389. procedure randomrumor;
  390.  
  391.   function numrumors:integer;
  392.   begin
  393.     numrumors:=filesize(rfile)
  394.   end;
  395.  
  396.   procedure seekrfile (n:integer);
  397.   begin
  398.     seek (rfile,n-1)
  399.   end;
  400.  
  401.   procedure openrfile;
  402.   var n:integer;
  403.   begin
  404.     n:=ioresult;
  405.     assign (rfile,'Rumors.Dat');
  406.     reset (rfile);
  407.     if ioresult<>0 then begin
  408.       close (rfile);
  409.       n:=ioresult;
  410.       rewrite (rfile)
  411.     end
  412.   end;
  413.  
  414. procedure showit (n:integer);
  415. var rr:rumorrec;
  416. begin
  417.    seekrfile (n);
  418.    read (rfile,rr);
  419.    if ulvl<rr.level then exit;
  420.    writeln;
  421.    ansicolor (11);
  422.    write ('"');
  423.    ansicolor (9);
  424.    write (rr.rumor);
  425.    ansicolor (11);
  426.    writeln ('"');
  427.    ansireset;
  428. end;
  429.  
  430. var x:integer;
  431. begin
  432.  if not userumor then exit;
  433.  openrfile;
  434.  if numrumors<1 then begin
  435.   writeln;
  436.   ansicolor (11);
  437.   write ('"');
  438.   ansicolor (9);
  439.   write ('Press ''R'' to make a Rumor...');
  440.   ansicolor (11);
  441.   writeln ('"');
  442.   ansireset;
  443.  end else
  444.  begin
  445.   seekrfile (1);
  446.   randomize;
  447.   x:=random (numrumors+1);
  448.   showit (x);
  449.  end;
  450.  close (rfile);
  451.  ansireset;
  452. end;
  453.  
  454. begin
  455. end.
  456.