home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FAQ-S.ZIP / QUOTES.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-13  |  12.0 KB  |  477 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit quotes;
  5.  
  6. interface
  7.  
  8. uses crt,dos,
  9.      gentypes,configrt,modem,statret,gensubs,subs1,windows,subs2;
  10.  
  11. procedure quotemenu;
  12. procedure randomquote;
  13.  
  14. implementation
  15.  
  16. procedure quotemenu;
  17. var r,ar:quoterec;
  18.  
  19.   function numquotes:integer;
  20.   begin
  21.     numquotes:=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,bbsdatadir+'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 listquotes;
  43.   var cnt:integer;
  44.       b:boolean;
  45.       n1,n2:integer;
  46.   begin
  47.     writeln;
  48.     ansireset;
  49.     if numquotes<1 then begin
  50.      writeln ('There are no Quotes!');
  51.      exit;
  52.     end;
  53.     b:=true;
  54.     seekrfile (1);
  55.     writehdr ('Quotes List');
  56.     parserange (numquotes,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 Quotes!')
  87.   end;
  88.  
  89.   function getrnum (txt:mstr):integer;
  90.   var n:integer;
  91.   begin
  92.     getrnum:=0;
  93.     repeat
  94.       writeln;
  95.       writestr ('Quote Number to '+txt+' [?/List]:');
  96.       if length(input)=0 then exit;
  97.       if upcase(input[1])='?'
  98.         then listquotes
  99.         else begin
  100.           n:=valu(input);
  101.           if (n<1) or (n>numquotes) 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 showquote (n:integer);
  115. var rr:quoterec;
  116. begin
  117.    seekrfile (n);
  118.    read (rfile,rr);
  119.    if ulvl<rr.level then exit;
  120.    writeln;
  121.    ansicolor (urec.regularcolor);
  122.    write ('"');
  123.    ansicolor (urec.statcolor);
  124.    write (rr.quote);
  125.    ansicolor (urec.regularcolor);
  126.    writeln ('"');
  127.    ansireset;
  128. end;
  129.  
  130.   procedure addquote;
  131.   var x,b:boolean;
  132.       y,t:text;
  133.       cdir,cddir:lstr;
  134.       n:integer;
  135.       z:anystr;
  136.       apecks:quoterec;
  137.  
  138.   function matchtitle (f:sstr):integer;
  139.   var cnt:integer;
  140.       monark:quoterec;
  141.   begin
  142.     for cnt:=1 to numquotes 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 numquotes>=999 then begin
  160.      writeln;
  161.      writeln ('Sorry, there are too many quotes now!');
  162.      writeln ('Ask your Sysop to delete some.');
  163.      exit
  164.     end;
  165.     ansireset;
  166.     writehdr ('Add a Quote');
  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 Quote 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 Quote 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 Quote [CR/1]: &');
  190.     if length(input)=0 then apecks.level:=1 else
  191.     apecks.level:=valu(input);
  192.     writeln;
  193.     writeln ('Enter Quote [CR to Abort]');
  194.     buflen:=78;
  195.     writeln (' [---------------------------------------------------------------------------]');
  196.     writestr('> &');
  197.     if input='' then exit;
  198.     b:=true;
  199.     apecks.quote:=input;
  200.     seekrfile (numquotes+1);
  201.     write (rfile,apecks);
  202.     if b then writeln (^M'Quote created!');
  203.     if not b then begin
  204.     exit
  205.     end;
  206.   end;
  207.  
  208.   procedure deletequote;
  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 (urec.regularcolor);
  226.     write ('"');
  227.     ansicolor (urec.statcolor);
  228.     write (r.quote);
  229.     ansicolor (urec.regularcolor);
  230.     writeln ('"');
  231.     writeln;
  232.     writestr ('Delete this Quote? [y/n]: *');
  233.     if not yes then exit;
  234.     for cnt:=n+1 to numquotes do begin
  235.      seekrfile (cnt);
  236.      read (rfile,r);
  237.      seekrfile (cnt-1);
  238.      write (rfile,r);
  239.     end;
  240.     seekrfile (numquotes);
  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 (^R'Newscan aborted!')
  257.     end
  258.   end;
  259.  
  260.   procedure quotesnewscan;
  261.   var first,cnt:integer;
  262.       nd:boolean;
  263.       re:quoterec;
  264.   begin
  265.     writehdr ('Quotes Newscan');
  266.     if numquotes<1 then exit;
  267.     for cnt:=1 to numquotes 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.       ansicolor (urec.regularcolor);
  282.       write (' "');
  283.       ansicolor (urec.statcolor);
  284.       write (re.quote);
  285.       ansicolor (urec.regularcolor);
  286.       writeln ('"');
  287.      end;
  288.     end;
  289.   end;
  290.  
  291.   procedure searchfortext;
  292.   var x:integer;
  293.       mixmasterfag:boolean;
  294.       s:anystr;
  295.       rr:quoterec;
  296.   begin
  297.    if numquotes<1 then begin
  298.     writeln (^M'No Quotes Exist!'^M);
  299.     exit;
  300.    end;
  301.    writehdr ('Search for Text in all Quotes');
  302.    writeln ('Enter Text to search for:');
  303.    writestr ('-> &');
  304.    writeln;
  305.    if length(input)=0 then exit;
  306.    s:=input;
  307.    s:=upstring(s);
  308.    for x:=1 to numquotes do begin
  309.     mixmasterfag:=false;
  310.     seekrfile (x);
  311.     read (rfile,rr);
  312.     if pos(s,upstring(rr.title))>0 then mixmasterfag:=true;
  313.     if pos(s,upstring(rr.quote))>0 then mixmasterfag:=true;
  314.     if pos(s,upstring(rr.author))>0 then mixmasterfag:=true;
  315.     if ((ulvl>=readanonlvl) and (pos(s,upstring(rr.author2))>0)) then mixmasterfag:=true;
  316.     if (mixmasterfag=true) and (ulvl>=rr.level) then begin
  317.      ansicolor (urec.inputcolor);
  318.      tab (strr(x)+'.',4);
  319.      ansicolor (urec.promptcolor);
  320.      write  (rr.title);
  321.      ansicolor (urec.regularcolor);
  322.      write (' by ');
  323.      ansicolor (urec.inputcolor);
  324.      if rr.author='...!@ANON#$...' then
  325.      write ('<Anonymous>') else write (rr.author2);
  326.      writeln;
  327.      ansicolor (urec.regularcolor);
  328.      write (' "');
  329.      ansicolor (urec.statcolor);
  330.      write (rr.quote);
  331.      ansicolor (urec.regularcolor);
  332.      writeln ('"');
  333.     end;
  334.    end;
  335.   end;
  336.  
  337.   procedure explainquotes;
  338.   begin
  339.    if exist (textfiledir+'Quotes.Hlp') then
  340.    printfile (textfiledir+'Quotes.Hlp') else
  341.    begin
  342.     writehdr ('Quotes Explanation');
  343.     writeln;
  344.     writeln ('Quotes are sayings that a user can make and the quote will');
  345.     writeln ('randomly appear at the Main Menu prompt. You can Add, View,');
  346.     writeln ('and Delete quotes (you can only Delete quotes if you are a');
  347.     writeln ('Sysop or if you posted that quote). You can also set a level');
  348.     writeln ('required to see that particular quote. ');
  349.     writeln;
  350.    end;
  351.   end;
  352.  
  353. label later;
  354. var prompt:lstr;
  355.     n,q,b:integer;
  356.     k:char;
  357.     mp:boolean;
  358. begin
  359.   if not usequote then begin
  360.    writeln;
  361.    writeln ('Quotes are not in use!');
  362.    writeln;
  363.    exit;
  364.   end;
  365.   openrfile;
  366.   mp:=moreprompts in urec.config;
  367.   if mp then urec.config:=urec.config-[moreprompts];
  368.   writehdr ('Quotes');
  369.   repeat
  370.     q:=menu ('Quotes','QUOTE','LAD#EQNS?');
  371.     writeln;
  372.     if q<0 then begin
  373.      b:=-q;
  374.      if (b<0) or (b>numquotes) then
  375.      writeln (^M'Number out of range!') else
  376.      showquote (b);
  377.     end else
  378.     case q of
  379.      1:listquotes;
  380.      2:addquote;
  381.      3:deletequote;
  382.      5:explainquotes;
  383.      7:quotesnewscan;
  384.      8:searchfortext;
  385.      9:begin
  386. writeln ('C╔═════════════════════════════════════╗Hs');
  387. writeln ('uC║ Quotes Section                      ║Hs');
  388. writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
  389. writeln ('u═════════════════════════════════╗HC║ [A]  s');
  390. writeln ('uAdd Quote                      ║HC║ [Ds');
  391. writeln ('u]  Delete Quote                   ║HC║ [s');
  392. writeln ('uE]  Explanation of Quote           ║Hs');
  393. writeln ('uC║ [N]  Newscan all Quotes             s');
  394. writeln ('u║HC║ [Q]  Quit                    s');
  395. writeln ('u       ║HC║ [S]  Search Quotes fors');
  396. writeln ('u Text         ║HC║ [#]  Read Quotes');
  397. writeln ('u #                   ║HC║ [?]  Vies');
  398. writeln ('uw This Menu                 ║HC╚═════════════════A');
  399. writeln ('C════════════════════╝');
  400. writeln;
  401. pause;
  402.            end;
  403.     end;
  404.   until (q=6) or (hungupon);
  405.   later:
  406.   close (rfile);
  407.   if mp then urec.config:=urec.config+[moreprompts];
  408. end;
  409.  
  410. procedure randomquote;
  411.  
  412.   function numquotes:integer;
  413.   begin
  414.     numquotes:=filesize(rfile)
  415.   end;
  416.  
  417.   procedure seekrfile (n:integer);
  418.   begin
  419.     seek (rfile,n-1)
  420.   end;
  421.  
  422.   procedure openrfile;
  423.   var n:integer;
  424.   begin
  425.     n:=ioresult;
  426.     assign (rfile,bbsdatadir+'Rumors.dat');
  427.     reset (rfile);
  428.     if ioresult<>0 then begin
  429.       close (rfile);
  430.       n:=ioresult;
  431.       rewrite (rfile)
  432.     end
  433.   end;
  434.  
  435. procedure showit (n:integer);
  436. var rr:quoterec;
  437. begin
  438.    seekrfile (n);
  439.    read (rfile,rr);
  440.    if ulvl<rr.level then exit;
  441.    writeln;
  442.    ansicolor (urec.regularcolor);
  443.    write ('"');
  444.    ansicolor (urec.statcolor);
  445.    write (rr.quote);
  446.    ansicolor (urec.regularcolor);
  447.    writeln ('"');
  448.    ansireset;
  449. end;
  450.  
  451. var x:integer;
  452. begin
  453.  if not usequote then exit;
  454.  openrfile;
  455.  if numquotes<1 then begin
  456.   writeln;
  457.   ansicolor (urec.regularcolor);
  458.   write ('"');
  459.   ansicolor (urec.statcolor);
  460.   write (^S'Make a Quote with '^R'"'^S'Q'^R'"'^S'.');
  461.   ansicolor (urec.regularcolor);
  462.   writeln ('"');
  463.   ansireset;
  464.  end else
  465.  begin
  466.   seekrfile (1);
  467.   randomize;
  468.   x:=random (numquotes+1);
  469.   showit (x);
  470.  end;
  471.  close (rfile);
  472.  ansireset;
  473. end;
  474.  
  475. begin
  476. end.
  477.