home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FAQ-S.ZIP / NETMAIL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-12-13  |  11.0 KB  |  389 lines
  1. procedure systemlist;
  2. var card,ugbot,p:lstr;
  3.     nl:netmailrec;
  4.  
  5.    function numbbses:integer;
  6.    begin
  7.      numbbses:=filesize(nmfile)
  8.    end;
  9.  
  10.    procedure seeknmfile (n:integer);
  11.    begin
  12.      seek (nmfile,n-1);
  13.    end;
  14.  
  15.    function numbbs:integer;
  16.    begin
  17.     numbbs:=filesize (nmfile);
  18.    end;
  19.  
  20.    procedure getstring (t:lstr; var m; buf:integer);
  21.    var q:lstr absolute m;
  22.        mm:lstr;
  23.    begin
  24.      writeln (^R'Old ',t,': '^S,q,^R);
  25.      buflen:=buf;
  26.      writestr ('Enter new '+t+' [CR/no change]:');
  27.      mm:=input;
  28.      if length(mm)<>0 then q:=mm;
  29.      writeln
  30.    end;
  31.  
  32.     procedure listbbs;
  33.     var cnt,b1,b2:integer;
  34.         showedz:boolean;
  35.     begin
  36.      writehdr ('FAQ-Paket List');
  37.      reset (nmfile);
  38.      if ioresult<>0 then begin
  39.       writeln ('There are no systems in the FAQ-Paket list.');
  40.       exit;
  41.      end
  42.      else begin
  43.      parserange (numbbs,b1,b2);
  44.      if b1>0 then
  45.      for cnt:=b1 to b2 do
  46.      begin
  47.       seeknmfile (cnt);
  48.       read (nmfile,nl);
  49.       write (^R'['^S);
  50.       tab (nl.number,12);
  51.       write (^R'] ['^P);
  52.       tab (nl.name,48);
  53.       write (^R'] ['^U);
  54.       tab (nl.maxbaud,4);
  55.       write (^R'] ['^P);
  56.       tab (nl.priority,2);
  57.       writeln (^R']');
  58.      end;
  59.     end;
  60.     end;
  61.  
  62.   function getbnum (txt:mstr):integer;
  63.   var n:integer;
  64.   begin
  65.     getbnum:=0;
  66.     repeat
  67.       writeln;
  68.       writestr ('FAQ-Packet Number to '+txt+' [?/List]:');
  69.       if length(input)=0 then exit;
  70.       if upcase(input[1])='?'
  71.         then listbbs
  72.         else begin
  73.           n:=valu(input);
  74.           if (n<1) or (n>numbbs) then begin
  75.             writestr (^M'Number does not meet range requirements.');
  76.             exit
  77.           end;
  78.           seeknmfile (n);
  79.           read (nmfile,nl);
  80.           getbnum:=n;
  81.           exit
  82.         end
  83.     until hungupon
  84.   end;
  85.  
  86.     procedure addbbs;
  87.     begin
  88.      writehdr ('Add a BBS');
  89.      writeln (^R'Phone Number [12 Characters Max]');
  90.      writeln (^R' [------------]');
  91.      buflen:=12;
  92.      writestr (': &');
  93.      nl.number:=input;
  94.      writeln;
  95.      writeln (^R'Enter BBS Name [48 Characters Max]');
  96.      writeln (^R' [------------------------------------------------]');
  97.      buflen:=48;
  98.      writestr (': &');
  99.      nl.name:=input;
  100.      writeln;
  101.      writeln (^R'Maximum Baud [4 Digits] (ie 2400,4800,9600,19.2)');
  102.      writeln (^R' [----]');
  103.      buflen:=4;
  104.      writestr (': &');
  105.      nl.maxbaud:=input;
  106.      writeln;
  107.      writeln (^R'FAQNet-Packet network priority');
  108.      writeln (^R' [--]');
  109.      buflen:=2;
  110.      writestr (': &');
  111.      nl.priority:=input;
  112.      if (length(nl.number)>0) and (length(nl.name)>0) and (length(nl.maxbaud)>0)
  113.      and (length(nl.priority)>0) then begin
  114.       if not exist (textdir+'FAQPACK.'+strr(conn)) then rewrite (nmfile);
  115.       seeknmfile (numbbses+1);
  116.       write (nmfile,nl);
  117.       writeln (^M^S'System added to packet processing list.'^R^M);
  118.       writelog (6,1,nl.name);
  119.      end else
  120.      writeln (^M^S'Entry incomplete!'^R^M);
  121.      end;
  122.  
  123.   procedure changebbs;
  124.   var q,spock:integer;
  125.       doodzdomain:char;
  126.       phortune:boolean;
  127.  
  128.    procedure showbbs (nl:netmailrec);
  129.    begin
  130.    writeln (^M^R'['^S'1'^R'] BBS Name       :  '^S,nl.name,
  131.             ^M^R'['^S'2'^R'] BBS Number     :  '^S,nl.number,
  132.             ^M^R'['^S'3'^R'] Maximum Baud   :  '^S,nl.maxbaud,
  133.             ^M^R'['^S'4'^R'] Packet Priority:  '^S,nl.priority,
  134.             ^M^R'['^S'Q'^R'] Quit');
  135.    end;
  136.  
  137.    begin
  138.        reset (nmfile);
  139.        if ioresult<>0 then begin
  140.        writeln ('There are no systems in the FAQ-Paket list.');
  141.        exit;
  142.        end;
  143.        writehdr ('Change an Entry');
  144.        phortune:=false;
  145.        repeat
  146.        writestr (^M'Entry to Change [?/List]: &');
  147.        if input[1]='?' then listbbs else begin
  148.        spock:=valu(input);
  149.        if spock<1 then exit;
  150.        if spock>numbbs then exit;
  151.        seeknmfile (spock);
  152.        read (nmfile,nl);
  153. {       if (not (match (nl.leftby,unam))) and (ulvl<sysoplevel) then begin
  154.         writeln (^M'That entry was not placed by you.'^M);
  155.         exit;
  156.        end;
  157.  }      phortune:=true;
  158.        writelog (16,3,nl.name);
  159.        repeat
  160.        showbbs (nl);
  161.        writestr (^P'['^R'Edit FAQ-Paket BBS List Command'^P'] ['^R'?'^P'/'^R'Help'^P']'
  162.        +^S': *');
  163.        doodzdomain:=upcase(input[1]);
  164.        case doodzdomain of
  165.         '1':getstring ('BBS Name',nl.name,48);
  166.         '2':getstring ('BBS Number',nl.number,12);
  167.         '3':getstring ('Maximum Baud',nl.maxbaud,4);
  168.         '4':getstring ('Packet Priority',nl.priority,2);
  169.         'Q':;
  170.        end;
  171.        until doodzdomain='Q';
  172.        seeknmfile (spock);
  173.        write (nmfile,nl);
  174.        end;
  175.        until phortune;
  176.       end;
  177.  
  178.   procedure deletebbs;
  179.   var i,n,cnt:integer;
  180.       c:char;
  181.       maniaclame:boolean;
  182.   begin
  183.        reset (nmfile);
  184.        if ioresult<>0 then begin
  185.        writeln ('There are no systems in the FAQ-Paket list.');
  186.        exit;
  187.        end;
  188.   {if numbbs<1 then begin
  189.     writeln (^M'There are no systems currently in the listings'^M);
  190.     exit;
  191.    end;}
  192.    writehdr ('Delete an Entry');
  193.    n:=getbnum ('Delete');
  194.    if n=0 then exit;
  195.    seeknmfile (n);
  196.    read (nmfile,nl);
  197.    if not issysop then
  198.   writeln;
  199.    writeln (^R'['^S,nl.name,^R'] - ['^S,nl.number,^R']');
  200.    writeln;
  201.    writestr ('Delete this entry? [y/n]: *');
  202.    if not yes then exit;
  203.    writelog (6,2,nl.name);
  204.     for cnt:=n to numbbs-1 do begin
  205.       seeknmfile (cnt+1);
  206.       read (nmfile,nl);
  207.       seeknmfile (cnt);
  208.       write (nmfile,nl)
  209.     end;
  210.     seeknmfile (numbbs);
  211.     truncate (nmfile);
  212.    { writelog ('Deleted BBS Entry "',nl.leftby,'"'); }
  213.   end;
  214.  
  215.   procedure bbslistsysop;
  216.   begin
  217.      if ulvl<sysoplevel then begin
  218.       reqlevel (sysoplevel);
  219.       exit;
  220.      end;
  221.      writelog (6,4,unam);
  222.      writeln;
  223.      repeat
  224.       ugbot:=' ';
  225.       writeln  (^R'['^S'D'^R']elete an Entry');
  226.       writeln  (^R'['^S'C'^R']hange an Entry');
  227.       writeln  (^R'['^S'Q'^R']uit');
  228.       writeln;
  229.       writestr ('[BBS List Sysop Command]:');
  230.       ugbot:=upstring(input);
  231.       case ugbot[1] of
  232.        'D':deletebbs;
  233.        'C':changebbs;
  234.        'Q':;
  235.       end;
  236.      until (ugbot[1]='Q');
  237.     end;
  238.  
  239. label exit;
  240. var q:integer;
  241. begin
  242.     assign (nmfile,textdir+'faqpack.'+strr(conn));
  243.     if exist (textdir+'faqpack.'+strr(conn)) then reset (nmfile);
  244.     repeat
  245.      q:=menu ('FAQNet-Packet System List Menu','PACKUP','LADC%Q');
  246.      writeln;
  247.      case q of
  248.       1:listbbs;
  249.       2:addbbs;
  250.       3:deletebbs;
  251.       4:changebbs;
  252.       5:bbslistsysop;
  253.       6:goto exit;
  254.      end;
  255.      until (hungupon) or (q=6);
  256.     exit:
  257.     close (nmfile);
  258. end;
  259.  
  260. procedure netmailsend;
  261.  
  262. var ib,ib2,ib3:integer;
  263.     f5:file of bulrec;
  264.     fit:bulrec;
  265.     hardf:file of message;
  266.     textf:message;
  267.     f1,f2:text;
  268.     nla:netlistrec;
  269.     filename:mstr;
  270.     filename2:mstr;
  271.     curb:boardrec;
  272.     priority:string[2];
  273.  
  274.   function numnetfiles:integer;
  275.    begin
  276.      numnetfiles:=filesize(nlifile)
  277.    end;
  278.  
  279.    procedure seeknlifile (n:integer);
  280.    begin
  281.      seek (nlifile,n-1);
  282.    end;
  283.  
  284.  
  285.   procedure getnetbrec;
  286.   begin
  287.     if checkcurbul then begin
  288.       seekbfile (curbul);
  289.       read (bfile,b); che;
  290.      seek(f5,filesize(f5));
  291.       write(f5,b);
  292.     end
  293.   end;
  294.  
  295.  procedure writedatanli;
  296.   begin
  297.      assign (nlifile,networkdir+'NETFILE.'+strr(conn));
  298.     if exist (networkdir+'NETFILE.'+strr(conn)) then reset (nlifile);
  299.      nla.filename:=filename;
  300.      nla.prioritya:=priority;
  301.      if (length(nla.filename)>0) and (length(nla.prioritya)>0) then begin
  302.       if not exist ('netfile.'+strr(conn)) then rewrite (nlifile);
  303.       seeknlifile (numnetfiles+1);
  304.       write (nlifile,nla);
  305.       writeln (^S'There are '^R,numnetfiles,^S' on the processing list.');
  306.       writeln (^S'File placed on packet processing list.'^R);
  307.       writelog (6,1,nla.filename);
  308.       close (nlifile);
  309.      end;
  310.   end;
  311.  
  312. begin
  313. if not curboard.net then begin
  314. writeln (^R'Subboard doesn''t support FAQNet!');
  315. exit;
  316. end;
  317. if not usenet or not netsubs then begin
  318. writeln (^R'Configuration doesn''t use FAQNet!');
  319. exit;
  320. end;
  321. {writestr('Have you switched to the proper area to transmit? *');
  322. if yes then
  323.   begin}
  324.     writeln ('Current Bulletin :'^S,curbul);
  325.     writeln ('Last Bulletin    :'^S,numbuls);
  326.     writeln;
  327.     buflen:=7;
  328.     writestr('Enter starting message to send : *');
  329.     if (length(input)>0) then
  330.           begin
  331.             val(input,ib,ib2);
  332.              if (ib>0) and (ib<=numbuls) then
  333.                begin
  334.  writeln('Preparing FAQpaket consisting of messages '^S,ib,^R' to '^S,numbuls);
  335.                 {repeat
  336.                  buflen:=7;
  337.                  writestr('Please enter filename: *');
  338.                  until (length(input)>0);
  339.                  filename:=input;}
  340.                  filename:=strr(conn)+'NET'+curboard.shortname;
  341.                  filename2:='NETSEND'+strr(conn);
  342.                  writestr('Please enter priority: *');
  343.                  priority:=input;
  344.                  assign(f5,networkdir+filename+'.SQ'+strr(conn));
  345.                  rewrite(f5);
  346.                  assign(hardf,networkdir+filename+'.ME'+strr(conn));
  347.                  rewrite(hardf);
  348.                  curbul:=ib;
  349.                  for ib3:=ib to numbuls do
  350.                    begin
  351.                     getnetbrec;
  352.                     reloadtext(b.line,textf);
  353.                     seek(hardf,filesize(hardf));
  354.                     textf.text[textf.numlines+1]:=^R'            ';
  355.                     textf.text[textf.numlines+2]:=^R'- FAQNet v'+netver+' Origin: '+longname+' '+strr(netnum)+' -';
  356.                     textf.text[textf.numlines+3]:=^R'- '+netcomment+'  Posted: '+datestr(now)+' - '+timestr(now)+' -';
  357.                     textf.numlines:=textf.numlines+3;
  358.                     write(hardf,textf);
  359.                     inc(curbul);
  360.                    end;
  361.                  close(f5);
  362.                  close(hardf);
  363.                  writeln('Please wait - placing compression/encosion on file');
  364.                  addtozip(networkdir+filename2+'.ZIP',networkdir+filename+'.SQ'+strr(conn)+' '+networkdir+filename
  365.                  +'.ME'+strr(conn));
  366.                  assign (f1,networkdir+filename+'.SQ'+strr(conn));
  367.                  assign (f2,networkdir+filename+'.ME'+strr(conn));
  368.                  reset (f1);
  369.                  reset (f2);
  370.                  rewrite (f1);
  371.                  rewrite (f2);
  372.                  textclose(f1);
  373.                  textclose(f2);
  374.                  reset(f1);
  375.                  reset(f2);
  376.                  writeln(f1,'  ');
  377.                  writeln(f2,'  ');
  378.                  erase (f1);
  379.                  erase (f2);
  380.                  textclose (f1);
  381.                  textclose (f2);
  382.                  writedatanli;
  383.                  writeln(^R'FAQNet package for Sub '^P'['^S+curboard.shortname+^P']'^R' prepared for transmital.');
  384.                end;
  385.           end;
  386.  {end
  387.   else writeln('FAQpaket preparation stopped.');}
  388. end;
  389.