home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 153.img / TELES.ZIP / COMMON.PAS < prev    next >
Pascal/Delphi Source File  |  1988-07-25  |  64KB  |  2,267 lines
  1. {$I-} { I/O hecking OFF }
  2. {$R-} { Range checking OFF }
  3. {$S-} { Stack checking OFF }
  4. {$V-} { Var-str checking OFF}
  5. {$B+} {Boolean complete evaluation on}
  6. {$N-} {No numeric coprocessor}
  7.  
  8. Unit Common;
  9.  
  10. Interface
  11.  
  12. Uses
  13.   Crt,
  14.   Dos,
  15.   Turbo3;
  16.  
  17. { global declarations  for Async}
  18.  
  19. type
  20.   astr = String[160];  { generic string type for parameters      }
  21.                        { note the change from Waynes str => Astr }
  22.  
  23. const
  24.   buffer_max = 5120;
  25.  
  26. var
  27.   Async_OriginalVector : pointer;
  28.   buffer       : Array[0..buffer_max] of char;
  29.  
  30.   Async_Open_Flag    : Boolean;   { true if Open but no Close }
  31.   Async_Port         : Integer;   { current Open port number (1 or 2) }
  32.   base               : Integer;   { base for current open port }
  33.   Async_Irq          : Integer;   { irq for current open port }
  34.  
  35.   Async_Buffer_Overflow : Boolean;  { True if buffer overflow has happened }
  36.   Async_Buffer_Used     : Integer;
  37.   Async_MaxBufferUsed   : Integer;
  38.  
  39.                  { buffer is empty if Head = Tail }
  40.   Buffer_head  : Integer;   { Locn in buffer to put next char }
  41.   Buffer_tail  : Integer;   { Locn in buffer to get next char }
  42.   Buffer_newtail : Integer;
  43.  
  44.  
  45. { End of Async declarations }
  46.  
  47. CONST strlen=160;
  48.       maxusers=500;
  49.       dsaves : Integer = 0;
  50.  
  51. TYPE restrictions=(rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,
  52.                    rpost,remail,rvoting,rmsg);
  53.      acrq='@'..'G';
  54.      newtyp=(rp,lt,rm);
  55.      deflts=(spcsr,onekey,wordwrap,pause,mmnu,ansi,color,music);
  56.      pnr=record name:string[40]; number:string[14]; hs:byte; end;
  57.      anontyp=(no,yes,forced,dearabby);
  58.      ansttype=(postn,emailn,pana,sanm,cosysop,lcosysop);
  59.      opts=(alert,smw,nomail);
  60.      dlnscan=set of 0..39;
  61.      emary=array[1..20] of integer;
  62.      clrs=array[false..true,0..9] of byte;
  63.      slr=record
  64.            ttime:byte;
  65.            mallowed:integer;
  66.            emails,posts:byte;
  67.            anst:set of ansttype;
  68.          end;
  69.      messages=record
  70.                 ltr:char;
  71.                 number:integer;
  72.                 ext:byte;
  73.               end;
  74.      smalrec=record
  75.                name:string[25];
  76.                number:integer;
  77.              end;
  78.      userrec=record
  79.                name:string[21];
  80.                realname:string[21];
  81.                deleted:boolean;
  82.                pw:string[20];
  83.                ph:string[12];
  84.                waiting:byte;
  85.                laston:string[10];
  86.                loggedon:integer;
  87.                msgpost:integer;
  88.                emailsent:integer;
  89.                feedback:integer;
  90.                linelen:byte;
  91.                pagelen:byte;
  92.                defaults:set of deflts;
  93.                ontoday:byte;
  94.                illegal:byte;
  95.                ttimeon:real;
  96.                dlnscn:dlnscan;
  97.                sl:byte;
  98.                ac:set of restrictions;
  99.                ar:set of acrq;
  100.                qscan:array[1..39] of messages;
  101.                qscn:array[1..39] of boolean;
  102.                macro:array[1..2] of string[79];
  103.                comptype:byte;
  104.                option:set of opts;
  105.                vote:array[1..20] of byte;
  106.                sbn:byte;
  107.                dsl:byte;
  108.                uploads,downloads:integer;
  109.                uk,dk:integer;
  110.                age:byte;
  111.                sex:char;
  112.                note:string[39];
  113.                forusr:integer;
  114.                res:array[1..70] of byte; (* Res[1] will be last msg base *)
  115.                filepoints:integer;
  116.                citystate:string[26];
  117.                street:string[21];
  118.                zipcode:string[10];
  119.                occupation:string[40];
  120.                wherebbs:string[40];
  121.                lockedout:boolean;
  122.                lockedfile:string[8];
  123.                computer:string[14];
  124.                cols:clrs;
  125.              end;
  126.       boardrec=record
  127.                  name:string[30];
  128.                  filename:string[12];
  129.                  sl:byte;
  130.                  maxmsgs:byte;
  131.                  pw:string[10];
  132.                  anonymous:anontyp;
  133.                  ar:acrq;
  134.                  key:char;
  135.                  postsl:byte;
  136.                end;
  137.       msgstat=(validated,unvalidated,deleted);
  138.       messagerec=record
  139.                    title:string[30];
  140.                    messagestat:msgstat;
  141.                    message:messages;
  142.                    owner:integer;
  143.                    date:integer;
  144.                    mage:byte;
  145.                  end;
  146.       systatrec=record
  147.                   boardpw:string[20];
  148.                   sysoppw:string[20];
  149.                   hmsg:messages;
  150.                   users:integer;
  151.                   lastdate:string[8];
  152.                   callernum:integer;
  153.                   activetoday:integer;
  154.                   callstoday:integer;
  155.                   msgposttoday:integer;
  156.                   emailtoday:integer;
  157.                   fbacktoday:integer;
  158.                   uptoday:integer;
  159.                   closedsystem:boolean;
  160.                   comport:byte;
  161.                   maxbaud:integer;
  162.                   msgpath:string[79];
  163.                   gfiledate:string[8];
  164.                   lowtime,hitime:integer;
  165.                   res:array[1..185] of byte;
  166.                   sysopcolor:byte;
  167.                   usercolor:byte;
  168.                   maxlines:byte;
  169.                   special:boolean;
  170.                   clearmsg:boolean;
  171.                   bbspw:string[20];
  172.                   matrix:boolean;
  173.                   engage:string[79];
  174.                   endchat:string[79];
  175.                   alias:boolean;
  176.                   echoc:char;
  177.                   sysopin:string[79];
  178.                   sysopout:string[79];
  179.                   note:array[1..2] of string[79];
  180.                   lprompt:string[40];
  181.                   lansi:boolean;
  182.                   init:string[40];
  183.                   wait:string[79];
  184.                   app:boolean;
  185.                   fone:boolean;
  186.                   sysopmacro:array[1..9] of string[72];
  187.                   forcevoting:boolean;
  188.                   multitask:boolean;
  189.                   gfilepath:string[79];
  190.                   pause:string[79];
  191.                   hangup:string[40];
  192.                   answer:string[40];
  193.                   result300:integer;
  194.                   result1200:integer;
  195.                   result2400:integer;
  196.                   nocarrier:integer;
  197.                   tries:byte;
  198.                   newsl:byte;
  199.                   newdsl:byte;
  200.                   newar:set of acrq;
  201.                   newac:set of restrictions;
  202.                   newfp:integer;
  203.                   newuk:integer;
  204.                   bwindow:boolean;
  205.                   bsdelay:byte;
  206.                   mcimsg:boolean;
  207.                   b300lowtime,b300hitime:integer;
  208.                   dllowtime,dlhitime:integer;
  209.                   b300dllowtime,b300dlhitime:integer;
  210.                   lock300:boolean;
  211.                   result4800:integer;
  212.                   result9600:integer;
  213.                   SysopFirst:String[12];
  214.                   SysopLast:String[16];
  215.                   BBSName:String[40];
  216.                   BBSPhone:String[12];
  217.                   ANSIq:String[40];
  218.                   WantQuote:Boolean;
  219.                   Menupath:string[79];
  220.                   autosl:byte;
  221.                   autodsl:byte;
  222.                   autoar:set of acrq;
  223.                   autoac:set of restrictions;
  224.                end;
  225.       blk=array[1..255] of byte;
  226.       mailrec=record
  227.                 title:string[30];
  228.                 from,destin:integer;
  229.                 msg:messages;
  230.                 date:integer;
  231.                 mage:byte;
  232.               end;
  233.       gft=record
  234.             num:integer;
  235.             title:string[40];
  236.             filen:string[12];
  237.           end;
  238.       smr=record
  239.             msg:astr;
  240.             destin:integer;
  241.           end;
  242.       vdatar=record
  243.                question:string[79];
  244.                numa:integer;
  245.                answ:array[0..9] of record
  246.                       ans:string[25];
  247.                       numres:integer;
  248.                     end;
  249.              end;
  250.       ulrec=record
  251.               name:string[25];
  252.               filename:string[12];
  253.               password:string[10];
  254.               dsl:byte;
  255.               maxfiles:integer;
  256.               key:char;
  257.               ulpath:string[39];
  258.               dlpath:string[40];
  259.               agereq:byte;
  260.               ar:acrq;
  261.             end;
  262.       ulfrec=record
  263.                filename:string[12];
  264.                description:string[60];
  265.                filepoints:integer;
  266.                res:array[1..15] of byte;
  267.                nacc:integer;
  268.                ft:byte;
  269.                blocks:integer;
  270.                owner:integer;
  271.                date:string[8];
  272.                daten:integer;
  273.              end;
  274.       strptr=^strrec;
  275.       strrec=record
  276.                i:astr;
  277.                next,last:strptr;
  278.              end;
  279.       zlogt=record
  280.               date:string[8];
  281.               active,calls,post,email,fback,up:integer;
  282.             end;
  283. {     eventrec=record
  284.                 descr:string[25];
  285.                 batch:string[12];
  286.                 time:integer;
  287.               end;}
  288. {    expro=record
  289.              descr:string[30];
  290.              rcmd:string[50];
  291.              scmd:string[50];
  292.              xferok:integer;
  293.            end;}
  294.  
  295. CONST dcols:clrs=((15,7,7,15,15,15,112,7,143,7),(15,3,1,11,9,14,31,4,140,10));
  296.  
  297. var sf:file of smalrec;
  298.     uf:file of userrec;
  299.     bf:file of boardrec;
  300. {   xp:file of expro;}
  301.     mailfile:file of mailrec;
  302.     ulf:file of ulrec;
  303. {    uevent:array [0..9] of eventrec;
  304.     eve:file of eventrec;
  305.     ev:eventrec;}
  306.     uboards:array[0..39] of ulrec;
  307. {   protocals:array [0..4] of expro;}
  308.     maxulb:integer;
  309.     sysopf:text{[1024]};
  310.     slf:file of slr;
  311.     seclev:array[0..255] of slr;
  312.     systatf:file of systatrec;
  313.     systat:systatrec;
  314.     sr:smalrec;
  315.     thisline,chatr,buf,spd,irt,lastname,ll,i:astr;
  316.     thisuser,user:userrec;
  317.     boards:array[1..39] of boardrec;
  318.     fw,extramsgs,mread,board,numboards,t,usernum,numprotocals:integer;
  319.     pap,lil,realsl,realdsl,ftoday,ptoday,etoday:integer;
  320.     c,ID:char;
  321.     rep,hungup,useron,next,chatcall,doneday,echo,hangup,incom,outcom:boolean;
  322.     extratime,chattime,timeon:real;
  323.     mailread,smread,macok,lan,enddayf,ch,quit,beepend:boolean;
  324.     smf:file of smr;
  325.     srl:array[0..maxusers] of smalrec;
  326.     vqu:array[1..20] of boolean;
  327.     ldate:integer;
  328.     cmd:char;
  329.     bread:byte;
  330.     bchanged:boolean;
  331.     mary:array[0..200] of messagerec;
  332.     cf:text; cfo,okt:boolean;
  333.     elevel:byte;
  334.     curco:byte;
  335.     sll:astr;
  336.     andwith:byte;
  337.     checkit:boolean;
  338.     geek:astr;
  339.     lmain:boolean;
  340.     lmsg:boolean;
  341.     windowon,entry,wantfilename,nofile,nofeed:boolean;
  342.     nopfile:boolean;
  343.     reading_a_msg,write_msg:boolean;
  344.     wantout:boolean;
  345.     wcolor:boolean;
  346.     Filv:Text;
  347.     N:Astr;
  348.     cmdl   : array [1..30] of string[14];
  349.     msl    : array [1..30] of byte;
  350.     cmdtype: array [1..30] of byte;
  351.     optdata: array [1..30] of integer;
  352.     optstr : array [1..30] of string[40];
  353.     noc    : integer;
  354.     found  : boolean;
  355.     directive,menuprompt:astr;
  356.     FILEBOARD:integer;
  357.     first_time:boolean;
  358.     ulff:file of ulfrec;
  359.     crc:integer;
  360.     doit:boolean;
  361.     sortbd,doneft:boolean;
  362.     ldat:astr;
  363.     ix:array[1..9] of string[79];
  364.     ymodem,ucrc,bnp:boolean;
  365.     c1,c2,c3:integer;
  366.     chksum:byte;
  367.     lrn:integer;
  368.     lfn:astr;
  369.     all,readingmail:boolean;
  370.     ft:byte;
  371.     ymbtt:real;
  372.     ymodemfiles:integer;
  373.     ymbindx:integer;
  374.     ymbary:array[1..20] of record
  375.       fn:string[80];
  376.       tt:real;
  377.     end;
  378.     dta:string[44];
  379.     filenamef,s1,s2,s3:astr;
  380.     donedos,dld,d1,d2,done,abort:boolean;
  381.     cd,cmdlist,start_dir,ver:astr;
  382.     returna,quitafterdone,nightly:boolean;
  383.     answerbaud:integer;
  384.     dumb,dumb2:char;
  385.     lastcaller:astr;
  386.     tim:real;
  387.  
  388. procedure sprompt(i:astr);
  389. procedure readin;
  390. procedure tc(n:integer);
  391. function cs:boolean;
  392. function so:boolean;
  393. function timer:real;
  394. function freek(d:integer):integer;    (* See disk space *)
  395. function lcs:boolean;
  396. function nma:integer;
  397. function okansi:boolean;
  398. function commpressed : boolean;
  399. procedure dump;
  400. procedure cline(dd:astr);                        (* input cmd line *)
  401. function nsl:real;
  402. procedure async_isr; INTERRUPT;
  403. function capsnam(xx:integer):astr;
  404. procedure remove_port;
  405. procedure term_ready(s:Boolean);
  406. procedure set_baud(r:integer);
  407. procedure fix_window;
  408. procedure iport;
  409. procedure commandline(dd:astr);                 (* cmd line *)
  410. function cinkey1:char;
  411. procedure gameport;
  412. function cinkey:char;
  413. procedure o1(c:char);
  414. procedure o(c:char);
  415. function sysop1:boolean;
  416. procedure cursoron;
  417. procedure cursoroff;
  418. function checkpw:boolean;
  419. function sysop:boolean;
  420. procedure sl1(i:astr);
  421. procedure sysoplog(i:astr);
  422. function tch(i:astr):astr;
  423. function time:astr;
  424. function date:astr;
  425. function value(I:astr):integer;
  426. function cstr(i:integer):astr;
  427. function nam:astr;
  428. procedure sysopshell;
  429. function leapyear(yr:integer):boolean;
  430. function days(mo,yr:integer):integer;
  431. function daycount(mo,yr:integer):integer;
  432. function daynum(dt:astr):integer;
  433. function dat:astr;
  434. function cdet:boolean;
  435. procedure checkhangup;
  436. procedure getkey(var c:char);
  437. procedure pr1(i:astr);
  438. procedure pr(i:astr);
  439. procedure sdc;
  440. procedure stsc;
  441. function xclr(c:integer):astr;
  442. procedure setc(cl:byte);
  443. procedure cl(c:integer);
  444. procedure prompt(i:astr);
  445. procedure pausescr;
  446. procedure print(i:astr);
  447. procedure nl;
  448. procedure prt(i:astr);
  449. procedure ynq(i:astr);
  450. procedure mpl(c:integer);
  451. procedure tleft;
  452. procedure prestrict(u:userrec);
  453. procedure topscr;
  454. procedure bigwindow;
  455. procedure smallwindow;
  456. function empty:boolean;
  457. {procedure skey1(var c:char);}
  458. function inkey:char;
  459. procedure oc(c:char);
  460. procedure outkey(c:char);
  461. procedure outansi(i:char);
  462. {procedure skey(var c:char);}
  463. procedure dm(i:astr; var c:char);   (* Throw macro to the input routine *)
  464. {procedure getkey;   } (* forward function to get a single key *)
  465. procedure cls;   (*guess*)
  466. procedure wait(b:boolean);         (* Displayed when sysop is working *)
  467. procedure chsl;     (* Change Security Level *)
  468. procedure swac(var u:userrec;r:restrictions);
  469. procedure acch(c:char; var u:userrec);
  470. procedure sprint(i:astr);
  471. procedure chac(var thisuser:userrec);
  472. procedure chbac;
  473. procedure chdsl;
  474. procedure tfile;                             (* Open/Close chat.msg *)
  475. procedure inli1(var i:astr);             (* Input routine for chat *)
  476. function yn:boolean;                       (* The "YES" or "NO" routine *)
  477. procedure input1(var i:astr; ml:integer; tf:boolean);
  478. procedure input(var i:astr; ml:integer);  (* Input uppercase only *)
  479. procedure inputl(var i:astr; ml:integer);   (* Input lower & upper case *)
  480. procedure onek(var c:char; ch:astr);    (* 1 Key example: onkey(c,'1234'); *)
  481. procedure centre(var i:astr);   (* Center I String *)
  482. procedure wkey(var abort,next:boolean);  (* See if user aborts, pauses, etc*)
  483. function ctim(rl:real):astr;
  484. function tlef:astr;
  485. Procedure Print_File (fn:astr);     (* print ansi file *)
  486. procedure printa1(i:astr; var abort,next:boolean);  (* Print line of text *)
  487. procedure printa(i:astr; var abort,next:boolean);
  488. procedure printacr(i:astr; var abort,next:boolean);
  489. function cstrr(rl:real; base:integer):astr;
  490. procedure savesystat;  (* save systat *)
  491. procedure pfl(fn:astr; var abort:boolean; cr:boolean);
  492. procedure printfile(fn:astr);         (* Print normal text file *)
  493. procedure printf(fn:astr);      (* See if an *.ans file is available *)
  494. procedure chat;  (*Break into chat *)
  495. procedure skey(c:char);   (* Global user keys *)
  496. procedure skey1(c:char);     (* Global sysop keys *)
  497. procedure Async_Init;
  498. procedure Async_Close;
  499. Procedure Async_Open(ComPort       : Integer;
  500.                     BaudRate      : Integer;
  501.                     Parity        : Char;
  502.                     WordSize      : Integer;
  503.                     StopBits      : Integer);
  504.  
  505. Implementation
  506.  
  507. const
  508.   UART_THR = $00;
  509.   UART_RBR = $00;
  510.   UART_IER = $01;
  511.   UART_IIR = $02;
  512.   UART_LCR = $03;
  513.   UART_MCR = $04;
  514.   UART_LSR = $05;
  515.   UART_MSR = $06;
  516.  
  517.   I8088_IMR = $21;   { port address of the Interrupt Mask Register }
  518.  
  519.  
  520. var
  521.  
  522.   Async_BIOS_Port_Table : Array[1..2] of Integer absolute $40:0;
  523.  
  524. const
  525.   Async_Num_Bauds = 8;
  526.   Async_Baud_Table : array [1..Async_Num_Bauds] of record
  527.                                                      Baud, Bits : integer
  528.                                                    end
  529.                    = ((Baud:110;  Bits:$00),
  530.                       (Baud:150;  Bits:$20),
  531.                       (Baud:300;  Bits:$40),
  532.                       (Baud:600;  Bits:$60),
  533.                       (Baud:1200; Bits:$80),
  534.                       (Baud:2400; Bits:$A0),
  535.                       (Baud:4800; Bits:$C0),
  536.                       (Baud:9600; Bits:$E0));
  537.  
  538.  
  539. PROCEDURE DisableInterrupts; inline($FA {cli} );     {MACROS}
  540. PROCEDURE EnableInterrupts;  inline($FB {sti} );
  541.  
  542. procedure BIOS_RS232_Init(ComPort, ComParm : Integer);
  543. var
  544.   Regs : registers;
  545. begin
  546.   with Regs do
  547.     begin
  548.       ax := ComParm and $00FF;  { AH=0; AL=ComParm }
  549.       dx := ComPort;
  550.       Intr($14, Regs)
  551.     end
  552. end;
  553.  
  554. function lenn(i:astr):integer;
  555. var x:integer; z:integer;
  556. begin
  557.   z:=0;
  558.   for x:=1 to length(i) do begin
  559.     if i[x]='^' then x:=x+2;
  560.     z:=z+1;
  561.   end;
  562.   lenn:=z;
  563. end;
  564.  
  565. function checkpw:boolean;
  566. var i:astr;
  567. begin
  568.   prompt('Sysop PW? ');
  569.   echo:=false;
  570.   input(i,20);
  571.   echo:=true;
  572.   checkpw:=(i=systat.sysoppw);
  573. end;
  574.  
  575. Procedure CursorOn;
  576. Var
  577.   Reg:Registers;
  578. Begin
  579.   with reg do
  580.   begin
  581.     ch:=07; cl:=08; ah:=1;
  582.     intr($10,reg);
  583.   end;
  584. end;
  585.  
  586. Procedure CursorOff;
  587. Var
  588.   Reg:Registers;
  589. Begin
  590.   with reg do
  591.   begin
  592.     ch:=09; cl:=00; ah:=1;
  593.     intr($10,reg);
  594.   end;
  595. end;
  596.  
  597. procedure sprompt(i:astr);
  598. var x,z:Integer; y:astr; fr:astr; xx:boolean; dum:astr; zz:astr;
  599. begin
  600.   dum:=nam;
  601.   for x:=1 to length(i) do begin
  602.     xx:=false;
  603.     if i[x]='^' then begin
  604.         z:=value(i[x+1]);
  605.         if z in [0..9] then cl(z);
  606.         x:=x+1; xx:=true;
  607.       end;
  608.    if i[x]='@' then begin
  609.         y:=upcase(i[x+1]);
  610.         if y='A' then prompt(cstr(board));
  611.         if y='B' then prompt(boards[board].name);
  612.         if y='C' then prompt(cstr(FILEBOARD));
  613.         if y='D' then prompt(uboards[FILEBOARD].name);
  614.         if y='E' then cls;
  615.         if y='P' then prompt(cstr(thisuser.filepoints));
  616.         if y='M' then nl;
  617.         if y='N' then prompt(dum);
  618.         if y='H' then prompt(copy(dum,1,(pos('#',dum)-1)));
  619.         if y='R' then prompt(thisuser.realname);
  620.         if y='Z' then prompt(chatr);
  621.         if y='F' then begin
  622.           zz:=(copy(dum,1,(pos(' ',dum)-1)));
  623.           if zz='The' then zz:=dum;
  624.           prompt(zz);
  625.         end;
  626.         if y='V' then prompt(cmdlist);
  627.         x:=x+1; xx:=true;
  628.     end;
  629.     if not xx then prompt(i[x]);
  630.   end;
  631. end;
  632.  
  633. procedure sprint(i:astr);
  634. begin
  635.   sprompt(i); nl;
  636. end;
  637.  
  638. procedure readin;
  639. var i:integer;
  640. begin
  641.   cmdlist:='';
  642.   noc:=0;
  643.   if first_time=false then close(filv);
  644.   if first_time=true then first_time:=false;
  645.   assign(filv,n);
  646.   {$I-} reset(filv); {$I+}
  647.   if ioresult<>0 then begin sysoplog(n+' is MISSING.'); print(n+' is MISSING.  Please inform SysOp.'); hangup:=true;
  648.     end else
  649.   BEGIN
  650.   readln(filv,directive);
  651.   readln(filv,menuprompt);
  652.   repeat
  653.     noc:=noc+1;
  654.     readln(filv,cmdl[noc]);
  655.     readln(filv,msl[noc]);
  656.     readln(filv,cmdtype[noc]);
  657.     readln(filv,optdata[noc]);
  658.     readln(filv,optstr[noc]);
  659.   until (eof(filv));
  660.   FILEBOARD:=thisuser.res[2];
  661.   for i:=1 to noc do begin
  662.     if (thisuser.sl>=msl[i]) and (i<>1) then cmdlist:=cmdlist+',';
  663.     if thisuser.sl>=msl[i] then cmdlist:=cmdlist+cmdl[i];
  664.   end;
  665.   END;
  666. end;
  667.  
  668. procedure Async_Isr;  {INTERRUPT;}
  669. begin
  670.   Inline(
  671.     $FB/                           { STI }
  672.       { get the incomming character }
  673.       { buffer[Buffer_head] := Chr(Port[UART_RBR + base]); }
  674.     $8B/$16/base/                  { MOV DX,base }
  675.     $EC/                           { IN AL,DX }
  676.     $8B/$1E/Buffer_head/           { MOV BX,Buffer_head }
  677.     $88/$87/buffer/                { MOV buffer[BX],AL }
  678.       { Async_Buffer_NewHead := Buffer_head + 1; }
  679.     $43/                           { INC BX }
  680.       { if Async_Buffer_NewHead > buffer_max then
  681.           Async_Buffer_NewHead := 0; }
  682.     $81/$FB/buffer_max/            { CMP BX,buffer_max }
  683.     $7E/$02/                       { JLE L001 }
  684.     $33/$DB/                       { XOR BX,BX }
  685.       { if Async_Buffer_NewHead = Buffer_tail then
  686.           Async_Buffer_Overflow := TRUE
  687.         else }
  688. {L001:}
  689.     $3B/$1E/Buffer_tail/     { CMP BX,Buffer_tail }
  690.     $75/$08/                       { JNE L002 }
  691.     $C6/$06/Async_Buffer_Overflow/$01/ { MOV Async_Buffer_Overflow,1 }
  692.     $90/                           { NOP generated by assembler for some reason }
  693.     $EB/$16/                       { JMP SHORT L003 }
  694.       { begin
  695.           Buffer_head := Async_Buffer_NewHead;
  696.           Async_Buffer_Used := Async_Buffer_Used + 1;
  697.           if Async_Buffer_Used > Async_MaxBufferUsed then
  698.             Async_MaxBufferUsed := Async_Buffer_Used
  699.         end; }
  700. {L002:}
  701.     $89/$1E/Buffer_head/           { MOV Buffer_head,BX }
  702.     $FF/$06/Async_Buffer_Used/     { INC Async_Buffer_Used }
  703.     $8B/$1E/Async_Buffer_Used/     { MOV BX,Async_Buffer_Used }
  704.     $3B/$1E/Async_MaxBufferUsed/   { CMP BX,Async_MaxBufferUsed }
  705.     $7E/$04/                       { JLE L003 }
  706.     $89/$1E/Async_MaxBufferUsed/   { MOV Async_MaxBufferUsed,BX }
  707. {L003:}
  708.       { disable interrupts }
  709.     $FA/                           { CLI }
  710.       { Port[$20] := $20; }        { use non-specific EOI }
  711.     $B0/$20/                       { MOV AL,20h }
  712.     $E6/$20                        { OUT 20h,AL }
  713.        )
  714. end; { Async_Isr }
  715.  
  716. procedure Async_Init;
  717. begin
  718.   Async_Open_Flag := FALSE;
  719.   Async_Buffer_Overflow := FALSE;
  720.   Async_Buffer_Used := 0;
  721.   Async_MaxBufferUsed := 0;
  722. end; { Async_Init }
  723.  
  724. procedure Async_Close;
  725. var
  726.   i, m : Integer;
  727. begin
  728.   if Async_Open_Flag then
  729.     begin
  730.  
  731.       { disable the IRQ on the 8259 }
  732.       DisableInterrupts;
  733.       i := Port[I8088_IMR];        { get the interrupt mask register }
  734.       m := 1 shl Async_Irq;        { set mask to turn off interrupt }
  735.       Port[I8088_IMR] := i or m;
  736.  
  737.       { disable the 8250 data ready interrupt }
  738.       Port[UART_IER + base] := 0;
  739.  
  740.       { disable OUT2 on the 8250 }
  741.       Port[UART_MCR + base] := 0;
  742.       EnableInterrupts;
  743.  
  744.       SetIntVec(Async_Irq + 8,Async_OriginalVector);
  745.  
  746.       { re-initialize our data areas so we know the port is closed }
  747.       Async_Open_Flag := FALSE
  748.  
  749.     end
  750. end; { Async_Close }
  751.  
  752. Procedure Async_Open(ComPort       : Integer;
  753.                     BaudRate      : Integer;
  754.                     Parity        : Char;
  755.                     WordSize      : Integer;
  756.                     StopBits      : Integer);
  757. { open a communications port }
  758. var
  759.   ComParm : Integer;
  760.   i, m : Integer;
  761. begin
  762.   if Async_Open_Flag then Async_Close;
  763.  
  764.   if (ComPort = 2) and (Async_BIOS_Port_Table[2] <> 0) then
  765.     Async_Port := 2
  766.   else
  767.     Async_Port := 1;  { default to COM1 }
  768.   base := Async_BIOS_Port_Table[Async_Port];
  769.   Async_Irq := Hi(base) + 1;
  770.  
  771.   if (Port[UART_IIR + base] and $00F8)=0
  772.   then
  773.     begin
  774.       Buffer_head := 0;
  775.       Buffer_tail := 0;
  776.       Async_Buffer_Overflow := FALSE;
  777.  
  778.   { Build the ComParm for RS232_Init }
  779.   { See Technical Reference Manual for description }
  780.  
  781.       ComParm := $0000;
  782.  
  783.   { Set up the bits for the baud rate }
  784.       i := 0;
  785.       repeat
  786.         i := i + 1
  787.       until (Async_Baud_Table[i].Baud = BaudRate) or (i = Async_Num_Bauds);
  788.       ComParm := ComParm or Async_Baud_Table[i].Bits;
  789.  
  790.       if Parity in ['E', 'e'] then ComParm := ComParm or $0018
  791.       else if Parity in ['O', 'o'] then ComParm := ComParm or $0008
  792.       else ComParm := ComParm or $0000;  { default to No parity }
  793.  
  794.       if WordSize = 7 then ComParm := ComParm or $0002
  795.       else ComParm := ComParm or $0003;  { default to 8 data bits }
  796.  
  797.       if StopBits = 2 then ComParm := ComParm or $0004
  798.       else ComParm := ComParm or $0000;  { default to 1 stop bit }
  799.  
  800.   { use the BIOS COM port initialization routine to save typing the code }
  801.       BIOS_RS232_Init(Async_Port - 1, ComParm);
  802.  
  803.       GetIntVec(Async_Irq + 8, Async_OriginalVector);
  804.       SetIntVec(Async_Irq + 8, @Async_Isr);
  805.  
  806.   { read the RBR and reset any possible pending error conditions }
  807.   { first turn off the Divisor Access Latch Bit to allow access to RBR, etc. }
  808.  
  809.       DisableInterrupts;
  810.  
  811.       Port[UART_LCR + base] := Port[UART_LCR + base] and $7F;
  812.   { read the Line Status Register to reset any errors it indicates }
  813.       i := Port[UART_LSR + base];
  814.   { read the Receiver Buffer Register in case it contains a character }
  815.       i := Port[UART_RBR + base];
  816.  
  817.   { enable the irq on the 8259 controller }
  818.       i := Port[I8088_IMR];  { get the interrupt mask register }
  819.       m := (1 shl Async_Irq) xor $00FF;
  820.       Port[I8088_IMR] := i and m;
  821.  
  822.   { enable the data ready interrupt on the 8250 }
  823.       Port[UART_IER + base] := $01; { enable data ready interrupt }
  824.  
  825.   { enable OUT2 on 8250 }
  826.       i := Port[UART_MCR + base];
  827.       Port[UART_MCR + base] := i or $08;
  828.  
  829.       EnableInterrupts;
  830.       Async_Open_Flag := TRUE;
  831.       {Async_Open := TRUE}
  832.     end
  833. end; { Async_Open }
  834.  
  835. procedure tc(n:integer);
  836. begin
  837.   textcolor(n);
  838. end;
  839.  
  840. function cs:boolean;
  841. begin
  842.   cs:=cosysop in seclev[thisuser.sl].anst;
  843. end;
  844.  
  845. function so:boolean;
  846. begin
  847.   so:=thisuser.sl=255;
  848. end;
  849.  
  850. function timer:real;
  851. var reg:registers;
  852.     h,m,s,t:real;
  853. begin
  854.   reg.ax:=44*256;
  855.   msdos(Dos.Registers(reg));
  856.   h:=(reg.cx div 256);
  857.   m:=(reg.cx mod 256);
  858.   s:=(reg.dx div 256);
  859.   t:=(reg.dx mod 256);
  860.   timer:=h*3600+m*60+s+t/100;
  861. end;
  862.  
  863. function freek(d:integer):integer;    (* See disk space *)
  864. var r:registers;
  865. begin
  866.   r.ax:=$3600;
  867.   r.dx:=d;
  868.   msdos(Dos.Registers(r));
  869.   freek:=trunc(1.0*r.bx*r.ax*r.cx/1024.0);
  870. end;
  871.  
  872. function lcs:boolean;
  873. begin
  874.   lcs:=cs or ((lcosysop in seclev[thisuser.sl].anst) and ((board=thisuser.sbn) or (thisuser.sbn=0)));
  875. end;
  876.  
  877. function nma:integer;
  878. begin
  879.   nma:=seclev[thisuser.sl].ttime;
  880. end;
  881.  
  882. function okansi:boolean;
  883. begin
  884.   okansi:=ansi in thisuser.defaults;
  885. end;
  886.  
  887. function commpressed : boolean;
  888. begin
  889.  commpressed := (buffer_tail<>buffer_head);
  890. end;
  891.  
  892. procedure dump;
  893.  
  894. Begin
  895.   disableinterrupts;  {Replaces the old inline $FA}
  896.   buffer_head:=0;
  897.   buffer_tail:=buffer_head;
  898.   enableinterrupts;   {Replaces the old inline $FB}
  899. end;
  900.  
  901. procedure cline(dd:astr);                        (* input cmd line *)
  902. var x,y,i,u:integer;
  903. begin
  904.     if windowon then
  905.     u:=36-(length(dd) div 2) else u:=39-(length(dd) div 2);
  906.   if dd=':' then u:=4;
  907.   x:=wherex; y:=wherey; if windowon then WINDOW(1,22,80,25) else WINDOW(1,25,80,25);
  908.   if windowon then gotoxy(4,1) else gotoxy(1,1); tc(15); textbackground(5);
  909.   if windowon then
  910.   write('                                                                          ') else clreol;
  911.   gotoxy(u,1);
  912.    write(dd+' '); readln(geek); tc(3); textbackground(0);
  913.   if windowon then WINDOW(1,1,80,21) else WINDOW(1,1,80,24); gotoxy(x,y);
  914. end;
  915.  
  916. function nsl:real;
  917. begin
  918.   nsl:=(nma*60.0+extratime+chattime+timeon-timer);
  919. end;
  920.  
  921. {procedure async_isr;
  922. begin
  923.   inline($50/$53/$52/$1E/$FB/$2E/$FF/$36/dsaves/$1F/$8B/$16/base/
  924.          $EC/$8B/$1E/buffer_Head/$88/$87/buffer/$43/$81/$FB/buffer_Max/$7E/
  925.          $02/$33/$DB/$3B/$1E/buffer_Tail/$74/$04/$89/$1E/buffer_Head/$FA/
  926.          $B0/$20/$E6/$20/$1F/$5A/$5B/$58/$5C/$5D/$CF);
  927. end;}
  928.  
  929. procedure remove_port;
  930. begin
  931.   async_close;
  932. end;
  933.  
  934. procedure term_ready(s:Boolean);
  935. var x:byte;
  936. begin
  937.   x := port[4+base] and $FE;
  938.   if s then x:=x+1;
  939.   port[4+base] := x;
  940. end;
  941.  
  942. procedure set_baud(r:integer);
  943. var rl:real; a:byte;
  944. begin
  945.   if (r>=300) and (r<=9600) then begin
  946.     rl:=115200.0/r;
  947.     r:=trunc(rl);
  948.     a:=port[3+base] or 128;
  949.     port[base+3]:=a;
  950.     port[base]:=lo(r);
  951.     port[1+base]:=hi(r);
  952.     port[3+base]:=a and 127;
  953.   end;
  954. end;
  955.  
  956. Procedure Iport;
  957. Begin
  958.   Async_init;
  959.   Async_open(Systat.comport,Systat.MaxBaud,'N',8,1);
  960. End;
  961.  
  962. Procedure Gameport;
  963. Var Speed:Integer;
  964. Begin
  965.  If Spd='KB' then Speed:=Systat.Maxbaud else Speed:=Value(Spd);
  966.  Async_init;
  967.  Async_Open(Systat.Comport,Speed,'N',8,1);
  968. End;
  969.  
  970. procedure commandline(dd:astr);                 (* cmd line *)
  971. var x,y,u:integer;
  972. begin
  973.   if windowon then
  974.     u:=37-(length(dd) div 2) else u:=40-(length(dd) div 2);
  975.   x:=wherex; y:=wherey;
  976.   if windowon then window(1,22,80,25) else window(1,25,80,25);
  977.   if windowon then gotoxy(4,1) else gotoxy(1,1); tc(15); textbackground(5);
  978.   if windowon then
  979.   write('                                                                          ') else clreol;
  980.   gotoxy(u,1);
  981.   write(dd); tc(3); textbackground(0);
  982.   if windowon then window(1,1,80,21) else window(1,1,80,24); gotoxy(x,y);
  983. end;
  984.  
  985. function cinkey1:char;
  986. var t:char;
  987. begin
  988.   if buffer_Head = buffer_Tail Then
  989.     t:=#0
  990.   else begin
  991.     disableinterrupts;
  992.     t:=buffer[buffer_Tail];
  993.     buffer_Tail:=(buffer_Tail+1) mod (buffer_max+1);
  994.     enableinterrupts;
  995.   end;
  996.   cinkey1:=t;
  997. end;
  998.  
  999. function cinkey:char;
  1000. var t:char;
  1001. begin
  1002.   t:=cinkey1;
  1003.   cinkey:=chr(ord(t) and andwith);
  1004. end;
  1005.  
  1006. procedure o1(c:char);
  1007. begin
  1008.   while (port[base+5] and 32)=0 do;
  1009.   port[base]:=ord(c);
  1010. end;
  1011.  
  1012. procedure o(c:char);
  1013. begin
  1014.   if outcom and (c<>#1) then o1(c);
  1015. end;
  1016.  
  1017. function sysop1:boolean;
  1018. begin
  1019.   if (mem[0:1047] and 16)=0 then sysop1:=false else sysop1:=true;
  1020. end;
  1021.  
  1022. function sysop:boolean;
  1023. begin
  1024.   sysop:=sysop1;
  1025.   if rchat in thisuser.ac then sysop:=false;
  1026.   if systat.lowtime<>systat.hitime then begin
  1027.     if systat.hitime>systat.lowtime then begin
  1028.       if (timer<=(systat.lowtime*60.0)) or (timer>=(systat.hitime*60.0))
  1029.         then sysop:=false;
  1030.     end else begin
  1031.       if (timer<=(systat.lowtime*60.0)) and (timer>=(systat.hitime*60.0))
  1032.         then sysop:=false;
  1033.     end;
  1034.   end;
  1035. end;
  1036.  
  1037. procedure sl1(i:astr);
  1038. begin
  1039.   writeln(sysopf,i);
  1040. end;
  1041.  
  1042. procedure sysoplog(i:astr);
  1043. begin
  1044.     sl1('   '+i);
  1045. end;
  1046.  
  1047. function tch(i:astr):astr;
  1048. begin
  1049.   if length(i)>2 then i:=copy(i,length(i)-1,2) else
  1050.     if length(i)=1 then i:='0'+i;
  1051.   tch:=i;
  1052. end;
  1053.  
  1054. function time:astr;
  1055. var reg:registers;
  1056.     h,m,s:string[4];
  1057. begin
  1058.   reg.ax:=$2c00; intr($21,Dos.Registers(reg));
  1059.   str(reg.cx shr 8,h); str(reg.cx mod 256,m); str(reg.dx shr 8,s);
  1060.   time:=tch(h)+':'+tch(m)+':'+tch(s);
  1061. end;
  1062.  
  1063. function date:astr;
  1064. var reg:registers;
  1065.     m,d,y:string[4];
  1066. begin
  1067.   reg.ax:=$2a00; msdos(Dos.Registers(reg)); str(reg.cx,y); str(reg.dx mod 256,d);
  1068.   str(reg.dx shr 8,m);
  1069.   date:=tch(m)+'/'+tch(d)+'/'+tch(y);
  1070. end;
  1071.  
  1072. {local}
  1073.  
  1074. function value(I:astr):integer;
  1075. var n,n1:integer;
  1076. begin
  1077.   val(i,n,n1);
  1078.   if n1<>0 then begin
  1079.     i:=copy(i,1,n1-1);
  1080.     val(i,n,n1)
  1081.   end;
  1082.   value:=n;
  1083.   if i='' then value:=0;
  1084. end;
  1085.  
  1086. function cstr(i:integer):astr;
  1087. var c:astr;
  1088. begin
  1089.   str(i,c); cstr:=c;
  1090. end;
  1091.  
  1092. function nam:astr;
  1093. var s:astr; i:integer; tf:boolean;
  1094. begin
  1095.   s:=thisuser.name;
  1096.   tf:=true;
  1097.   for i:=1 to length(s) do
  1098.     if s[i]<'A' then
  1099.       tf:=true
  1100.     else begin
  1101.       if (s[i]<='Z') and not tf then
  1102.         s[i]:=chr(ord(s[i])+32);
  1103.       tf:=false;
  1104.     end;
  1105.   nam:=s+' #'+cstr(usernum);
  1106. end;
  1107.  
  1108. function capsnam(xx:integer):astr;
  1109. var s:astr; i:integer; tf:boolean;
  1110. begin
  1111.   s:=srl[xx].name;
  1112.   tf:=true;
  1113.   for i:=1 to length(s) do
  1114.     if s[i]<'A' then
  1115.       tf:=true
  1116.     else begin
  1117.       if (s[i]<='Z') and not tf then
  1118.         s[i]:=chr(ord(s[i])+32);
  1119.       tf:=false;
  1120.     end;
  1121.   capsnam:=s;
  1122. end;
  1123.  
  1124. function leapyear(yr:integer):boolean;
  1125. begin
  1126.   leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
  1127. end;
  1128.  
  1129. function days(mo,yr:integer):integer;
  1130. var d:integer;
  1131. begin
  1132.   d:=value(copy('312831303130313130313031',1+(mo-1)*2,2));
  1133.   if (mo=2) and leapyear(yr) then d:=d+1;
  1134.   days:=d;
  1135. end;
  1136.  
  1137. function daycount(mo,yr:integer):integer;
  1138. var m,t:integer;
  1139. begin
  1140.   t:=0;
  1141.   for m:=1 to (mo-1) do t:=t+days(m,yr);
  1142.   daycount:=t;
  1143. end;
  1144.  
  1145. function daynum(dt:astr):integer;
  1146. var d,m,y,t,c:integer;
  1147. begin
  1148.   t:=0;
  1149.   m:=value(copy(dt,1,2));
  1150.   d:=value(copy(dt,4,2));
  1151.   y:=value(copy(dt,7,2))+1900;
  1152.   for c:=1985 to y-1 do
  1153.     if leapyear(c) then t:=t+366 else t:=t+365;
  1154.   t:=t+daycount(m,y)+(d-1);
  1155.   daynum:=t;
  1156.   if y<1985 then daynum:=0;
  1157. end;
  1158.  
  1159. function dat:astr;
  1160. var ap,x,y:astr; i:integer;
  1161. begin
  1162.   case daynum(date) mod 7 of
  1163.     0:x:='Tue';
  1164.     1:x:='Wed';
  1165.     2:x:='Thu';
  1166.     3:x:='Fri';
  1167.     4:x:='Sat';
  1168.     5:x:='Sun';
  1169.     6:x:='Mon';
  1170.   end;
  1171.   case value(copy(date,1,2)) of
  1172.     1:y:='Jan';
  1173.     2:y:='Feb';
  1174.     3:y:='Mar';
  1175.     4:y:='Apr';
  1176.     5:y:='May';
  1177.     6:y:='Jun';
  1178.     7:y:='Jul';
  1179.     8:y:='Aug';
  1180.     9:y:='Sep';
  1181.     10:y:='Oct';
  1182.     11:y:='Nov';
  1183.     12:y:='Dec';
  1184.   end;
  1185.   x:=x+' '+y+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
  1186.   y:=time; i:=value(copy(y,1,2));
  1187.   if i>11 then ap:='pm' else ap:='am';
  1188.   if i>12 then i:=i-12;
  1189.   if i=0 then i:=12;
  1190.   dat:=cstr(i)+copy(y,3,3)+' '+ap+'  '+x;
  1191. end;
  1192.  
  1193. function cdet:boolean;
  1194. begin
  1195.   cdet:=(port[base+6] and 128)<>0;
  1196. end;
  1197.  
  1198. procedure checkhangup;
  1199. begin
  1200.   if outcom and not cdet and (not hangup) then begin
  1201.     hangup:=true; hungup:=true;
  1202.   end;
  1203. end;
  1204.  
  1205. procedure pr1(i:astr);
  1206. var c:integer;
  1207. begin
  1208.   for c:=1 to length(i) do o1(i[c]);
  1209. end;
  1210.  
  1211. procedure pr(i:astr);
  1212. begin
  1213.   pr1(i+#13);
  1214. end;
  1215.  
  1216. procedure sdc;
  1217. var f:integer;
  1218. begin
  1219.   f:=curco and 7;
  1220.   if (curco and 8)<>0 then f:=f+8;
  1221.   if (curco and 128)<>0 then f:=f+16;
  1222.   tc(f);
  1223.   textbackground((curco shr 4) and 7);
  1224. end;
  1225.  
  1226. procedure stsc;
  1227. begin
  1228.   tc(11); textbackground(0);
  1229. end;
  1230.  
  1231. function xclr(c:integer):astr;
  1232. begin
  1233.   case c of
  1234.     0:xclr:='0';
  1235.     1:xclr:='4';
  1236.     2:xclr:='2';
  1237.     3:xclr:='6';
  1238.     4:xclr:='1';
  1239.     5:xclr:='5';
  1240.     6:xclr:='3';
  1241.     7:xclr:='7';
  1242.   end;
  1243. end;
  1244.  
  1245. procedure setc(cl:byte);
  1246. var i:astr; r:registers; zz:integer;
  1247.   procedure adto(ii:astr);
  1248.   begin
  1249.     if (i[length(i)]<>';') and (i[length(i)]<>'[') then i:=i+';';
  1250.     i:=i+ii;
  1251.   end;
  1252. begin
  1253.   if cl<>curco then begin
  1254.     if ((curco and (not cl)) and $88)<>0 then begin
  1255.       i:=#27+'[0';
  1256.       curco:=$07;
  1257.     end else i:=#27+'[';
  1258.     if (cl and 7)<>(curco and 7) then adto('3'+xclr(cl and 7));
  1259.     if (cl and $70)<>(curco and $70) then adto('4'+xclr((cl shr 4) and 7));
  1260.     if (cl and 128)<>0 then adto('5');
  1261.     if (cl and 8)<>0 then adto('1');
  1262.     i:=i+'m';
  1263.     curco:=cl;
  1264.     if (okansi) and (outcom) then pr1(i);
  1265.     if (okansi) then for zz:=1 to length(i) do begin
  1266.       with r do begin
  1267.         dx:=ord(i[zz]);
  1268.         ax:=$0200;
  1269.         if i[zz]<>#16 then msdos(Dos.Registers(r));
  1270.       end;
  1271.     end;
  1272.     sdc;
  1273.   end;
  1274. end;
  1275.  
  1276. procedure cl(c:integer);
  1277. begin
  1278.   if c in [0..9] then begin
  1279.     if okansi then
  1280.       if color in thisuser.defaults then
  1281.         setc(thisuser.cols[true,c])
  1282.       else
  1283.         setc(thisuser.cols[false,c]);
  1284.   end;
  1285. end;
  1286.  
  1287. procedure pausescr;
  1288. var i:byte; cc:char; x:integer;
  1289. begin
  1290.   cl(8); sprompt(systat.pause); cl(1);
  1291.   getkey(cc);
  1292.   x:=lenn(systat.pause);
  1293.   for i:=1 to x do prompt(#8);
  1294.   for i:=1 to x do prompt(' ');
  1295.   for i:=1 to x do prompt(#8);
  1296. end;
  1297.  
  1298. procedure prompt (i:astr);
  1299. var c:integer; cc:char;
  1300. begin
  1301.  checkhangup;
  1302.  if not hangup then begin
  1303.   for c:=1 to length(i) do begin
  1304.     if i[c]=#10 then
  1305.       if okansi then
  1306.         if (curco<>thisuser.cols[color in thisuser.defaults,1]) and (ch=false)
  1307.         and (write_msg=false) and not (reading_a_msg) then CL(1);
  1308.     if (not ((i[c]=chr(7)) and (incom))) and (i[c]<>chr(12)) and (i<>#1) and (wantout) then write(i[c]);
  1309.     if chatcall then sound(2000);
  1310.     o(i[c]);
  1311.     if i[c]>#31 then thisline:=thisline+i[c];
  1312.     if i[c]=#8 then if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
  1313.     if i[c]=chr(12) then begin lil:=0; clrscr; end;
  1314.     if i[c]=chr(13) then begin pap:=0; thisline:=''; end;
  1315.     nosound;
  1316.     if i[c]=chr(10) then begin
  1317.       lil:=lil+1;
  1318.       if (lil>=thisuser.pagelen-1) then begin
  1319.         lil:=0;
  1320.         if pause in thisuser.defaults then pausescr;
  1321.       end;
  1322.     end;
  1323.   end;
  1324.  end;
  1325. end;
  1326.  
  1327. procedure print(i:astr);
  1328. begin
  1329.   prompt(i+chr(13)+chr(10))
  1330. end;
  1331.  
  1332. procedure nl;
  1333. begin
  1334.   prompt(chr(13)+chr(10))
  1335. end;
  1336.  
  1337. procedure prt(i:astr);
  1338. begin
  1339.   cl(4); prompt(i); CL(1);
  1340. end;
  1341.  
  1342. procedure ynq(i:astr);
  1343. begin
  1344.   cl(9); prompt(i);
  1345. end;
  1346.  
  1347. procedure mpl(c:integer);
  1348. var n:integer; i:astr;
  1349. begin
  1350.  if okansi then begin
  1351.   cl(6);
  1352.   i:='';
  1353.   for n:=1 to c do i:=i+' ';
  1354.   n:=wherex;
  1355.   prompt(i);
  1356.   gotoxy(n,wherey);
  1357.   if outcom then
  1358.     pr1(#27+'['+cstr(c)+'D');
  1359.  end;
  1360.  thisline:=copy(thisline,1,length(thisline)-c);
  1361. end;
  1362.  
  1363. procedure tleft;
  1364. var x,y:integer;
  1365. begin
  1366.  if okt and (windowon=true) then begin
  1367.   stsc;
  1368.   x:=wherex; y:=wherey; WINDOW(1,22,80,25);
  1369.   gotoxy(18,4);if chatr<>'' then begin
  1370.     tc(28);write('<<CHAT>> ');tc(3);
  1371.     if alert in thisuser.option then begin
  1372.       gotoxy(18,4);
  1373.       tc(32);write('<<ALERT>>');tc(3);
  1374.     end;
  1375.   end else write('        ');
  1376.     gotoxy(68,3); if sysop1 then write('Page is ON ') else
  1377.       write('Page is OFF');
  1378.   {if useron then begin } gotoxy(68,4); write('TL:',(nsl/60):7:2); {end;}
  1379.   if hangup then begin
  1380.     gotoxy(56,4);TC(20);
  1381.     write('DROP');TC(7);
  1382.   end;
  1383.   gotoxy(75,2);
  1384.   if beepend then write('(>*<)') else write('     ');
  1385.   WINDOW(1,1,80,21);gotoxy(x,y);
  1386.   if timer<timeon then timeon:=timeon-24.0*60*60;
  1387.   if not ch and (nsl<0) and useron then
  1388.   begin nl; print('You have used up all your time. Time expired.'); hangup:=true; end;
  1389.   checkhangup;
  1390.   sdc;
  1391.  end;
  1392. end;
  1393.  
  1394. procedure prestrict(u:userrec);
  1395. var r:restrictions;
  1396. begin
  1397.   for r:=rlogon to rmsg do
  1398.   if r in u.ac then write(copy('LCVBA*PEKM',ord(r)+1,1)) else write('-');
  1399.   writeln;
  1400. end;
  1401.  
  1402. procedure topscr;
  1403. var c:char; x,y,i:integer; spe:astr;
  1404. begin
  1405.  if (usernum<>0) and okt and (windowon=true) then begin
  1406.   x:=wherex; y:=wherey; {i:=wherex;
  1407.   while i>20 do begin writeln; i:=wherex; end;
  1408.   if x>20 then x:=20;}
  1409.   WINDOW(1,22,80,25);tc(1);
  1410.   textcolor(13);
  1411.   for i:=1 to 4 do begin
  1412.      gotoxy(1,i);clreol;
  1413.   end;
  1414.   gotoxy(1,1);write('──[');gotoxy(78,1);write(']──');
  1415.   textcolor(14);
  1416.   with thisuser do begin
  1417.     gotoxy(2,2);write(nam);
  1418.     gotoxy(2,3);write(thisuser.realname);
  1419.     textcolor(11);
  1420.     gotoxy(5,4);write('   ');gotoxy(13,4);write('   ');
  1421.     gotoxy(2,4);write('SL:',thisuser.sl);gotoxy(9,4);write('DSL:',thisuser.dsl);
  1422.     gotoxy(27,2);write('AC:');textcolor(9);prestrict(thisuser);textcolor(11);
  1423.     gotoxy(27,3);write('AR:');textcolor(9);
  1424.     for c:='A' to 'G' do if c in ar then write(c) else write('-');
  1425.     textcolor(11);gotoxy(27,4);write('PH:'+thisuser.ph);gotoxy(43,2);
  1426.     textcolor(10);write('CP:'+computer);
  1427.     if spd='KB' then spe:='KyBd' else spe:=spd;
  1428.     gotoxy(43,3);write('SC:',thisuser.linelen,'X',thisuser.pagelen,' ',spe,' ',thisuser.sex,thisuser.age);
  1429.     textcolor(11);
  1430.     gotoxy(43,4);write('LO:'); if laston<>date then write(laston) else write(ontoday,'       ');
  1431.     gotoxy(61,2);write('MP:',msgpost);gotoxy(61,3);write('ES:',emailsent);
  1432.     gotoxy(61,4);write('FW:',fw);gotoxy(68,2);write('MW:',waiting);
  1433.     {if not useron then begin
  1434.       gotoxy(68,4);write('P:"'+pw+'"');
  1435.     end;}
  1436.     textbackground(0);
  1437.     commandline(chatr);
  1438.   end;
  1439.   IF WINDOWON THEN  WINDOW(1,1,80,21) else WINDOW(1,1,80,24); gotoxy(x,y);
  1440.   tleft;
  1441.   sdc;
  1442.  end;
  1443. end;
  1444.  
  1445. procedure bigwindow;
  1446. var x,y,i:integer;
  1447. begin
  1448.   x:=wherex;y:=wherey;
  1449.   if y>21 then for i:=1 to (y-21) do writeln;
  1450.   if y>21 then y:=21;
  1451.   window(1,1,80,21);
  1452.   gotoxy(x,y);topscr;systat.bwindow:=true;
  1453. end;
  1454.  
  1455. procedure smallwindow;
  1456. var x,y,i:integer;
  1457. begin
  1458.   x:=wherex;y:=wherey;
  1459.   window(1,1,80,24);
  1460.   gotoxy(1,22);clreol;writeln;clreol;writeln;clreol;
  1461.   gotoxy(x,y);topscr;commandline('Commandline Updated');systat.bwindow:=false;
  1462. end;
  1463.  
  1464. function empty:boolean;
  1465. begin
  1466.   if incom then empty:=not commpressed else {empty:=true;} empty:=not keypressed;
  1467.   if keypressed then empty:=false;
  1468.   if hangup then begin dump; empty:=true; end;
  1469. end;
  1470.  
  1471. function inkey:char;
  1472. var c:char;
  1473. begin
  1474.   c:=chr(0); inkey:=chr(0);
  1475.   if keypressed then begin
  1476.     if (ch) and (wcolor=false) then begin cl(systat.sysopcolor); wcolor:=true; end;
  1477.     read(kbd,c); if c=chr(27) then
  1478.       if keypressed then begin
  1479.         read(kbd,c);
  1480.         skey1(c);
  1481.         if c=#68 then
  1482.           c:=#1
  1483.         else
  1484.           c:=#0;
  1485.       end;
  1486.     inkey:=c;
  1487.   end else begin
  1488.     if commpressed and incom then begin
  1489.       if (ch) and (wcolor) then begin cl(systat.usercolor); wcolor:=false; end; inkey:=cinkey;
  1490.     end;
  1491.   end;
  1492. end;
  1493.  
  1494. procedure oc(c:char);
  1495. begin
  1496.   if (c<>#0) and (wantout) then write(c);
  1497.   o(c);
  1498. end;
  1499.  
  1500. procedure outkey(c:char);
  1501. begin
  1502.   if (c<>chr(12)) and (not ((c=chr(7)) and (incom))) then if (c<>#0) and (nopfile=false) and (wantout) then write(c);
  1503.   if (not echo) and (c>=' ') then c:='X';
  1504.   o(c);
  1505.   if c=chr(12) then begin clrscr; lil:=0; end;
  1506.   if c=#7 then begin o(#0); o(#0); o(#0); o(#0); end;
  1507. end;
  1508.  
  1509. procedure outansi(i:char);    (* Send ansi to msdos  1 char *)
  1510. var r:registers;
  1511. begin
  1512.   nopfile:=false;
  1513.   if (i<>#29) and (ord(i)<>16) then begin     (* Strip out linking character *)
  1514.      nopfile:=true;
  1515.      if outcom then outkey(i);
  1516.      nopfile:=false;
  1517.      if (wantout) and (i<>#16) then begin
  1518.        with r do begin
  1519.          dx:=ord(i);
  1520.          ax:=$0200;
  1521.          msdos(Dos.Registers(r));
  1522.        end;
  1523.      end;
  1524.   end;
  1525. end;
  1526.  
  1527. procedure dm(i:astr; var c:char);   (* Throw macro to the input routine *)
  1528. begin
  1529.   buf:=i;
  1530.   if buf<>'' then begin
  1531.     c:=buf[1];
  1532.     buf:=copy(buf,2,length(buf)-1);
  1533.   end;
  1534. end;
  1535.  
  1536. procedure getkey(var c:char);    (* forward function to get a single key *)
  1537. var b,tf,t1:boolean;
  1538. begin
  1539.   lil:=0;
  1540.   if buf<>'' then begin
  1541.     c:=buf[1]; buf:=copy(buf,2,length(buf)-1);
  1542.   end else
  1543.     if not empty then c:=inkey
  1544.     else begin
  1545.       tim:=timer; t1:=false; tf:=false;
  1546.       c:=#0;
  1547.       while (c=#0) and not hangup do begin
  1548.         c:=inkey;
  1549.         if ((timer-tim)>180) and (c=#0) then begin nl;nl;
  1550.           print('** Telegard - Time out at '+time); nl;nl;
  1551.           hangup:=true;
  1552.           sysoplog('  **Time-out at '+time);
  1553.         end;
  1554.         if ((timer-tim)>90) and (not tf) and (c=#0) then begin tf:=true; outkey(chr(7)); end;
  1555.         checkhangup;
  1556.       end;
  1557.     end;
  1558.     if checkit then
  1559.       if (ord(c) and 128)>0 then begin
  1560.         checkit:=false;
  1561.         andwith:=127;
  1562.         c:=chr(ord(c) and andwith);
  1563.       end;
  1564.   skey(c);
  1565. end;
  1566.  
  1567. procedure cls;   (*guess*)
  1568. begin
  1569.   if okansi then begin
  1570.     pr1(#27+'[2J');
  1571.     clrscr;
  1572.   end else
  1573.   outkey(chr(12));
  1574. end;
  1575.  
  1576. procedure wait(b:boolean);         (* Displayed when sysop is working *)
  1577. var c,len:integer;
  1578. begin
  1579.   if b then begin
  1580.     sprompt(systat.wait);
  1581.   end else begin
  1582.     len:=lenn(systat.wait);
  1583.     sll:=''; for c:=1 to (len) do prompt(#8);
  1584.     for c:=1 to (len) do prompt(' ');
  1585.     for c:=1 to (len) do prompt(#8);
  1586.     topscr;
  1587.   end;
  1588. end;
  1589.  
  1590. procedure chsl;     (* Change Security Level *)
  1591. var ij,i:astr; c:integer;
  1592. begin
  1593.   wait(true);
  1594.   Cline('Enter new SL: ');
  1595.   if geek<>'' then thisuser.sl:=value(geek);
  1596.   realsl:=thisuser.sl;
  1597.   wait(false);
  1598. end;
  1599.  
  1600. procedure swac(var u:userrec;r:restrictions);
  1601. begin
  1602.   if r in u.ac then u.ac:=u.ac-[r] else u.ac:=u.ac+[r];
  1603. end;
  1604.  
  1605. procedure acch(c:char; var u:userrec);
  1606. begin
  1607.   case c of
  1608.     'L':swac(u,rlogon);
  1609.     'C':SWAC(u,RCHAT);
  1610.     'V':SWAC(u,RVALIDATE);
  1611.     'B':SWAC(u,RBACKSPACE);
  1612.     'A':SWAC(u,RAMSG);
  1613.     '*':SWAC(u,RPOSTAN);
  1614.     'P':SWAC(u,RPOST);
  1615.     'E':SWAC(u,REMAIL);
  1616.     'K':SWAC(u,RVOTING);
  1617.     'M':swac(u,rmsg);
  1618.   END;
  1619. end;
  1620.  
  1621. Procedure Fix_Window;
  1622. Var X,Y,I,Z:Integer;
  1623. Begin
  1624.   X:=wherex; Y:=Wherey; I:=WhereY;
  1625.   if systat.bwindow then begin
  1626.     if i>21 then for z:=1 to 4-(25-I) do writeln;
  1627.     if y>21 then y:=21;
  1628.   end else begin if y>24 then begin y:=24; writeln; end; end;
  1629.   GotoXy(X,y);
  1630.   if (useron) and (systat.bwindow) then TopScr else if useron then commandline(chatr);
  1631. End;
  1632.  
  1633. procedure chac(var thisuser:userrec);
  1634. var c:char; ij,i:astr; cc:integer;
  1635. begin
  1636.   wait(true);
  1637.   commandline('Toggle Restrictions: (LCVBA*PEKM) - Selection? ');
  1638.   read(kbd,c); c:=upcase(c); commandline(c);
  1639.   acch(c,thisuser);
  1640.   wait(false);
  1641. end;
  1642.  
  1643. procedure chbac;
  1644. var c:char; ij,i:astr; cc:integer;
  1645. begin
  1646.   wait(true);
  1647.   commandline('Toggle which AR flag (A-G)? '); read(kbd,c); c:=upcase(c); commandline(c);
  1648.   if c in ['A'..'G'] then
  1649.     if c in thisuser.ar then
  1650.       thisuser.ar:=thisuser.ar-[c]
  1651.     else
  1652.       thisuser.ar:=thisuser.ar+[c];
  1653.   wait(false);
  1654. end;
  1655.  
  1656. procedure chdsl;
  1657. var ij,i:astr; c:integer;
  1658. begin
  1659.  wait(true);
  1660.  Cline('Enter new DSL: ');
  1661.  if geek<>'' then thisuser.dsl:=value(geek);
  1662.  realdsl:=thisuser.dsl;
  1663.  wait(false);
  1664. end;
  1665.  
  1666. procedure tfile;                             (* Open/Close chat.msg *)
  1667. var i:astr; ii:integer;
  1668. bf:file of byte; cr:boolean;
  1669. begin
  1670.   if cfo then begin
  1671.     cfo:=false;
  1672.     close(cf);
  1673.     commandline('Capture is OFF (See '+systat.gfilepath+' for recording)');
  1674.   end else begin
  1675.     assign(cf,systat.gfilepath+'chat.msg');
  1676.     assign(bf,systat.gfilepath+'chat.msg'); cr:=false;
  1677.     {$I-} reset(bf); {$I+}
  1678.     if ioresult<>0 then cr:=true
  1679.     else begin
  1680.       if filesize(bf)=0 then cr:=true;
  1681.       close(bf);
  1682.     end;
  1683.     if cr then rewrite(cf) else append(cf);
  1684.     cfo:=true;
  1685.     i:=#13+#10+#13+#10+dat+#13+#10+'Recorded with user: '+nam+#13+#10+'------------------------------------'+#13+#10;
  1686.     writeln(cf,i);
  1687.     commandline('Capture is ON (Storing in '+systat.gfilepath+')');
  1688.   end;
  1689. end;
  1690.  
  1691. procedure inli1(var i:astr);             (* Input routine for chat *)
  1692. var cp,g:integer; c:char; cv,cc:integer; r:registers; z:astr; c1:char;
  1693. begin
  1694.   cp:=1;
  1695.   i:='';
  1696.   if ll<>'' then begin prompt(ll); i:=ll; ll:=''; cp:=length(i)+1;end;
  1697.   repeat
  1698.     getkey(c); checkhangup;
  1699.     case ord(c) of
  1700.       32..255:if (cp<79) then begin
  1701.                 i[cp]:=c; cp:=cp+1; outansi(c);
  1702.               end;
  1703.       16:if okansi then begin
  1704.            getkey(c1);
  1705.            cl(ord(chr(ord(c1)-ord('0'))));
  1706.           end;
  1707.       27:if (cp<79) then begin
  1708.               i[cp]:=c; cp:=cp+1; outansi(c);
  1709.            end;
  1710.       8:if cp>1 then begin c:=chr(8);
  1711.                prompt(c+' '+c); cp:=cp-1;
  1712.             end;
  1713.       24:begin
  1714.            for cv:=1 to cp-1 do prompt(chr(8)+' '+chr(8)); cp:=1;
  1715.          end;
  1716.        7:o(#7);
  1717.       23:if cp>1 then repeat
  1718.            prompt(chr(8)+' '+chr(8)); cp:=cp-1;
  1719.          until (cp=1) or (i[cp]=' ');
  1720.        9:begin
  1721.            cv:=5-(cp mod 5); if (cp+cv<79)  then
  1722.              for cc:=1 to cv do begin
  1723.                prompt(' ');
  1724.                i[cp]:=' '; cp:=cp+1;
  1725.              end;
  1726.          end;
  1727.   end;
  1728.   until (c=#13) or (cp=79) or hangup or (not ch);
  1729.   if not ch then begin c:=#13; ch:=false; end;
  1730.   i[0]:=chr(cp-1);
  1731.   if c<>chr(13) then begin
  1732.     cv:=cp-1;
  1733.     while (cv>0) and (i[cv]<>' ') and (i[cv]<>chr(8))do cv:=cv-1;
  1734.     if (cv>(cp div 2)) and (cv<>cp-1) then begin
  1735.       ll:=copy(i,cv+1,cp-cv); for cc:=cp-2 downto cv do prompt(chr(8));
  1736.       for cc:=cp-2 downto cv do prompt(' ');
  1737.       i[0]:=chr(cv-1);
  1738.     end;
  1739.   end;
  1740.   nl;
  1741. end;
  1742.  
  1743. function yn:boolean;                       (* The "YES" or "NO" routine *)
  1744. var c:char;
  1745. begin
  1746.   if not hangup then begin
  1747.     cl(3);
  1748.     repeat
  1749.       getkey(c);
  1750.       c:=upcase(c);
  1751.     until (c='Y') or (c='N') or (c=chr(13)) or hangup;
  1752.     if c='Y' then begin print('Yes'); yn:=true; end else begin print('No'); yn:=false; end;
  1753.     if hangup then yn:=false;
  1754.   end;
  1755. end;
  1756.  
  1757. procedure input1(var i:astr; ml:integer; tf:boolean);
  1758. var cp:integer;
  1759.     c:char;
  1760.     r:real;
  1761. begin
  1762.  checkhangup;
  1763.  if not hangup then begin
  1764.   r:=timer;
  1765.   cp:=1;
  1766.   repeat
  1767.     getkey(c);
  1768.     if c=#1 then r:=timer;
  1769.     if not tf then c:=upcase(c);
  1770.     if (c>=' ') and (c<chr(127)) then
  1771.       if cp<=ml then begin
  1772.       i[cp]:=c;
  1773.       cp:=cp+1;
  1774.       outkey(c);
  1775.       thisline:=thisline+c;
  1776.     end else else case ord(c) of
  1777.       8:if cp>1 then begin
  1778.                c:=chr(8);
  1779.                outkey(c);outkey(' '); outkey(c);
  1780.                cp:=cp-1;
  1781.                if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
  1782.              end;
  1783.       21,24:while cp<>1 do begin
  1784.                cp:=cp-1;
  1785.                outkey(#8);outkey(' '); outkey(#8);
  1786.                if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
  1787.              end;
  1788.     end;
  1789.     if (timer-r)>300.0 then hangup:=true;
  1790.   until (c=#13) or (c=#14) or hangup;
  1791.   i[0]:=chr(cp-1);
  1792.   nl;
  1793.  end;
  1794. end;
  1795.  
  1796. procedure input(var i:astr; ml:integer);  (* Input uppercase only *)
  1797. begin
  1798.   input1(i,ml,false);
  1799. end;
  1800.  
  1801. procedure inputl(var i:astr; ml:integer);   (* Input lower & upper case *)
  1802. begin
  1803.   input1(i,ml,true);
  1804. end;
  1805.  
  1806. procedure onek(var c:char; ch:astr);    (* 1 Key example: onkey(c,'1234'); *)
  1807. var i1,i:astr; tf:boolean;
  1808. begin
  1809.   i1:=thisline; tf:=false;
  1810.   repeat
  1811.     if not(onekey in thisuser.defaults) then begin
  1812.       if tf then prompt(i1);
  1813.       input(i,3);
  1814.       if length(i)=1 then c:=i[1] else c:=' ';
  1815.     end else begin
  1816.       getkey(c);
  1817.       c:=upcase(c);
  1818.     end;
  1819.     tf:=true;
  1820.   until (pos(c,ch)>0) or hangup;
  1821.   if hangup then c:=ch[1];
  1822.   if onekey in thisuser.defaults then print(''+c);
  1823. end;
  1824.  
  1825. procedure centre(var i:astr);   (* Center I String *)
  1826. var n,n1:integer;
  1827. begin
  1828.   if pap<>0 then nl;
  1829.   if i[1]=#2 then i:=copy(i,2,length(i)-1);
  1830.   n:=length(i); n1:=1;
  1831.   while (n1<=length(i)) do begin
  1832.     if i[n1]=#3 then begin
  1833.       n:=n-2;
  1834.       n1:=n1+1;
  1835.     end;
  1836.     n1:=n1+1;
  1837.   end;
  1838.   if n<thisuser.linelen then
  1839.     i:=copy('                                               ',1,
  1840.       (thisuser.linelen-n) div 2)+i;
  1841. end;
  1842.  
  1843.  procedure wkey(var abort,next:boolean);  (* See if user aborts, pauses, etc*)
  1844.  var cc:char;
  1845.  begin
  1846.     while not (empty or hangup or abort) do begin
  1847.       getkey(cc);
  1848.       if (cc=' ') or (cc=chr(3)) or (cc=chr(24)) or (cc=chr(11)) then
  1849.         abort:=true;
  1850.       if (cc=chr(14)) then begin abort:=true; next:=true; end;
  1851.       if (cc=chr(19)) or (cc='P') or (cc='p') then begin
  1852.         getkey(cc);
  1853.       end;
  1854.     end;
  1855.  end;
  1856.  
  1857. function ctim(rl:real):astr;
  1858. var h,m,s:astr;
  1859. begin
  1860.   s:=tch(cstr(trunc(rl-int(rl/60.0)*60.0)));
  1861.   m:=tch(cstr(trunc(int(rl/60.0)-int(rl/3600.0)*60.0)));
  1862.   h:=cstr(trunc(rl/3600.0));
  1863.   if length(h)=1 then h:='0'+h;
  1864.   ctim:=h+':'+m+':'+s;
  1865. end;
  1866.  
  1867. function tlef:astr;
  1868. begin
  1869.   tlef:=ctim(nsl);
  1870. end;
  1871.  
  1872. procedure erase_window;
  1873. Var x,y,i:integer;
  1874. Begin
  1875.   x:=wherex; y:=wherey;
  1876.   window(1,1,80,25);
  1877.   if systat.bwindow then begin
  1878.     for i:=22 to 25 do begin gotoxy(1,i); clreol; end;
  1879.   end else begin gotoxy(1,25); clreol; end;
  1880.   gotoxy(x,y);
  1881. end;
  1882.  
  1883. Procedure Print_File (fn:astr);     (* print ansi file *)
  1884.  Var  fil:Text; i:char; abort,next:boolean; c:Integer; r:registers; x,y:byte;
  1885.  begin
  1886.   if not hangup then begin
  1887.     erase_window;
  1888.     assign(fil,fn);
  1889.     {$I-} reset(fil); {$I+}
  1890.     if ioresult<>0 then print('File not found.') else begin
  1891.       abort:=false;
  1892.       while ((not eof(fil)) and (not abort) and (not hangup)) do begin
  1893.         checkhangup;
  1894.         if (not empty) then wkey(abort,next);
  1895.         read(fil,i);
  1896.            If outcom then o1(i);
  1897.            With r Do Begin
  1898.               DX := Ord(i);
  1899.               AX := $0200;
  1900.               MsDos (Dos.Registers(r));
  1901.            End;
  1902.       end;
  1903.       close(fil);
  1904.     end;
  1905.     fix_window;
  1906.   end;
  1907.   nl;nl;
  1908. end;
  1909.  
  1910. procedure printa1(i:astr; var abort,next:boolean);  (* Print line of text *)
  1911. var c:integer; okmci:boolean;
  1912. begin
  1913.  checkhangup;
  1914.  doit:=true;
  1915.  if (not hangup) and (doit) then begin
  1916.   abort:=false; next:=false; c:=1;
  1917.   if not empty then wkey(abort,next);
  1918.   while (not abort) and (doit) and (c-1<length(i)) and (not hangup) do begin
  1919.     checkhangup;
  1920.     if i[1]='&' then begin
  1921.       if thisuser.sl<value(copy(i,2,4)) then doit:=false;
  1922.       i:=copy(i,5,length(i));
  1923.     end;
  1924.     okmci:=false;
  1925.     if (c-1<length(i)) then begin
  1926.       if i[c]='@' then begin
  1927.         if reading_a_msg=false then
  1928.         begin
  1929.           if i[c+1] in ['1'..'9'] then begin
  1930.             okmci:=true;
  1931.             case i[c+1] of
  1932.               '1':prompt(thisuser.name);
  1933.               '2':prompt(thisuser.realname);
  1934.               '3':prompt(thisuser.ph);
  1935.               '4':prompt(thisuser.citystate);
  1936.               '5':prompt(thisuser.street);
  1937.               '6':prompt(thisuser.zipcode);
  1938.               '7':cls;
  1939.               '8':delay(800);
  1940.               '9':pausescr;
  1941.            end;
  1942.           c:=c+2;
  1943.           end;
  1944.         end;
  1945.       end;
  1946.       if okmci=false then begin
  1947.         if i[c]=chr(8) then begin
  1948.           pap:=pap-1;
  1949.           delay(systat.bsdelay);
  1950.         end else
  1951.           if i[c]=#3 then begin
  1952.              if i[c+1] in [#0..#9] then
  1953.               if okansi then
  1954.               cl(ord(i[c+1]));
  1955.           end else
  1956.              if i[c]<>chr(10) then pap:=pap+1;
  1957.         if not empty then wkey(abort,next);
  1958.         if i[c]=#3 then
  1959.           c:=c+1
  1960.         else
  1961.          if (i[c]<>#29) then outansi(i[c]);
  1962.          c:=c+1;
  1963.       end; {mci seg}
  1964.     end;
  1965.    end;
  1966.    end else abort:=true;
  1967. end;
  1968.  
  1969. procedure printa(i:astr; var abort,next:boolean);
  1970. var s:astr; p,op,rp,rop,nca:integer; crend:boolean; org:astr;
  1971. begin
  1972.   org:=i;
  1973.   nofeed:=false;
  1974.   abort:=false;
  1975.   nopfile:=false;
  1976.   crend:=(i[length(i)]=#1) and (i[length(i)-1]<>#3);
  1977.   if i[length(i)]=#29 then nofeed:=true;
  1978.   if crend then i:=copy(i,1,length(i)-1);
  1979.   if i[1]=#2 then begin
  1980.     centre(i);
  1981.     printa1(i,abort,next);
  1982.     nl;
  1983.   end else begin
  1984.     wkey(abort,next);
  1985.     if i='' then nl;
  1986.     while (i<>'') and (not abort) and (not hangup) do begin
  1987.       rp:=0;
  1988.       if pos(#27,i)=0 then nca:=thisuser.linelen-pap-1 else nca:=255;
  1989.       p:=0;
  1990.       while (rp<nca) and (p<length(i)) do begin
  1991.         if i[p+1]=#8 then rp:=rp-1 else
  1992.           if i[p+1]=#3 then
  1993.             p:=p+1
  1994.           else
  1995.             if (i[p+1]<>#10) then rp:=rp+1;
  1996.         p:=p+1;
  1997.       end;
  1998.       op:=p; rop:=rp;
  1999.       if (rp>=nca) and (p<length(i)) then begin
  2000.         while ((not (i[p] in [' ',#8,#10])) or (i[p-1]=#3)) and (p>1) do begin
  2001.           rp:=rp-1; p:=p-1;
  2002.         end;
  2003.         if p=1 then
  2004.           if not (i[1] in [' ',#8,#10]) then begin rp:=rp-1; p:=p-1; end;
  2005.       end;
  2006.       if abs(rop-rp)>=(thisuser.linelen div 2) then p:=op;
  2007.       s:=copy(i,1,p); delete(i,1,p);
  2008.       if (s[length(s)]=' ') and not nofeed then s[0]:=pred(s[0]);
  2009.       printa1(s,abort,next);
  2010.       if ((i='') and crend) or (i<>'') or abort then
  2011.         if ((nofeed=false) or (doit=true)) then nl
  2012. {      if (crend) and (i<>'') or abort then if (nofeed=false) and (doit=true) then nl}
  2013.       else
  2014.         IF NOFEED=FALSE THEN printa1(' ',abort,next);
  2015.         doit:=true;
  2016.     end;
  2017.   end;
  2018. end;
  2019.  
  2020. procedure printacr(i:astr; var abort,next:boolean);
  2021. begin
  2022.  if not abort then
  2023.  {if (i[length(i)]<>#1) and (i[length(i)]<>#29) then i[length(i)+1]:=#1;}
  2024.   if (i[length(i)]=#1) or (i[length(i)]=#29) then
  2025.     printa(i,abort,next)
  2026.   else
  2027.     printa(i+#1,abort,next);
  2028. end;
  2029.  
  2030. function cstrr(rl:real; base:integer):astr;
  2031. var c1,c2,c3:integer; i:astr; r1,r2:real;
  2032. begin
  2033.  if rl<=0.0 then cstrr:='0' else begin
  2034.   r1:=ln(rl)/ln(1.0*base);
  2035.   r2:=exp(ln(1.0*base)*(trunc(r1)));
  2036.   i:='';
  2037.   while (r2>0.999) do begin
  2038.     c1:=trunc(rl/r2);
  2039.     i:=i+copy('0123456789ABCDEF',c1+1,1);
  2040.     rl:=rl-c1*r2;
  2041.     r2:=r2/(1.0*base);
  2042.   end;
  2043.   cstrr:=i;
  2044.  end;
  2045. end;
  2046.  
  2047. {procedure erhnd(erno,eradr:integer);
  2048. begin
  2049.   cl(8); print('Critical System Error Has Occured ... Shutting Down');
  2050.   sysoplog(#3+#8+'Critical System Error');
  2051.   halt(2);
  2052. end;}
  2053.  
  2054. procedure savesystat;  (* save systat *)
  2055. begin
  2056.   reset(systatf); write(systatf,systat); close(systatf);
  2057. end;
  2058.  
  2059. procedure pfl(fn:astr; var abort:boolean; cr:boolean);
  2060. var fil:text;
  2061.     i:astr;
  2062.     ofn:astr;
  2063.     p:integer;
  2064.     next:boolean;
  2065. begin
  2066.   nofile:=false;
  2067.     if not hangup then begin
  2068.       assign(fil,fn);
  2069.       {$I-} reset(fil); {$I+}
  2070.       if ioresult<>0 then nofile:=true else
  2071.       begin
  2072.        abort:=false;
  2073.         while not eof(fil) and (not abort) and (not hangup) and (nofile=false) do begin
  2074.           readln(fil,i);
  2075.           if cr then
  2076.             printacr(i,abort,next)
  2077.           else
  2078.             printa(i,abort,next);
  2079.         end;
  2080.         close(fil);
  2081.       end;
  2082.     end;
  2083.   nl;
  2084. end;
  2085.  
  2086. procedure printfile(fn:astr);         (* Print normal text file *)
  2087. var abort:boolean;
  2088. begin
  2089.   pfl(fn,abort,true);
  2090. end;
  2091.  
  2092. procedure printf(fn:astr);      (* See if an *.ans file is available *)
  2093. var fil:text;                  (* if you have ansi graphics invoked *)
  2094. begin
  2095.   if okansi then begin
  2096.     assign(fil,fn+'.ans');
  2097.     {$I-} reset(fil); {$I+}
  2098.     if ioresult<>0 then nofile:=true else begin nofile:=false; close(fil); end;
  2099.     if nofile then printfile(fn+'.msg') else print_file(fn+'.ans');
  2100.   end else printfile(fn+'.msg');
  2101. end;
  2102.  
  2103. procedure chat;  (*Break into chat *)
  2104. var c,ohl:char; tf:boolean; sp,xx:astr; x:integer; t,t1:real;
  2105.     i,hollie:integer; ff:astr;
  2106. begin
  2107.   sp:=thisline; ch:=true; chatcall:=false; tf:=echo; echo:=true;nl;nl; t:=timer;
  2108.   thisuser.option:=thisuser.option-[alert];
  2109.   cl(5); sprompt(systat.engage); cl(systat.usercolor);
  2110.   nl; nl; commandline('Chat Engaged.');
  2111.   if chatr<>'' then begin
  2112.     commandline(chatr); print(' '); chatr:='';
  2113.   end;
  2114.   repeat
  2115.     inli1(xx);
  2116.       if (copy(xx,1,6)='/type ') then begin
  2117.       ff:=copy(xx,7,length(xx));printfile(ff);
  2118.     end;
  2119.     if (xx='/page') then begin
  2120.       for i:=650 to 700 do begin;
  2121.         sound(i);delay(2);delay(2);nosound;
  2122.       end;
  2123.       repeat
  2124.           i:=i-1;
  2125.           sound(i);delay(2);nosound;
  2126.       until (i=200);
  2127.       prompt(#7); prompt(#7);
  2128.     end;
  2129.     if (xx='/q') or (xx='/Q') then begin
  2130.       t1:=timer; while (abs(t1-timer)<1.0) and (not keypressed) do;
  2131.       if not keypressed then begin ch:=false; print('Chat Aborted ...'); end;
  2132.     end else
  2133.   if cfo then writeln(cf,xx);
  2134.   until (not ch) or hangup;
  2135.   nl; cl(5); sprompt(systat.endchat); nl; nl; commandline('Chat mode over.');
  2136.   chattime:=chattime+timer-t; ch:=false; echo:=tf;
  2137.   if hangup and cfo then begin
  2138.     writeln(cf); writeln(cf,'NO CARRIER');
  2139.   end;
  2140.   prompt(sp); thisline:=sp;
  2141.   if cfo then begin cfo:=false; close(cf); end;
  2142. end;
  2143.  
  2144. procedure skey;   (* Global user keys *)
  2145. var i:astr;
  2146. begin
  2147.   case ord(c) of
  2148.       6:if macok and (buf='') then dm(' '+thisuser.macro[2],c);
  2149.       4:if macok and (buf='') then dm(' '+thisuser.macro[1],c);
  2150.      20:begin
  2151.           i:=thisline;
  2152.           nl; nl; cl(0); prompt('Date.......: '); cl(9); print(dat);
  2153.           cl(0); prompt('Time left..: '); cL(5); print(tlef);
  2154.           cl(0); prompt('Time on....: '); cL(5); print(ctim(timer-timeon));
  2155.           nl; prompt(i);
  2156.         end;
  2157.     127:c:=#8;
  2158.    end;
  2159. end;
  2160.  
  2161. Procedure SysopShell;
  2162. var t:real;
  2163. Begin
  2164.   t:=timer;
  2165.   If useron then Begin
  2166.      Nl; Nl; Cl(5);
  2167.      Print('>> '+systat.sysopfirst+' '+systat.sysoplast+' has Shelled to dos, please wait ...');
  2168.   End;
  2169.   Window(1,1,80,25);
  2170.   ClrScr;
  2171.   Writeln('Type "EXIT" to return to Telegard.');
  2172.   Exec('\Command.Com','/C Command.Com'); {Drop To DOS}
  2173.   ChDir(Start_Dir);
  2174.   Writeln('Returned From DOS Shell.');
  2175.   GamePort;
  2176.   TopScr;
  2177.   If useron then Begin Cl(5); Print('>> Thank you for waiting'); End;
  2178.   chattime:=chattime+timer-t; tim:=timer; dump;
  2179. End;
  2180.  
  2181. procedure skey1(c:char);     (* Global sysop keys *)
  2182. var b:boolean; z,xx,yy,cz:integer; i:integer; s:astr;
  2183. begin
  2184.  wcolor:=false;
  2185.  case ord(c) of
  2186.    46:cls;
  2187.   113:commandline(chatr);
  2188.    59:chsl;
  2189.    60:chac(thisuser);
  2190.    61:begin
  2191.         if outcom then incom:=not incom;
  2192.         if incom then commandline('User keyboard is now ON.')
  2193.           else commandline('User keyboard is now OFF.');
  2194.         dump;
  2195.       end;
  2196.    62:begin chatcall:=false; chatr:=''; thisuser.option:=thisuser.option-[alert]; tleft; end;
  2197.    63:hangup:=true;
  2198.    64:tleft;
  2199.    65:begin b:=ch; ch:=true; extratime:=extratime-5*60; tleft; ch:=b;end;
  2200.    66:begin b:=ch; ch:=true; extratime:=extratime+5*60; tleft; ch:=b;end;
  2201.    67:begin
  2202.          if thisuser.sl=255 then if realsl<>255 then begin
  2203.            thisuser.sl:=realsl; thisuser.dsl:=realdsl;commandline('Security level restored.');
  2204.            end
  2205.          else else begin
  2206.             thisuser.sl:=255; realdsl:=thisuser.dsl; thisuser.dsl:=255;
  2207.             commandline('Temporary sysop access granted.');
  2208.          end; topscr;
  2209.        end;
  2210.    68:if ch then
  2211.         ch:=false
  2212.       else begin
  2213.         chat;
  2214.       end;
  2215.    71:if ch then tfile;
  2216.    84:chdsl;
  2217.    85:chbac;
  2218.    86:begin
  2219.        if outcom then begin nl;nl;cl(5);print('Please wait ...');nl;nl;commandline('Text Concealed │ User Keyboard Off');
  2220.          outcom:=false;incom:=false;end
  2221.        else begin outcom:=true;commandline('Normal mode │ User keyboard on');nl;
  2222.          cl(5);print('Sorry for the inconvience.');nl;nl;incom:=true;end;
  2223.        end;
  2224.    87:begin
  2225.         if windowon=true then begin
  2226.           windowon:=false; smallwindow;
  2227.          end else
  2228.          begin windowon:=true; bigwindow; end;
  2229.       end;
  2230.    88:begin cline('Display what hangup file (HANGUPxx.MSG)? ');nl;nl;incom:=not incom;
  2231.         printfile(systat.gfilepath+'hangup'+geek+'.MSG'); hangup:=true; end;
  2232.    93:begin beepend:=not beepend; b:=ch; ch:=true; tleft; ch:=b; end;
  2233.    103:begin
  2234.        wait(true);
  2235.          nl;nl;for i:=1 to 9 do begin write(cstr(i)+'] ');writeln(systat.sysopmacro[i]); end;
  2236.        cline('Change which macro? ');z:=0;z:=value(geek); if z in [1..9] THEN cline(':');systat.sysopmacro[z]:=geek;
  2237.        wait(false);
  2238.      end;
  2239.    94..102:begin i:=(ord(c)-93);prompt(systat.sysopmacro[i]); end;
  2240.    104:topscr;
  2241.    105:commandline('U/L: '+cstr(thisuser.uploads)+'/'+cstr(thisuser.uk)+'k'+
  2242.          ' │ D/L: '+cstr(thisuser.downloads)+'/'+cstr(thisuser.dk)+'k'+
  2243.          ' File Points:' +cstr(thisuser.filepoints));
  2244.    106:if wantout then begin clrscr; writeln('Text OFF'); wantout:=false; end else begin clrscr; writeln('Text ON');
  2245.      wantout:=true; end;
  2246.    107:SysopShell;
  2247.    108:begin
  2248.          randomize;
  2249.          for i:=1 to 50 do begin
  2250.            cz:=random(255); prompt(chr(cz));
  2251.          end;
  2252.          hangup:=true;
  2253.        end;
  2254.    109:begin
  2255.          wait(true);
  2256.          cline('Enter new file points:');
  2257.          wait(false);
  2258.          if geek<>'' then thisuser.filepoints:=value(geek);
  2259.        end;
  2260.     47:Begin  {Auto Validate}
  2261.          Wait(True); Thisuser.Sl:=Systat.AutoSL; Thisuser.Dsl:=Systat.AutoDsl;
  2262.          Thisuser.Ar:=Systat.AutoAr; Thisuser.Ac:=Systat.AutoAc;
  2263.          Wait(False);
  2264.        End;
  2265.    end;
  2266. end;
  2267. end.