home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
f
/
faq-s.zip
/
NETMAIL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-12-13
|
11KB
|
389 lines
procedure systemlist;
var card,ugbot,p:lstr;
nl:netmailrec;
function numbbses:integer;
begin
numbbses:=filesize(nmfile)
end;
procedure seeknmfile (n:integer);
begin
seek (nmfile,n-1);
end;
function numbbs:integer;
begin
numbbs:=filesize (nmfile);
end;
procedure getstring (t:lstr; var m; buf:integer);
var q:lstr absolute m;
mm:lstr;
begin
writeln (^R'Old ',t,': '^S,q,^R);
buflen:=buf;
writestr ('Enter new '+t+' [CR/no change]:');
mm:=input;
if length(mm)<>0 then q:=mm;
writeln
end;
procedure listbbs;
var cnt,b1,b2:integer;
showedz:boolean;
begin
writehdr ('FAQ-Paket List');
reset (nmfile);
if ioresult<>0 then begin
writeln ('There are no systems in the FAQ-Paket list.');
exit;
end
else begin
parserange (numbbs,b1,b2);
if b1>0 then
for cnt:=b1 to b2 do
begin
seeknmfile (cnt);
read (nmfile,nl);
write (^R'['^S);
tab (nl.number,12);
write (^R'] ['^P);
tab (nl.name,48);
write (^R'] ['^U);
tab (nl.maxbaud,4);
write (^R'] ['^P);
tab (nl.priority,2);
writeln (^R']');
end;
end;
end;
function getbnum (txt:mstr):integer;
var n:integer;
begin
getbnum:=0;
repeat
writeln;
writestr ('FAQ-Packet Number to '+txt+' [?/List]:');
if length(input)=0 then exit;
if upcase(input[1])='?'
then listbbs
else begin
n:=valu(input);
if (n<1) or (n>numbbs) then begin
writestr (^M'Number does not meet range requirements.');
exit
end;
seeknmfile (n);
read (nmfile,nl);
getbnum:=n;
exit
end
until hungupon
end;
procedure addbbs;
begin
writehdr ('Add a BBS');
writeln (^R'Phone Number [12 Characters Max]');
writeln (^R' [------------]');
buflen:=12;
writestr (': &');
nl.number:=input;
writeln;
writeln (^R'Enter BBS Name [48 Characters Max]');
writeln (^R' [------------------------------------------------]');
buflen:=48;
writestr (': &');
nl.name:=input;
writeln;
writeln (^R'Maximum Baud [4 Digits] (ie 2400,4800,9600,19.2)');
writeln (^R' [----]');
buflen:=4;
writestr (': &');
nl.maxbaud:=input;
writeln;
writeln (^R'FAQNet-Packet network priority');
writeln (^R' [--]');
buflen:=2;
writestr (': &');
nl.priority:=input;
if (length(nl.number)>0) and (length(nl.name)>0) and (length(nl.maxbaud)>0)
and (length(nl.priority)>0) then begin
if not exist (textdir+'FAQPACK.'+strr(conn)) then rewrite (nmfile);
seeknmfile (numbbses+1);
write (nmfile,nl);
writeln (^M^S'System added to packet processing list.'^R^M);
writelog (6,1,nl.name);
end else
writeln (^M^S'Entry incomplete!'^R^M);
end;
procedure changebbs;
var q,spock:integer;
doodzdomain:char;
phortune:boolean;
procedure showbbs (nl:netmailrec);
begin
writeln (^M^R'['^S'1'^R'] BBS Name : '^S,nl.name,
^M^R'['^S'2'^R'] BBS Number : '^S,nl.number,
^M^R'['^S'3'^R'] Maximum Baud : '^S,nl.maxbaud,
^M^R'['^S'4'^R'] Packet Priority: '^S,nl.priority,
^M^R'['^S'Q'^R'] Quit');
end;
begin
reset (nmfile);
if ioresult<>0 then begin
writeln ('There are no systems in the FAQ-Paket list.');
exit;
end;
writehdr ('Change an Entry');
phortune:=false;
repeat
writestr (^M'Entry to Change [?/List]: &');
if input[1]='?' then listbbs else begin
spock:=valu(input);
if spock<1 then exit;
if spock>numbbs then exit;
seeknmfile (spock);
read (nmfile,nl);
{ if (not (match (nl.leftby,unam))) and (ulvl<sysoplevel) then begin
writeln (^M'That entry was not placed by you.'^M);
exit;
end;
} phortune:=true;
writelog (16,3,nl.name);
repeat
showbbs (nl);
writestr (^P'['^R'Edit FAQ-Paket BBS List Command'^P'] ['^R'?'^P'/'^R'Help'^P']'
+^S': *');
doodzdomain:=upcase(input[1]);
case doodzdomain of
'1':getstring ('BBS Name',nl.name,48);
'2':getstring ('BBS Number',nl.number,12);
'3':getstring ('Maximum Baud',nl.maxbaud,4);
'4':getstring ('Packet Priority',nl.priority,2);
'Q':;
end;
until doodzdomain='Q';
seeknmfile (spock);
write (nmfile,nl);
end;
until phortune;
end;
procedure deletebbs;
var i,n,cnt:integer;
c:char;
maniaclame:boolean;
begin
reset (nmfile);
if ioresult<>0 then begin
writeln ('There are no systems in the FAQ-Paket list.');
exit;
end;
{if numbbs<1 then begin
writeln (^M'There are no systems currently in the listings'^M);
exit;
end;}
writehdr ('Delete an Entry');
n:=getbnum ('Delete');
if n=0 then exit;
seeknmfile (n);
read (nmfile,nl);
if not issysop then
writeln;
writeln (^R'['^S,nl.name,^R'] - ['^S,nl.number,^R']');
writeln;
writestr ('Delete this entry? [y/n]: *');
if not yes then exit;
writelog (6,2,nl.name);
for cnt:=n to numbbs-1 do begin
seeknmfile (cnt+1);
read (nmfile,nl);
seeknmfile (cnt);
write (nmfile,nl)
end;
seeknmfile (numbbs);
truncate (nmfile);
{ writelog ('Deleted BBS Entry "',nl.leftby,'"'); }
end;
procedure bbslistsysop;
begin
if ulvl<sysoplevel then begin
reqlevel (sysoplevel);
exit;
end;
writelog (6,4,unam);
writeln;
repeat
ugbot:=' ';
writeln (^R'['^S'D'^R']elete an Entry');
writeln (^R'['^S'C'^R']hange an Entry');
writeln (^R'['^S'Q'^R']uit');
writeln;
writestr ('[BBS List Sysop Command]:');
ugbot:=upstring(input);
case ugbot[1] of
'D':deletebbs;
'C':changebbs;
'Q':;
end;
until (ugbot[1]='Q');
end;
label exit;
var q:integer;
begin
assign (nmfile,textdir+'faqpack.'+strr(conn));
if exist (textdir+'faqpack.'+strr(conn)) then reset (nmfile);
repeat
q:=menu ('FAQNet-Packet System List Menu','PACKUP','LADC%Q');
writeln;
case q of
1:listbbs;
2:addbbs;
3:deletebbs;
4:changebbs;
5:bbslistsysop;
6:goto exit;
end;
until (hungupon) or (q=6);
exit:
close (nmfile);
end;
procedure netmailsend;
var ib,ib2,ib3:integer;
f5:file of bulrec;
fit:bulrec;
hardf:file of message;
textf:message;
f1,f2:text;
nla:netlistrec;
filename:mstr;
filename2:mstr;
curb:boardrec;
priority:string[2];
function numnetfiles:integer;
begin
numnetfiles:=filesize(nlifile)
end;
procedure seeknlifile (n:integer);
begin
seek (nlifile,n-1);
end;
procedure getnetbrec;
begin
if checkcurbul then begin
seekbfile (curbul);
read (bfile,b); che;
seek(f5,filesize(f5));
write(f5,b);
end
end;
procedure writedatanli;
begin
assign (nlifile,networkdir+'NETFILE.'+strr(conn));
if exist (networkdir+'NETFILE.'+strr(conn)) then reset (nlifile);
nla.filename:=filename;
nla.prioritya:=priority;
if (length(nla.filename)>0) and (length(nla.prioritya)>0) then begin
if not exist ('netfile.'+strr(conn)) then rewrite (nlifile);
seeknlifile (numnetfiles+1);
write (nlifile,nla);
writeln (^S'There are '^R,numnetfiles,^S' on the processing list.');
writeln (^S'File placed on packet processing list.'^R);
writelog (6,1,nla.filename);
close (nlifile);
end;
end;
begin
if not curboard.net then begin
writeln (^R'Subboard doesn''t support FAQNet!');
exit;
end;
if not usenet or not netsubs then begin
writeln (^R'Configuration doesn''t use FAQNet!');
exit;
end;
{writestr('Have you switched to the proper area to transmit? *');
if yes then
begin}
writeln ('Current Bulletin :'^S,curbul);
writeln ('Last Bulletin :'^S,numbuls);
writeln;
buflen:=7;
writestr('Enter starting message to send : *');
if (length(input)>0) then
begin
val(input,ib,ib2);
if (ib>0) and (ib<=numbuls) then
begin
writeln('Preparing FAQpaket consisting of messages '^S,ib,^R' to '^S,numbuls);
{repeat
buflen:=7;
writestr('Please enter filename: *');
until (length(input)>0);
filename:=input;}
filename:=strr(conn)+'NET'+curboard.shortname;
filename2:='NETSEND'+strr(conn);
writestr('Please enter priority: *');
priority:=input;
assign(f5,networkdir+filename+'.SQ'+strr(conn));
rewrite(f5);
assign(hardf,networkdir+filename+'.ME'+strr(conn));
rewrite(hardf);
curbul:=ib;
for ib3:=ib to numbuls do
begin
getnetbrec;
reloadtext(b.line,textf);
seek(hardf,filesize(hardf));
textf.text[textf.numlines+1]:=^R' ';
textf.text[textf.numlines+2]:=^R'- FAQNet v'+netver+' Origin: '+longname+' '+strr(netnum)+' -';
textf.text[textf.numlines+3]:=^R'- '+netcomment+' Posted: '+datestr(now)+' - '+timestr(now)+' -';
textf.numlines:=textf.numlines+3;
write(hardf,textf);
inc(curbul);
end;
close(f5);
close(hardf);
writeln('Please wait - placing compression/encosion on file');
addtozip(networkdir+filename2+'.ZIP',networkdir+filename+'.SQ'+strr(conn)+' '+networkdir+filename
+'.ME'+strr(conn));
assign (f1,networkdir+filename+'.SQ'+strr(conn));
assign (f2,networkdir+filename+'.ME'+strr(conn));
reset (f1);
reset (f2);
rewrite (f1);
rewrite (f2);
textclose(f1);
textclose(f2);
reset(f1);
reset(f2);
writeln(f1,' ');
writeln(f2,' ');
erase (f1);
erase (f2);
textclose (f1);
textclose (f2);
writedatanli;
writeln(^R'FAQNet package for Sub '^P'['^S+curboard.shortname+^P']'^R' prepared for transmital.');
end;
end;
{end
else writeln('FAQpaket preparation stopped.');}
end;