home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 153.img / TELES.ZIP / UNIT2.PAS < prev    next >
Pascal/Delphi Source File  |  1988-07-24  |  17KB  |  532 lines
  1. {$R-}    {Range checking off}
  2. {$B+}    {Boolean complete evaluation on}
  3. {$S+}    {Stack checking on}
  4. {$I+}    {I/O checking on}
  5. {$N-}    {No numeric coprocessor}
  6. {$V-}
  7.  
  8.  
  9. Unit Unit2;
  10.  
  11. Interface
  12.  
  13. Uses
  14.   Crt,
  15.   Dos,
  16.   Common,
  17.   Unit0,
  18.   UnitX,
  19.   Unit1,
  20.   BoardEdt,
  21.   SysopUt,
  22.   FileSc,
  23.   MenuEdt;
  24.  
  25. procedure bulletins;
  26. procedure chuser;
  27. procedure pstat;
  28. procedure mailr;
  29. procedure init;
  30. procedure hangupphone;
  31. procedure zlog;
  32. PROCEDURE scan2(var cn:integer; iread:newtyp; var quit:boolean);
  33. procedure scan1;
  34. procedure getcaller;
  35. procedure qscan(var quit:boolean; tf:boolean);
  36. procedure nscan;
  37.  
  38. Implementation
  39.  
  40. procedure chuser;
  41. var n:integer;
  42. begin
  43.   if checkpw then begin
  44.     prt('Which user? ');
  45.     finduser(n);
  46.     if n>0 then begin
  47.       thisuser.sl:=realsl;
  48.       thisuser.dsl:=realdsl;
  49.       reset(uf);
  50.       seek(uf,usernum);
  51.       write(uf,thisuser);
  52.       seek(uf,n);
  53.       read(uf,thisuser);
  54.       close(uf);
  55.       realsl:=thisuser.sl;
  56.       realdsl:=thisuser.dsl;
  57.       usernum:=n;
  58.       if spd<>'KB' then sysoplog('#*#*#*# '+#3+#8+'Changed to '+nam);
  59.       topscr;
  60.     end;
  61.   end;
  62. end;
  63.  
  64. procedure pstat;
  65. var c:char;
  66. begin
  67.   outkey(chr(12));
  68.   with systat do begin
  69.     print('New User Pass   : '+boardpw);
  70.     prompt('Board is        : '); if closedsystem then print('Closed') else print('Open');
  71.     print('Number Users    : '+cstr(users));
  72.     print('Number calls    : '+cstr(callernum));
  73.     print('Date            : '+lastdate);
  74.     print('Time            : '+time);
  75.     print('Active today    : '+cstr(activetoday));
  76.     print('Calls today     : '+cstr(callstoday));
  77.     print('Messages today  : '+cstr(msgposttoday));
  78.     print('Email sent today: '+cstr(emailtoday));
  79.     print('Feed back today : '+cstr(fbacktoday));
  80.     print('Up today        : '+cstr(uptoday));
  81.     prompt('Sysop           : '); if sysop then begin sprompt(SYSTAT.SYSOPIN); end
  82.       else begin sprompt(SYSTAT.SYSOPOUT); nl; end;
  83.     print('Files waiting   : '+cstr(fw));
  84.     print('Disk free space : '+cstr(freek(0))+'k');
  85.     prompt('Sysop hours     : ');
  86.     if lowtime=hitime then
  87.       print('None')
  88.     else
  89.       print(tch(cstr(lowtime div 60))+':'+tch(cstr(lowtime mod 60))+' to '+
  90.                 tch(cstr(hitime div 60))+':'+tch(cstr(hitime mod 60)));
  91.  
  92.   end;
  93.   if not useron then begin
  94.     nl;nl;print('Hit any key');
  95.     getkey(c);
  96.   end;
  97. end;
  98.  
  99. procedure mailr;
  100. var ii:integer; mr:mailrec; abort,a:boolean; c:char; u:userrec; is:astr;
  101. begin
  102.   readingmail:=true;
  103.   {$I-} reset(mailfile); {$I+} c:=' ';
  104.   if ioresult=0 then begin
  105.     reset(uf);
  106.     ii:=filesize(mailfile)-1; c:=' ';
  107.     while (ii>=0) and (c<>'Q') and (not hangup) do begin
  108.       seek(mailfile,ii); read(mailfile,mr);
  109.       if mr.destin<>-1 then begin
  110.         repeat
  111.           seek(uf,mr.destin); read(uf,u); if systat.clearmsg then cls;
  112.           cl(1);prompt('  Title: ');cl(3);print(mr.title);
  113.           cl(1);prompt('     To: ');cl(9);print(u.name+' #'+cstr(mr.destin));
  114.           a:=true;
  115.           readmsg(mr.msg,a,next);
  116.           prt('Mail Read (R:e-read,D:elete,Q:uit,<space>,?) : ');
  117.           if next then c:=' ' else getkey(c); c:=upcase(c); print(c);
  118.           if c='D' then begin
  119.             close(uf); is:=rmail(ii); reset(uf);
  120.             if usernum=mr.destin then thisuser.waiting:=thisuser.waiting-1;
  121.           end;
  122.           nl;nl;
  123.         until (c<>'R') or hangup;
  124.       end;
  125.       ii:=ii-1;
  126.     end;
  127.     close(mailfile);
  128.     close(uf);
  129.   end;
  130.   readingmail:=false;
  131. end;
  132.  
  133. procedure init;
  134. var a,b,c:integer;
  135.     vdf:file of vdatar;
  136.     vd:vdatar;
  137.     fi:text;
  138.     i:astr;
  139.     f:file;
  140.     ch1:char;
  141. begin
  142.   if daynum(date)=0 then begin
  143.     clrscr;
  144.     writeln('Please set the date & time, it is required for operation.');
  145.     halt;
  146.   end;
  147.   initp1;
  148.   assign(vdf,systat.gfilepath+'voting.dat');
  149.   {$I-} reset(vdf); {$I+}
  150.   if ioresult=0 then begin
  151.     for a:=1 to 9 do begin
  152.       read(vdf,vd);
  153.       vqu[a]:=vd.numa<>0;
  154.     end;
  155.     close(vdf);
  156.   end else for a:=1 to 9 do vqu[a]:=false;
  157.   a:=freek(0);
  158.   {errorptr:=ofs(erhnd);}
  159. {!^ 62. Use the new ExitProc facility to replace ErrorPtr references.}
  160. end;
  161.  
  162. procedure hangupphone;
  163. var rl:real; try:integer;
  164.   procedure dely(r:real);
  165.   var r1:real;
  166.   begin
  167.     r1:=timer;
  168.     while abs(timer-r1)<r do;
  169.   end;
  170.  
  171. begin
  172.   try:=0;
  173.   term_ready(false);
  174.   while (try<2) and cdet do begin
  175.     dely(2.0);
  176.     pr1(#1#1#1);
  177.     rl:=timer;
  178.     while (cinkey<>'0') and (abs(timer-rl)<2.0) do;
  179.     dely(0.8);
  180.     pr(systat.hangup);
  181.     try:=try+1;
  182.     dely(0.3);
  183.   end;
  184. end;
  185.  
  186. procedure zlog;
  187. var d1:zlogt; n:integer; i:astr; zf:file of zlogt; abort,next:boolean;
  188.  
  189.   function f(x,n:integer):astr;
  190.   var i:astr;
  191.   begin
  192.     i:=cstr(x);
  193.     while length(i)<n do
  194.       i:=' '+i;
  195.     f:=i;
  196.   end;
  197.  
  198. begin
  199.   assign(zf,systat.gfilepath+'zlog.dat');
  200.   {$I-} reset(zf); {$I+}
  201.   if ioresult=0 then begin
  202.     abort:=false;
  203.     read(zf,d1);
  204.     cl(3);printacr(
  205.       '  Date     Calls  Active   Posts   Email   Fback     U/L    %Act   T/user',abort,next);
  206.     cl(2);printacr(
  207.       '--------   -----  ------   -----   -----   -----     ---    ----   ------',abort,next);
  208.     while (not abort) and (d1.date<>'') do begin
  209.       i:=d1.date+f(d1.calls,8)+f(d1.active,8)+f(d1.post,8)+f(d1.email,8)+
  210.          f(d1.fback,8)+f(d1.up,8)+f(trunc(100.0*d1.active/1440.0),8);
  211.       if d1.calls>0 then i:=i+f(d1.active div d1.calls,9);
  212.       printacr(i,abort,next);
  213.       if eof(zf) then
  214.         abort:=true
  215.       else
  216.         read(zf,d1);
  217.     end;
  218.   end;
  219.   close(zf);
  220. end;
  221.  
  222. PROCEDURE scan2(var cn:integer; iread:newtyp; var quit:boolean);
  223. var unvali,uv,pq,donescan,abort,next:boolean; i:astr; t:integer;
  224.  b:messagerec;
  225. begin
  226.   quit:=false;pq:=false; unvali:=false;
  227.   donescan:=false;
  228.   repeat
  229.     if iread=lt then begin cn:=cn+1; titles(cn); iread:=rp; end;
  230.     if iread=rp then begin
  231.       topscr;
  232.       rep:=false;
  233.       cl(5);prompt('['+(cstr(cn))+'] ');cl(3);
  234.       prompt('Read:(W,P,T,Q,B,D,A,M,1-'+cstr(tnum)+',<CR>) :');cl(5);
  235.       input(i,4); t:=value(i);
  236.       if (i='R') then begin t:=cn; i:=cstr(t); wantfilename:=false; end;
  237.       if (i='L') then begin t:=cn; i:=cstr(t); wantfilename:=true; end;
  238.       if (i<>'') and (t=0) then case i[1] of
  239.         'P':post;
  240.         'T':iread:=lt;
  241.         'Q':begin quit:=true; donescan:=true; end;
  242.         'B':donescan:=true;
  243.         'D':if lcs and (cn>0) and (cn<=tnum) then begin
  244.               deletem(cn); cn:=cn-1;
  245.             end;
  246.         'A':autoreply;
  247.         'M':if cs then movemsg(cn);
  248.         'W':begin rep:=true; irt:=irt+' (Msg #'+cstr(cn)+')'; post; end;
  249.         '?':begin
  250.               nl; cl(5);
  251.               print('- Message Commands -'); nl;
  252.               print('#:message to read   <CR>:next msg');
  253.               print('T:itles  Q:uit  P:ost  A:uto-reply');
  254.               print('R:e-read B:next board in N-scan');
  255.               print('W:rite reply to current message');nl;
  256.               if so then begin
  257.               cl(5);print('- Sysop Functions -');
  258.                 nl;
  259.                 print('L:ist message with filename');
  260.                 print('D:elete message');
  261.                 print('M:ove message to different base');nl;
  262.               end;
  263.             end;
  264.       end else begin
  265.         if (t>0) and (t<=tnum) then begin
  266.           cn:=t;
  267.           iread:=rm;
  268.         end else if i='' then begin
  269.           t:=cn+1;
  270.           if t<=tnum then begin
  271.             cn:=t;
  272.             iread:=rm;
  273.           end else begin donescan:=true; pq:=true; end;
  274.         end;
  275.       end;
  276.     end;
  277.     if (iread=rm) and (cn>0) and (cn<=tnum) then begin
  278.       readm(cn,next,uv); if uv then unvali:=true;
  279.       if next then cn:=cn+1 else iread:=rp;
  280.       mread:=mread+1; tleft;
  281.       if (mread>=extramsgs+seclev[thisuser.sl].mallowed)
  282.       and (thisuser.sl<>255) and (thisuser.ontoday<>1) then begin
  283.         print('You have read all your messages.');
  284.         hangup:=true;
  285.       end;
  286.       if (mread+5=extramsgs+seclev[thisuser.sl].mallowed) and (thisuser.ontoday<>1) then
  287.         print('5 messages left until forced logoff');
  288.     end else if iread=rm then iread:=rp;
  289.     if (iread=rm) and (cn=tnum+1) then begin donescan:=true; pq:=true; end;
  290.   until donescan or hangup;
  291.   if unvali and lcs then begin
  292.     ynq(chr(7)+'Validate messages here? ');
  293.     if yn then for t:=1 to tnum do
  294.       if mary[t].messagestat<>validated then
  295.         mary[t].messagestat:=validated;
  296.     bchanged:=true;
  297.   end;
  298.   if pq and (thisuser.sl>=boards[board].postsl) and not (rpost in thisuser.ac)
  299.         and ((ptoday<seclev[thisuser.sl].posts) or (thisuser.sl>55)) then begin
  300.     nl; ynq('Post on '+boards[board].name+'? ');
  301.     if yn then post;
  302.   end;
  303.   nl;
  304. end;
  305.  
  306. procedure scan1;
  307. var cn:integer; i:astr; quit:boolean;
  308. begin
  309.   iscan;
  310.   print(cstr(tnum)+' msgs on '+boards[board].name);
  311.   if tnum<>0 then begin
  312.     prt('Start listing at (Q=quit)? ');
  313.     input(i,4);
  314.     cn:=value(i); if cn<=0 then cn:=0 else if cn>tnum then cn:=tnum else cn:=cn-1;
  315.     end else i:='S';
  316.     if i='S' then scan2(cn,rp,quit) else
  317.       if (i<>'Q') then
  318.         if i='N' then begin
  319.           cn:=1;
  320.           while (not greater(mary[cn].message)) and (cn<tnum) do
  321.             cn:=cn+1;
  322.           cn:=cn-1;
  323.           if greater(mary[cn].message) then scan2(cn,lt,quit);
  324.         end else scan2(cn,lt,quit);
  325.   savebase;
  326. end;
  327.  
  328. procedure getcaller;
  329. var c:char; x:smr; chkcom:boolean; rl,rl1,rl2:real; i:astr; wfcm:boolean; duh,txt:integer;
  330.  
  331.   procedure init1;
  332.   begin
  333.     if (systat.init<>'') then begin
  334.       clrscr;textcolor(9);write('■ ');textcolor(11);rl2:=timer;
  335.       write('Initializing modem');
  336.       wfcm:=false;
  337.       set_baud(systat.maxbaud);
  338.       pr(systat.init);
  339.       dump;
  340.     end;
  341.   end;
  342.  
  343.   procedure i1;
  344.   begin
  345.     init1; c:=#0; rl:=timer;
  346.     repeat
  347.       c:=cinkey;if abs(timer-rl)>4.0 then begin init1; rl:=timer; end;
  348.     until c=#13; delay(50);
  349.   end;
  350.  
  351. begin
  352.   duh:=0;  txt:=0;
  353.   wfcm:=false; wantfilename:=false; windowon:=systat.bwindow; nopfile:=false;
  354.   buf:=''; enddayf:=false; delay(50); close(sysopf); append(sysopf); reading_a_msg:=false;
  355.   dump; mailread:=false; smread:=false; andwith:=255; checkit:=false;
  356.   curco:=7; sdc; window(1,1,80,25); beepend:=false;
  357.   outcom:=false; useron:=false; ll:=''; chatr:='';
  358.   hangup:=false; usernum:=0; chatcall:=false; hungup:=false;
  359.   term_ready(true); if answerbaud<2 then i1; clrscr;thisline:=''; okt:=false;
  360.   if systat.users>0 then
  361.     begin reset(uf); seek(uf,1); read(uf,thisuser); close(uf); usernum:=1; end
  362.   else with thisuser do begin
  363.     linelen:=80; pagelen:=25; defaults:=[]; option:=[];
  364.   end;
  365.   repeat
  366.   if (wfcm=false) and (lmsg=true) then lmsg:=false;
  367.   if not wfcm then begin wfcmenu;wfcm:=true; end;
  368.     if daynum(date)<>ldate then
  369.       if (daynum(date)-ldate)=1 then
  370.         ldate:=ldate+1
  371.       else begin
  372.         clrscr;
  373.         textcolor(9);write('■ ');textcolor(11);writeln('Date corrupted.');
  374.         halt(1);
  375.       end;
  376.     randomize; incom:=false; outcom:=false;
  377.     hangup:=false; hungup:=false; irt:=''; lastname:=''; macok:=true; cfo:=false;
  378.     spd:='KB'; c:=#0; chkcom:=false;chattime:=0.0; extratime:=0.0;
  379.     sdc; bread:=0; lil:=0; cursoroff; if systat.special then duh:=duh+1;
  380.     if duh=30 then begin
  381.       duh:=0; txt:=txt+1; if txt>13 then txt:=0; tc(txt);
  382.       tc(txt);gotoxy(1,1); write('   ─────────────────');
  383.       tc(txt);gotoxy(59,1); write(' ────────────────');
  384.       tc(txt+1);gotoxy(1,2); write('────────────────────');
  385.       tc(txt+1);gotoxy(59,2); write(' ────────────────────');
  386.       tc(txt+2);gotoxy(1,3); write('   ─────────────────');
  387.       tc(txt+2);gotoxy(59,3); write(' ────────────────');
  388.     end;
  389.     textcolor(11);
  390.     gotoxy(16,14);write(time);gotoxy(16,15);write(date);
  391.     if (time='04:00:00') and (nightly) then begin
  392.       clrscr; writeln('Time for nightly events.');
  393.       sl1('[> Ran nightly events at '+time);
  394.       exec('\command.com','/c night.bat');
  395.       sl1('[> Returned from nightly events at '+time); iport;
  396.       i1;
  397.     end;
  398.     gotoxy(41,17);if sysop then write('Available') else write('Not here ');
  399.     textcolor(3);gotoxy(2,24);
  400.     if lmsg=true then begin lmain:=true; lmsg:=false; wfcm:=false; end;
  401.     if answerbaud>2 then c:='A';
  402.     if returna=true then begin returna:=false; c:='A'; end else
  403.     if answerbaud<2 then c:=inkey;
  404.     if c<>#0 then begin
  405.       cursoron;
  406.       c:=upcase(c);
  407.       wfcm:=false;cls;
  408.       CL(1);
  409.       case c of
  410.         '#':Menu_edit;
  411.         'U':if usernum=1 then dosj('U');
  412.         ' ':begin
  413.               write('Log on? '); rl2:=timer;
  414.               while (not keypressed) and (abs(timer-rl2)<60.0) do;
  415.               if keypressed then c:=readkey else c:='N'; c:=upcase(c); writeln(c);
  416.               if c='Y' then begin
  417.               c:=' '
  418.               END else c:='@';
  419.             end;
  420.         'Q':begin elevel:=0; hangup:=true; doneday:=true; end;
  421.         'L':begin close(sysopf); printfile(systat.gfilepath+'sysop.log');
  422.               pausescr; append(sysopf);
  423.             end;
  424.         'Y':begin printfile(systat.gfilepath+'ysysop.log'); pausescr; end;
  425.         'A':chkcom:=true;
  426.         'M':mailr;
  427.         'T':begin term; if returna=false then if answerbaud<>1 then i1; end;
  428.         'B':boardedit;
  429.         'I':initvotes;
  430.         'E':dosj('E');
  431.         '=':exec('\command.com','/c sysop.exe');
  432.         'P':changestuff;
  433.         'F':dlboardedit;
  434.         'R':if (systat.users>0) and (thisuser.waiting>0) then begin
  435.               writeln('Feedback: '); nl; nl;
  436.               macok:=true; readmail; macok:=false;
  437.               reset(uf); seek(uf,1); write(uf,thisuser); close(uf);
  438.             end;
  439.         'Z':begin zlog; pausescr; end;
  440.        'X':if answerbaud<>1 then i1;
  441.        'D':SysopShell;
  442.        '/':begin clrscr; printfile(systat.gfilepath+'user.log'); pausescr; end;
  443.        'V':begin voteprint; printfile(systat.gfilepath+'votes.txt'); end;
  444.       end;
  445.       curco:=7; sdc; window(1,1,80,25); clrscr; dump;
  446.     end;
  447.     if c<>' ' then c:=#0;
  448.     if (c<>#0) or commpressed or chkcom then begin
  449.       getcallera(c,chkcom);
  450.       if c='X' then Begin WfcM:=False; if answerbaud<2 then i1;
  451.         If QuitAfterDone then begin elevel:=0; hangup:=true; doneday:=true; end;
  452.       End;
  453.     end;
  454.   until incom or (c=' ') or doneday;
  455.   etoday:=0; ptoday:=0; ftoday:=0; if not doneday then begin
  456.       window(1,1,80,25);
  457.       writeln('Baud = '+spd);
  458.     end;
  459.   curco:=7; sdc;
  460.   if incom then begin
  461.     outcom:=true;
  462.     set_baud(value(spd));
  463.     delay(700);
  464.   end else begin term_ready(false); incom:=false; outcom:=false; end;
  465.   timeon:=timer; ftoday:=0;
  466.   dump;
  467.   if windowon then window(1,1,80,21) else window(1,1,80,24);
  468.   lil:=0; okt:=true;
  469.   thisuser.defaults:=thisuser.defaults-[ansi];
  470.   thisuser.cols:=dcols; curco:=$07;
  471.   andwith:=255; checkit:=true; beepend:=false;
  472. end;
  473.  
  474. procedure qscan(var quit:boolean; tf:boolean);
  475. var cn:integer; i:astr;
  476. begin
  477.   iscan;
  478.   i:='#'+cstr(board);
  479.   cn:=1; nl;
  480.   cl(3);
  481.   print('[:New-scan '+boards[board].name+' '+i+' - '+cstr(tnum)+' msgs:]');
  482.   if (tnum<>0) then begin
  483.     if not tf then tf:=boardacpw(board);
  484.     if tf then begin
  485.       while (not greater(mary[cn].message)) and (cn<tnum) do
  486.         cn:=cn+1;
  487.       if greater(mary[cn].message) then scan2(cn,rm,quit) else quit:=false;
  488.     end;
  489.   end;
  490.   cl(4); print('[:'+boards[board].name+' New-scan done:]');
  491.   savebase;
  492. end;
  493.  
  494. procedure bulletins;
  495. var filv:Text; i:astr;
  496. begin
  497.   nl;
  498.   assign(filv,systat.gfilepath+'bulletin.msg');
  499.   {$I-} reset(filv); {$I+}
  500.   if ioresult<>0 then print('There are no bulletins today.') else
  501.   begin
  502.   close(filv);
  503.   printf(systat.gfilepath+'bulletin');
  504.   repeat
  505.     prt('Enter Bulletin Selection (#,?,Q=Quit) : ');
  506.     input(i,3); if i='' then i:='Q';
  507.     if i='?' then printf(systat.gfilepath+'bulletin');
  508.     if (i<>'Q') and (i<>'?') then printf(systat.gfilepath+'bullet'+i);
  509.   until (i='Q') or (hangup);
  510.   end;
  511. end;
  512.  
  513. procedure nscan;
  514. var quit:boolean;
  515. begin
  516.   nl;
  517.   ynq('Global new-scan? ');
  518.   if yn then begin
  519.   nl; cl(5); print(')[ New-scan All ](');
  520.   board:=1; quit:=false;
  521.   while (board<=numboards) and (not quit) and (not hangup) do begin
  522.    if (thisuser.qscn[board]) and not (boards[board].key='%') then
  523.      if boardac(board) then qscan(quit,false);
  524.    board:=board+1;
  525.   end;
  526.   nl; cl(5); print(')[ Global New-scan Done ]('); nl;
  527.   board:=1;
  528.  end else qscan(next,true);
  529. end;
  530.  
  531. END.
  532.