home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FAQ-S.ZIP / MAINR2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-25  |  7.2 KB  |  291 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit mainr2;
  5.  
  6. interface
  7.  
  8. uses crt,gensubs,gentypes,modem,subs1,subs2,statret,configrt,overret1,
  9.      textret,userret,mailret,lineedit,ansiedit,mainr1;
  10.  
  11. function reedit (var m:message; g:boolean):boolean;
  12. function editor (var m:message; gettitle:boolean; tttitle:lstr):integer;
  13. procedure seekbdfile (n:integer);
  14. procedure writebdfile (var bd:boardrec);
  15. procedure writecurboard;
  16. procedure addnews;
  17. procedure sendmailto (uname:mstr; anon:boolean);
  18. procedure addfeedback (var m:mailrec);
  19. procedure hangupmodem;
  20. procedure setupmodem;
  21. procedure dialnumber (num:lstr);
  22. procedure disconnect;
  23.  
  24. implementation
  25.  
  26. function reedit (var m:message; g:boolean):boolean;
  27. begin
  28.   if fseditor in urec.config
  29.     then reedit:=ansireedit (m,g)
  30.     else reedit:=linereedit (m,g);
  31.   trimmessage (m)
  32. end;
  33.  
  34. function editor (var m:message; gettitle:boolean; tttitle:lstr):integer;
  35. var thetitle:lstr;
  36.  
  37.   function getthetitle:boolean;
  38.   begin
  39.     m.anon:=false;
  40.     getthetitle:=true;
  41.     m.title:=tttitle;
  42.     thetitle:=tttitle;
  43.     if gettitle then begin
  44.     if (notitle=false) or (emailing=false) then begin
  45.       buflen:=30;
  46.       writestr (^M^M'Subject: &');
  47.       if (length(input)=0) and (notitle=false) then begin
  48.         getthetitle:=false;
  49.         exit
  50.       end;
  51.       if (notitle=false) then begin
  52.        m.title:=input;
  53.        thetitle:=m.title;
  54.       end;
  55.       if (emailing=false) and (nosendprompt=false) then begin
  56.        writestr ('To [CR/All]: &');
  57.        if length(input)=0 then m.leftto:='All' else
  58.        m.leftto:=input;
  59.       end;
  60.       with curboard do
  61.         if anony then begin
  62.         buflen:=1;
  63.     writestr ('Anonymous? [y/n]: *');
  64.         m.anon:=yes
  65.       end
  66.      end;
  67.     end;
  68.    if (not gettitle) or (emailing) or (notitle) then begin
  69.     m.title:=tttitle;
  70.     m.leftto:='All';
  71.     m.anon:=false;
  72.    end;
  73.   end;
  74.  
  75. begin
  76.   editor:=-1;
  77.   m.numlines:=0;
  78.   if getthetitle then
  79.    if reedit(m,gettitle) then
  80.     editor:=maketext(m)
  81. end;
  82.  
  83. procedure seekbdfile (n:integer);
  84. begin
  85.   seek (bdfile,n);
  86.   seek (bifile,n); che
  87. end;
  88.  
  89. procedure writebdfile (var bd:boardrec);
  90. begin
  91.   write (bdfile,bd);
  92.   write (bifile,bd.shortname)
  93. end;
  94.  
  95. procedure writecurboard;
  96. begin
  97.   seekbdfile (curboardnum);
  98.   writebdfile (curboard); che
  99. end;
  100.  
  101. procedure addnewsold;
  102. var newline,r:integer;
  103.     nfile:file of integer;
  104.     numnews,cnt:integer;
  105.     m:message;
  106. begin
  107.   writehdr ('Adding to the News');
  108.   titlestr:='Adding to the News';
  109.   sendstr:='All';
  110.   newline:=editor (m,false,'Adding to the News');
  111.   if newline<0 then exit;
  112.   r:=ioresult;
  113.   assign (nfile,bbsdatadir+'News.dat');
  114.   reset (nfile);
  115.   r:=ioresult;
  116.   if r<>0
  117.     then
  118.       begin
  119.     if r<>1 then writeln ('Creating news file.');
  120.         rewrite (nfile);
  121.         write (nfile,newline);
  122.         numnews:=0
  123.       end
  124.     else
  125.       begin
  126.         numnews:=filesize(nfile);
  127.         for cnt:=numnews-1 downto 0 do
  128.           begin
  129.             seek (nfile,cnt);
  130.             read (nfile,r);
  131.             seek (nfile,cnt+1);
  132.             write (nfile,r)
  133.           end;
  134.         che;
  135.         seek (nfile,0);
  136.         write (nfile,newline)
  137.       end;
  138.   writeln ('News added.  News items: ',numnews+1);
  139.   writelog (2,1,'');
  140.   close (nfile)
  141. end;
  142.  
  143.  
  144.   Procedure addnews;
  145.     Var newline,r:Integer;
  146.       nfile:File Of newsrec;
  147.       Ntmp,atmp:newsrec;
  148.       numnews,cnt:Integer;
  149.       m:message;
  150.     Begin
  151.       writehdr('Adding to the news');
  152.       Writestr('Minimum Level to read news [1] :');
  153.       If Input='' Then Input:='1';
  154.       ntmp.level:=valu(Input);
  155.       Writestr('Maximum Level to read news [32767] :');
  156.       If Input='' Then Input:='32767';
  157.       ntmp.Maxlevel:=valu(Input);
  158.  
  159.       newline:=editor(m,true,'');
  160.       Ntmp.when:=now;ntmp.from:=unam;Ntmp.title:=m.title;
  161.       ntmp.location:=newline;
  162.       If newline<0 Then exit;
  163.       r:=IOResult;
  164.       Assign(nfile,bbsdatadir+'News.dat');
  165.       Reset(nfile);
  166.       r:=IOResult;
  167.       If r<>0
  168.       Then
  169.         Begin
  170.           If r<>1 Then WriteLn('Error ',r,' opening news file; recreating.');
  171.           Rewrite(nfile);
  172.           Write(nfile,ntmp);
  173.           numnews:=0
  174.         End
  175.       Else
  176.         Begin
  177.           numnews:=FileSize(nfile);
  178.           For cnt:=numnews-1 Downto 0 Do
  179.             Begin
  180.               Seek(nfile,cnt);
  181.               Read(nfile,atmp);
  182.               Seek(nfile,cnt+1);
  183.               Write(nfile,atmp)
  184.             End;
  185.           che;
  186.           Seek(nfile,0);
  187.           Write(nfile,Ntmp)
  188.         End;
  189.       WriteLn('News added.  News items: ',numnews+1);
  190.       writelog(2,1,'');
  191.       Close(nfile)
  192.     End;
  193.  
  194.  
  195. procedure sendmailto (uname:mstr; anon:boolean);
  196. var un:integer;
  197.     me:message;
  198.     line:integer;
  199.     u:userrec;
  200. begin
  201.   if length(uname)=0 then exit;
  202.   un:=lookupuser (uname);
  203.   if un=0 then writeln ('User not found.') else begin
  204.     if anon and (ulvl<sysoplevel) then uname:=anonymousstr;
  205.     seek (ufile,un);
  206.     read (ufile,u);
  207.     if u.emailannounce>-1 then begin
  208.       writehdr (u.handle+'''s Announcement');
  209.       printtext (u.emailannounce)
  210.     end;
  211.     writehdr ('Sending E-Mail to '+uname);
  212.     titlestr:='Sending E-Mail to '+uname;
  213.     emailing:=true;
  214.     line:=editor (me,true,'E-Mail to '+uname);
  215.     emailing:=false;
  216.     if line>=0 then addmail (un,line,me)
  217.   end
  218. end;
  219.  
  220. procedure addfeedback (var m:mailrec);
  221. var ffile:file of mailrec;
  222. begin
  223.   assign (ffile,bbsdatadir+'Feedback.dat');
  224.   reset (ffile);
  225.   if ioresult<>0 then begin
  226.     close (ffile);
  227.     rewrite (ffile)
  228.   end;
  229.   seek (ffile,filesize(ffile));
  230.   write (ffile,m);
  231.   close (ffile);
  232.   newfeedback:=newfeedback+1;
  233. end;
  234.  
  235. procedure hangupmodem;
  236. var tries:integer;
  237. begin
  238.   hangup;
  239.   tries:=0;
  240.   while (carrier or local) and (tries<5) do begin
  241.     hangup;
  242.     sendmodemstr (modemhangupstr,false);
  243.     tries:=tries+1
  244.   end; 
  245.   setparam (usecom,baudrate,parity)
  246. end;
  247.  
  248. procedure setupmodem;
  249. var s:string;
  250. begin
  251.   clrscr;
  252.   if carrier then exit;
  253.   textcolor (normtopcolor);
  254.   write  (usr,'Initializing Modem [Type: ',usrspeed);
  255.   writeln(usr,' - DTE Rate: '+strlong(defbaudrate)+']');
  256.   cursor (false);
  257.   if length(modemsetupstr)>0 then
  258.   sendmodemstr ('~~'+modemsetupstr+'|',true);
  259.   s:='~~ATS0='+strr(answerring)+'Q0M0V0X4';
  260.   if (usrspeed=1) or (usrspeed=3) then s:=s+'B0';
  261.   if usrspeed=2 then s:=s+'B1';
  262.   sendmodemstr (s+'|',true);
  263.   {if usrspeed=0 then sendmodemstr ('~~ATS0='+strr(answerring)+'Q0M0V0X4|',true);
  264.   if usrspeed=1 then sendmodemstr ('~~ATS0='+strr(answerring)+'Q0M0V0X4B0| ~~AT&A3&B0&D0&G0&H1&K1&L0&M4'+
  265.   '&N0&P0&R2&S0&X0&Y1|',true);
  266.   if usrspeed=2 then sendmodemstr ('~~ATS0='+strr(answerring)+'Q0M0V0X4B1| ~~AT&A3&B0&D0&G0&H1&K1&L0&M4'+
  267.   '&N0&P0&R2&S0&X0&Y1|',true);
  268.   if usrspeed=3 then sendmodemstr ('~~ATS0='+strr(answerring)+'Q0M0V0X4B0| ~~AT&A3&B0&D0&G0&H1&K1&L0&M4'+
  269.   '&N0&P0&R2&S0&X0&Y1|',true);}
  270. end;
  271.  
  272. procedure dialnumber (num:lstr);
  273. begin
  274.   sendmodemstr (modemdialprefix+num+modemdialsuffix,true);
  275. end;
  276.  
  277. procedure disconnect;
  278. begin
  279.  
  280.   if online then hangupmodem;
  281.   online:=true;
  282.   writelog (0,3,'');
  283.   if (unum>0) and not disconnected then updateuserstats (true);
  284.   forcehangup:=true;
  285.   disconnected:=true;
  286.   hangup;
  287. end;
  288.  
  289. begin
  290. end.
  291.