home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 153.img / TELES.ZIP / COMMON4U.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-01-25  |  55.5 KB  |  2,332 lines
  1.                     Turbo 4 Implementation of WWIV
  2.  
  3.                       Modification to Common.pas
  4.                            by Steve Lesner
  5.                      Sysop of ACC: (203) 531-4289
  6.                     20 hrs online at 300/1200/2400
  7.  
  8.                      Original Author: Wayne Bell
  9.  
  10. The following code is a modification of Wayne Bell's Common include file
  11. from version 3.21D.  It has already been unitized and should not need any
  12. altering.  You will have to Unitize YOUR copyies of BBS.PAS, PART1.PAS,
  13. PART2.PAS, PART3.PAS , and DLOADS.PAS.  Note that I left out the Dos module
  14. due to Memory constraints.  You see, after you Unitize the BBS with all its
  15. PART?.PAS files plus the DLOADS, you will be running a BBS that takes up
  16. about 350K of memory.  Borland is suppose to implement Chain files soon and
  17. that should rectify this problem.  But if you have the memory, WWIV will
  18. now fly !!
  19.  
  20. Okay, now for the meat of it.  You should read the Turbo 4 manual concerning
  21. Chain files and Upgrading your old Turbo 3 programs.  There are a few things
  22. you will need to do that Borlands upgrade will not!
  23.  
  24. 1) Change all occurences of the Var Type Str to a Var of Type Astr.  This
  25.    means areas such as "Procedure xxx (Var Whatever:Str);" should change to
  26.    "Procedure xxx(Var Whatever:Astr);".  DO NOT CHANGE STATMENTS SUCH AS
  27.    "Str(i,s)" to "Astr(i,s)".  This is a function call.  The reason for
  28.    this change is that Turbo 3 should never have allowed a Variable to be
  29.    declared as Type Str (As Wayne was guilty of).  It now conflicts with
  30.    the Function Str(x,y);  Do note that everything else other than the
  31.    Function Str should be changed such as Local Vars of Type Str too!
  32.  
  33. 2) In your Dloads and BBS modules, take out the logic that calls the Dloads
  34.    chain so that you do not Iport before calling Dloads and you do not have
  35.    a Return before returning to the BBS.  This was only needed for Chains
  36.    and is true of any other Units (Old CHains) you decide to add to the BBS.
  37.  
  38. 3) Your Main Code in BBS.PAS should look like this:
  39.  
  40.   begin  {Main Loop}
  41.    checkbreak:=false;  { Takes the place of $C-}
  42.    getdir(0,i);
  43.    async_init;         { Initalize the Port instead of}
  44.    init;               { worrying about Ret Values Returned}
  45.                        { by chains}
  46.    repeat
  47.      getcaller;
  48.      if not doneday then
  49.        begin
  50.          if getuser then
  51.             newuser;
  52.          macok:=true;
  53.          if not hangup then
  54.            if logon then
  55.              readmail;
  56.        end;
  57.      flush(sysopf);
  58.      if thisuser.age=0 then
  59.        getnewinfo;
  60.      while not hangup do
  61.        mainmenu;
  62.      term_ready(false); delay(500);
  63.      if useron then
  64.        logoff;
  65.      if cdet and (not doneday) then
  66.        hangupphone;
  67.      if enddayf then
  68.        endday;
  69.      enddayf:=false;
  70.    until doneday;
  71.    close(sysopf);
  72.    term_ready(true); delay(100); pr('ATZ');
  73.    remove_port;
  74.    halt(elevel);
  75.   end.  {Main Loop}
  76.  
  77.    The main difference is that the Ret variable is gone!  It is also gone
  78.    in this Common4u.pas file so get rid of all references to it.  You may
  79.    also want to get rid of the Chain procedures and any calls to them since
  80.    they are not needed.  Here is a look at my Interfaces that I used:
  81.  
  82. Part1:========================================================================
  83.  
  84. {$R-}    {Range checking off}
  85. {$B+}    {Boolean complete evaluation on}
  86. {$S+}    {Stack checking on}
  87. {$I+}    {I/O checking on}
  88. {$N-}    {No numeric coprocessor}
  89. {$V-}
  90.  
  91. Unit Unit0; {Part1 renamed to Unit 0 for sanity's sake}
  92.  
  93. Interface
  94.  
  95. Uses
  96.   Crt,
  97.   Dos,
  98.   Turbo3,
  99.   Common;
  100.  
  101. procedure printfile1(fn:astr; var abort:boolean);
  102. procedure inli(var i:astr);
  103. function filename(mrec:messages):astr;
  104. procedure inmsg(var mrec:messages;an:anontyp;var title:astr;tr,mp:boolean);
  105. procedure readmsg(mrec:messages;rname:boolean; var next:boolean);
  106. function greater(mrec:messages):boolean;
  107. function maxage(x:integer):integer;
  108. function boardacpw(nb:integer):boolean;
  109. function boardac(nb:integer):boolean;
  110. procedure isr(uname:astr;usernum:integer);
  111. function ctp(t,b:integer):astr;
  112. procedure vali(un:integer);
  113. procedure vallastuser;
  114. procedure iscan;
  115. procedure savebase;
  116. function tnum:integer;
  117. procedure deletem(ntd:integer);
  118. procedure readm(cn:integer; var next:boolean; var unvali:boolean);
  119. function mln(i:astr; l:integer):astr;
  120. function mn(i,l:integer):astr;
  121. procedure inu(var i:integer);
  122. procedure ini(var i:byte);
  123.  
  124. {The Implementation of Your Converted Unit goes here!}
  125.  
  126. Part2:========================================================================
  127.  
  128. {$R-}    {Range checking off}
  129. {$B+}    {Boolean complete evaluation on}
  130. {$S+}    {Stack checking on}
  131. {$I+}    {I/O checking on}
  132. {$N-}    {No numeric coprocessor}
  133. {$V-}
  134.  
  135. Unit Unit1; {Part2 renamed to Unit 1 for sanity's sake}
  136.  
  137. Interface
  138.  
  139. Uses
  140.   Crt,
  141.   Dos,
  142.   Turbo3,
  143.   Common,
  144.   Unit0;
  145.  
  146. function checkpw:boolean;
  147.  procedure finduser(var usernum:integer);
  148.  procedure post;
  149.  procedure p1;
  150.  function p2:boolean;
  151.  function rmail(n:integer):astr;
  152.  procedure dsr(uname:astr);
  153.  procedure ssm(dest:integer; s:astr);
  154.  procedure rsm;
  155.  procedure chbds;
  156.  procedure pmsg(x:integer);
  157.  procedure pdfinf;
  158.  procedure forwardmail;
  159.  procedure bed;
  160.  procedure bem;
  161.  procedure bei;
  162.  procedure dlbed;
  163.  procedure dlbem;
  164.  procedure dlbei;
  165.  procedure chstb;
  166.  procedure chsta;
  167.  procedure chstc;
  168.  procedure chstd;
  169.  procedure chste;
  170.  procedure chstg;
  171.  procedure mmacroo;
  172.  procedure readamsg;
  173.  procedure logon1;
  174.  function vote1x(qnum:integer; var vd:vdatar):boolean;
  175.  procedure wmsg;
  176.  procedure email(touser:integer; xx:boolean);
  177.  function forwardm(n:integer):integer;
  178.  procedure smail2(na:emary);
  179.  procedure chcolors;
  180.  procedure initp1;
  181.  procedure getcallera(var c:char; var chkcom:boolean);
  182.  procedure beephim;
  183.  procedure imail(i:integer);
  184.  
  185. {The Implementation of Your Converted Unit goes here!}
  186.  
  187. Part3:========================================================================
  188.  
  189. {$R-}    {Range checking off}
  190. {$B+}    {Boolean complete evaluation on}
  191. {$S+}    {Stack checking on}
  192. {$I+}    {I/O checking on}
  193. {$N-}    {No numeric coprocessor}
  194. {$V-}
  195.  
  196. Unit unit2; {Part3 renamed to Unit 2 for sanity's sake}
  197.  
  198. Interface
  199.  
  200. Uses
  201.   Crt,
  202.   Dos,
  203.   Turbo3,
  204.   Common,
  205.   Unit0,
  206.   Unit1;
  207.  
  208.  
  209. procedure readmail;
  210.  procedure newuser;
  211.  function getuser:boolean;
  212.  procedure vote;
  213.  procedure ratio;
  214.  function logon:boolean;
  215.  procedure reqchat;
  216.  procedure yourinfo;
  217.  procedure prg(x:boolean);
  218.  procedure wamsg;
  219.  procedure removem;
  220.  procedure boardlist;
  221.  procedure delmail;
  222.  procedure gfiles;
  223.  procedure chpw;
  224.  procedure mmacro;
  225.  procedure default;
  226.  procedure logoff;
  227.  procedure endday;
  228.  procedure smail(tf:boolean);
  229.  procedure ulist;
  230.  procedure getnewinfo;
  231.  procedure chuser;
  232.  procedure oldusers;
  233.  procedure pstat;
  234.  procedure initvotes;
  235.  procedure boardedit;
  236.  procedure mailr;
  237.  procedure changestuff;
  238.  procedure dlboardedit;
  239.  procedure init;
  240.  procedure movemsg(var cn:integer);
  241.  procedure hangupphone;
  242.  procedure zlog;
  243.  procedure autoreply;
  244.  
  245. {The Implementation of Your Converted Unit goes here!}
  246.  
  247.  
  248. BBS:==========================================================================
  249.  
  250. PROGRAM BBS;
  251.  
  252. {NOTE:
  253.       I used the command "TPC /$V- /$L- /M BBS" to Compile.
  254.       This will build all modules, only if necessary.}
  255.  
  256. {$R-}                   {Range checking off}
  257. {$B+}                   {Boolean complete evaluation on}
  258. {$S+}                   {Stack checking on}
  259. {$I+}                   {I/O checking on}
  260. {$N-}                   {No numeric coprocessor}
  261. {$M 32150,0,0}          {Declared here suffices for all Units as well!}
  262. {$V-}
  263.  
  264. Uses
  265.   Crt,
  266.   Dos,
  267.   Turbo3,
  268.   Common,
  269.   Dloads,
  270.   Unit0,
  271.   Unit1,
  272.   Unit2,
  273.  
  274. {The rest of the procedures and functions not listed in Unit0-2 go here}
  275. {The main code should be similar to my above example and will go here after}
  276. {any other functions or procedures not included in the above modules.}
  277.  
  278. Note that I have not included Dloads in this source.  I have made too many
  279. changes to it to be of any use.  With the above examples, and Borlands
  280. Upgrade program, you should have little or no problems.  Also note that
  281. without the Dos Module incorporated, you will need to disbale the calls
  282. in all Units to the Dos Module Functions.  This means that you will lose
  283. Functions such as Terminal mode, Validate users outside the BBS, The Edit
  284. Routines as well as the '=' function.  This loss is better than adding more
  285. memory overhead as far as I'm concerning, but you could certainly include it
  286. if you like.
  287.  
  288. ONE LAST THING:
  289.      90% of this code is owned and distrubuted by Wayne Bell, not me.  I do
  290. claim responsibilty for one of the First Sysops to succeed in this conversion.
  291. The conversion was completed in early Novemeber of the Year 1987.  If you find
  292. this to be helpful to you, then an upload to my board will suffice any $$$ and
  293. I earnestly request that you do so for your own conscience!!  Enjoy and don't
  294. forget to Post my BBS on your Board!!  Thank you!
  295.  
  296.                             Steve Lesner
  297.  
  298. Common Begins Here:===========================================================
  299.  
  300. {$I-} { I/O hecking OFF }
  301. {$R-} { Range checking OFF }
  302. {$S-} { Stack checking OFF }
  303. {$V-} { Var-str checking OFF}
  304. {$B+} {Boolean complete evaluation on}
  305. {$N-} {No numeric coprocessor}
  306.  
  307. Unit Common;
  308.  
  309. Interface
  310.  
  311. Uses
  312.   Crt,
  313.   Dos,
  314.   Turbo3;
  315.  
  316. { global declarations  for Async}
  317.  
  318. type
  319.   astr = String[160];  { generic string type for parameters      }
  320.                        { note the change from Waynes str => Astr }
  321.  
  322. const
  323.   buffer_max = 5120;
  324.  
  325. var
  326.   Async_OriginalVector : pointer;
  327.   buffer       : Array[0..buffer_max] of char;
  328.  
  329.   Async_Open_Flag    : Boolean;   { true if Open but no Close }
  330.   Async_Port         : Integer;   { current Open port number (1 or 2) }
  331.   base               : Integer;   { base for current open port }
  332.   Async_Irq          : Integer;   { irq for current open port }
  333.  
  334.   Async_Buffer_Overflow : Boolean;  { True if buffer overflow has happened }
  335.   Async_Buffer_Used     : Integer;
  336.   Async_MaxBufferUsed   : Integer;
  337.  
  338.                  { buffer is empty if Head = Tail }
  339.   Buffer_head  : Integer;   { Locn in buffer to put next char }
  340.   Buffer_tail  : Integer;   { Locn in buffer to get next char }
  341.   Buffer_newtail : Integer;
  342.  
  343.  
  344. { End of Async declarations }
  345.  
  346.  
  347. CONST strlen=160;
  348.       maxusers=500;
  349.       comptyp:array[1..8] of string[14]=
  350.         ('IBM           ','Apple         ','TRS-80        ','Z-80 CP/M     ',
  351.          'Commodore     ','Atari         ','Dumb Terminal ','Other         ');
  352.  
  353.  
  354. TYPE
  355.      restrictions=(rlogon,rchat,rvalidate,rbackspace,ramsg,rpostan,
  356.                    rpost,remail,rvoting,rmsg);
  357.      acrq='@'..'G';
  358.      newtyp=(rp,lt,rm);
  359.      deflts=(spcsr,onekey,wordwrap,pause,mmnu,ansi,color,music);
  360.      pnr=record name:string[40]; number:string[14]; hs:byte; end;
  361.      anontyp=(no,yes,forced,dearabby);
  362.      ansttype=(postn,emailn,pana,sanm,cosysop,lcosysop);
  363.      opts=(alert,smw,nomail);
  364.      dlnscan=set of 0..39;
  365.      emary=array[1..20] of integer;
  366.      clrs=array[false..true,1..8] of byte;
  367.      slr=record
  368.            ttime:byte;
  369.            mallowed:integer;
  370.            emails,posts:byte;
  371.            anst:set of ansttype;
  372.          end;
  373.      messages=record
  374.                 ltr:char;
  375.                 number:integer;
  376.                 ext:byte;
  377.               end;
  378.      smalrec=record
  379.                name:string[25];
  380.                number:integer;
  381.              end;
  382.      userrec=record
  383.                name:string[25];
  384.                realname:string[14];
  385.                deleted:boolean;
  386.                pw:string[8];
  387.                ph:string[12];
  388.                waiting:byte;
  389.                laston:string[10];
  390.                loggedon:integer;
  391.                msgpost:integer;
  392.                emailsent:integer;
  393.                feedback:integer;
  394.                linelen:byte;
  395.                pagelen:byte;
  396.                defaults:set of deflts;
  397.                ontoday:byte;
  398.                illegal:byte;
  399.                ttimeon:real;
  400.                dlnscn:dlnscan;
  401.                sl:byte;
  402.                ac:set of restrictions;
  403.                ar:set of acrq;
  404.                qscan:array[1..19] of messages;
  405.                qscn:array[1..19] of boolean;
  406.                macro:array[1..2] of string[79];
  407.                comptype:byte;
  408.                option:set of opts;
  409.                vote:array[1..9] of byte;
  410.                sbn:byte;
  411.                dsl:byte;
  412.                uploads,downloads:integer;
  413.                uk,dk:integer;
  414.                age:byte;
  415.                sex:char;
  416.                note:string[39];
  417.                forusr:integer;
  418.                cols:clrs;
  419.                res:array[1..72] of byte;
  420.              end;
  421.       boardrec=record
  422.                  name:string[30];
  423.                  filename:string[12];
  424.                  sl:byte;
  425.                  maxmsgs:byte;
  426.                  pw:string[10];
  427.                  anonymous:anontyp;
  428.                  ar:acrq;
  429.                  key:char;
  430.                  postsl:byte;
  431.                end;
  432.       msgstat=(validated,unvalidated,deleted);
  433.       messagerec=record
  434.                    title:string[30];
  435.                    messagestat:msgstat;
  436.                    message:messages;
  437.                    owner:integer;
  438.                    date:integer;
  439.                    mage:byte;
  440.                  end;
  441.       systatrec=record
  442.                   boardpw:string[8];
  443.                   sysoppw:string[8];
  444.                   hmsg:messages;
  445.                   users:integer;
  446.                   lastdate:string[8];
  447.                   callernum:integer;
  448.                   activetoday:integer;
  449.                   callstoday:integer;
  450.                   msgposttoday:integer;
  451.                   emailtoday:integer;
  452.                   fbacktoday:integer;
  453.                   uptoday:integer;
  454.                   closedsystem:boolean;
  455.                   comport:byte;
  456.                   maxbaud:integer;
  457.                   dloadpath:string[79];
  458.                   gfiledate:string[8];
  459.                   lowtime,hitime:integer;
  460.                   res:array[1..200] of byte;
  461.                 end;
  462.       blk=array[1..255] of byte;
  463.       mailrec=record
  464.                 title:string[30];
  465.                 from,destin:integer;
  466.                 msg:messages;
  467.                 date:integer;
  468.                 mage:byte;
  469.               end;
  470.       gft=record
  471.             num:integer;
  472.             title:string[40];
  473.             filen:string[12];
  474.           end;
  475.       smr=record
  476.             msg:astr;
  477.             destin:integer;
  478.           end;
  479.       vdatar=record
  480.                question:string[79];
  481.                numa:integer;
  482.                answ:array[0..9] of record
  483.                       ans:string[25];
  484.                       numres:integer;
  485.                     end;
  486.              end;
  487.       ulrec=record
  488.               name:string[25];
  489.               filename:string[12];
  490.               password:string[10];
  491.               dsl:byte;
  492.               maxfiles:integer;
  493.             end;
  494.       ulfrec=record
  495.                filename:string[12];
  496.                description:string[60];
  497.                res:array[1..17] of byte;
  498.                nacc:integer;
  499.                ft:byte;
  500.                blocks:integer;
  501.                owner:integer;
  502.                date:string[8];
  503.                daten:integer;
  504.              end;
  505.       strptr=^strrec;
  506.       strrec=record
  507.                i:astr;
  508.                next,last:strptr;
  509.              end;
  510.       zlogt=record
  511.               date:string[8];
  512.               active,calls,post,email,fback,up:integer;
  513.             end;
  514.       Str255=String[255];
  515.       Str66=String[66];
  516.  
  517. CONST dcols:clrs=((7,7,15,15,15,112,15,143),(7,7,11,14,5,31,2,140));
  518.  
  519. var sf:file of smalrec;
  520.     uf:file of userrec;
  521.     bf:file of boardrec;
  522.     mailfile:file of mailrec;
  523.     ulf:file of ulrec;
  524.     uboards:array[0..19] of ulrec;
  525.     maxulb:integer;
  526.     sysopf:text{[1024]};
  527. {! 4. Use the n^ew standard procedure SetTextBuf to set Text buffer size.}
  528. {  This has not caused a crash yet but should be changed!}
  529.     slf:file of slr;
  530.     seclev:array[0..255] of slr;
  531.     systatf:file of systatrec;
  532.     systat:systatrec;
  533.     sr:smalrec;
  534.     thisline,chatr,buf,spd,irt,lastname,ll,i:astr;
  535.     thisuser,user:userrec;
  536.     boards:array[1..19] of boardrec;
  537.     fw,extramsgs,mread,board,numboards,t,usernum:integer;
  538.     pap,lil,realsl,ftoday,ptoday,etoday:integer;
  539.     c,ID:char;
  540.     hungup,useron,next,chatcall,doneday,echo,hangup,incom,outcom:boolean;
  541.     extratime,chattime,timeon:real;
  542.     mailread,smread,macok,lan,enddayf,ch,quit,beepend:boolean;
  543.     smf:file of smr;
  544.     srl:array[0..maxusers] of smalrec;
  545.     vqu:array[1..9] of boolean;
  546.     ldate:integer;
  547.     cmd:char;
  548.     bread:byte;
  549.     bchanged:boolean;
  550.     mary:array[0..200] of messagerec;
  551.     cf:text; cfo,okt:boolean;
  552.     elevel:byte;
  553.     curco:byte;
  554.     sll:astr;
  555.     andwith:byte;
  556.     checkit,comd:boolean;
  557.  
  558.  
  559. function freek(d:integer):integer;
  560.  
  561. function cs:boolean;
  562.  
  563. function so:boolean;
  564.  
  565. function lcs:boolean;
  566.  
  567. function nma:integer;
  568.  
  569. function okansi:boolean;
  570.  
  571. function commpressed : boolean;
  572.  
  573. procedure dump;
  574.  
  575. procedure remove_port;
  576.  
  577. procedure term_ready(s:Boolean);
  578.  
  579. procedure set_baud(r:integer);
  580.  
  581. procedure iport;
  582.  
  583. function cinkey1:char;
  584.  
  585. function cinkey:char;
  586.  
  587. procedure o1(c:char);
  588.  
  589. procedure o(c:char);
  590.  
  591. function timer:real;
  592.  
  593. function nsl:real;
  594.  
  595. function sysop1:boolean;
  596.  
  597. function sysop:boolean;
  598.  
  599. procedure sl1(i:astr);
  600.  
  601. procedure sysoplog(i:astr);
  602.  
  603. function tch(i:astr):astr;
  604.  
  605. function time:astr;
  606.  
  607. function date:astr;
  608.  
  609. function value(I:astr):integer;
  610.  
  611. function cstr(i:integer):astr;
  612.  
  613. function nam:astr;
  614.  
  615. function leapyear(yr:integer):boolean;
  616.  
  617. function days(mo,yr:integer):integer;
  618.  
  619. function daycount(mo,yr:integer):integer;
  620.  
  621. function daynum(dt:astr):integer;
  622.  
  623. function dat:astr;
  624.  
  625. function cdet:boolean;
  626.  
  627. procedure checkhangup;
  628.  
  629. procedure getkey(var c:char);
  630.  
  631. procedure pr1(i:astr);
  632.  
  633. procedure pr(i:astr);
  634.  
  635. procedure sdc;
  636.  
  637. procedure stsc;
  638.  
  639. function xclr(c:integer):astr;
  640.  
  641. procedure setc(cl:byte);
  642.  
  643. procedure ansic(c:integer);
  644.  
  645. procedure prompt(i:astr);
  646.  
  647. procedure pausescr;
  648.  
  649. procedure print(i:astr);
  650.  
  651. procedure nl;
  652.  
  653. procedure prt(i:astr);
  654.  
  655. procedure ynq(i:astr);
  656.  
  657. procedure mpl(c:integer);
  658.  
  659. procedure tleft;
  660.  
  661. procedure prestrict(u:userrec);
  662.  
  663. procedure ff(i:integer);
  664.  
  665. procedure topscr;
  666.  
  667. function empty:boolean;
  668.  
  669. procedure skey1(var c:char);
  670.  
  671. function inkey:char;
  672.  
  673. procedure oc(c:char);
  674.  
  675. procedure outkey(c:char);
  676.  
  677. procedure ptime;
  678.  
  679. procedure skey(var c:char);
  680.  
  681. procedure dm(i:astr; var c:char);
  682.  
  683. procedure cls;
  684.  
  685. procedure wait(b:boolean);
  686.  
  687. procedure chsl;
  688.  
  689. procedure swac(var u:userrec;r:restrictions);
  690.  
  691. procedure acch(c:char; var u:userrec);
  692.  
  693. procedure chac(var thisuser:userrec);
  694.  
  695. procedure chbac;
  696.  
  697. procedure chdsl;
  698.  
  699. procedure tfile;
  700.  
  701. procedure inli1(var i:astr);
  702.  
  703. procedure chat;
  704.  
  705. function yn:boolean;
  706.  
  707. procedure input1(var i:astr; ml:integer; tf:boolean);
  708.  
  709. procedure input(var i:astr; ml:integer);
  710.  
  711. procedure inputl(var i:astr; ml:integer);
  712.  
  713. procedure onek(var c:char; ch:astr);
  714.  
  715. procedure onek2(var c:char; ch:astr); {Added because I use a Modified}
  716.                                       {Message Editor}
  717. procedure centre(var i:astr);
  718.  
  719. procedure wkey(var abort,next:boolean);
  720.  
  721. procedure printa1(i:astr; var abort,next:boolean);
  722.  
  723. procedure printa(i:astr; var abort,next:boolean);
  724.  
  725. procedure printacr(i:astr; var abort,next:boolean);
  726.  
  727. function ctim(rl:real):astr;
  728.  
  729. function tlef:astr;
  730.  
  731. function cstrr(rl:real; base:integer):astr;
  732.  
  733. procedure savesystat;
  734.  
  735. procedure pfl(fn:astr; var abort:boolean; cr:boolean);
  736.  
  737. procedure printfile(fn:astr);
  738.  
  739. Procedure Print_File (fn:astr);  {Another Addiitional Mod}
  740.  
  741. procedure Async_Init;
  742. { initialize variables }
  743.  
  744. procedure Async_Close;
  745. { reset the interrupt system when UART interrupts no longer needed }
  746.  
  747. function Async_Open(ComPort       : Integer;
  748.                     BaudRate      : Integer;
  749.                     Parity        : Char;
  750.                     WordSize      : Integer;
  751.                     StopBits      : Integer) : Boolean;
  752. { open a communications port }
  753.  
  754. {----------------------------------------------------------------------------}
  755.  
  756. IMPLEMENTATION
  757.  
  758.  
  759. const
  760.   UART_THR = $00;    { offset from base of UART Registers for IBM PC }
  761.   UART_RBR = $00;
  762.   UART_IER = $01;
  763.   UART_IIR = $02;
  764.   UART_LCR = $03;
  765.   UART_MCR = $04;
  766.   UART_LSR = $05;
  767.   UART_MSR = $06;
  768.  
  769.   I8088_IMR = $21;   { port address of the Interrupt Mask Register }
  770.  
  771.  
  772. var
  773.  
  774.   Async_BIOS_Port_Table : Array[1..2] of Integer absolute $40:0;
  775.                { This table is initialized by BIOS equipment determination
  776.                  code at boot time to contain the base addresses for the
  777.                  installed async adapters.  A value of 0 means "not in-
  778.                  stalled." }
  779.  
  780. const
  781.   Async_Num_Bauds = 8;
  782.   Async_Baud_Table : array [1..Async_Num_Bauds] of record
  783.                                                      Baud, Bits : integer
  784.                                                    end
  785.                    = ((Baud:110;  Bits:$00),
  786.                       (Baud:150;  Bits:$20),
  787.                       (Baud:300;  Bits:$40),
  788.                       (Baud:600;  Bits:$60),
  789.                       (Baud:1200; Bits:$80),
  790.                       (Baud:2400; Bits:$A0),
  791.                       (Baud:4800; Bits:$C0),
  792.                       (Baud:9600; Bits:$E0));
  793.  
  794.  
  795. PROCEDURE DisableInterrupts; inline($FA {cli} );     {MACROS}
  796. PROCEDURE EnableInterrupts;  inline($FB {sti} );
  797.  
  798.  
  799. procedure BIOS_RS232_Init(ComPort, ComParm : Integer);
  800. { Issue Interrupt $14 to initialize the UART }
  801. { See the IBM PC Technical Reference Manual for the format of ComParm }
  802. var
  803.   Regs : registers;
  804. begin
  805.   with Regs do
  806.     begin
  807.       ax := ComParm and $00FF;  { AH=0; AL=ComParm }
  808.       dx := ComPort;
  809.       Intr($14, Regs)
  810.     end
  811. end; { BIOS_RS232_Init }
  812.  
  813.  
  814. {----------------------------------------------------------------------}
  815. {                                                                      }
  816. {  ISR - Interrupt Service Routine                                     }
  817. {                                                                      }
  818. {----------------------------------------------------------------------}
  819.  
  820. procedure Async_Isr;  INTERRUPT;
  821. { Interrupt Service Routine }
  822. { Invoked when the UART has received a byte of data from the
  823.   communication line }
  824.  
  825. { re-written 9/10/84 to be entirely in machine language; original source
  826.   left as comments }
  827.  
  828. begin
  829.  
  830.   Inline(
  831.     $FB/                           { STI }
  832.       { get the incomming character }
  833.       { buffer[Buffer_head] := Chr(Port[UART_RBR + base]); }
  834.     $8B/$16/base/                  { MOV DX,base }
  835.     $EC/                           { IN AL,DX }
  836.     $8B/$1E/Buffer_head/           { MOV BX,Buffer_head }
  837.     $88/$87/buffer/                { MOV buffer[BX],AL }
  838.       { Async_Buffer_NewHead := Buffer_head + 1; }
  839.     $43/                           { INC BX }
  840.       { if Async_Buffer_NewHead > buffer_max then
  841.           Async_Buffer_NewHead := 0; }
  842.     $81/$FB/buffer_max/            { CMP BX,buffer_max }
  843.     $7E/$02/                       { JLE L001 }
  844.     $33/$DB/                       { XOR BX,BX }
  845.       { if Async_Buffer_NewHead = Buffer_tail then
  846.           Async_Buffer_Overflow := TRUE
  847.         else }
  848. {L001:}
  849.     $3B/$1E/Buffer_tail/     { CMP BX,Buffer_tail }
  850.     $75/$08/                       { JNE L002 }
  851.     $C6/$06/Async_Buffer_Overflow/$01/ { MOV Async_Buffer_Overflow,1 }
  852.     $90/                           { NOP generated by assembler for some reason }
  853.     $EB/$16/                       { JMP SHORT L003 }
  854.       { begin
  855.           Buffer_head := Async_Buffer_NewHead;
  856.           Async_Buffer_Used := Async_Buffer_Used + 1;
  857.           if Async_Buffer_Used > Async_MaxBufferUsed then
  858.             Async_MaxBufferUsed := Async_Buffer_Used
  859.         end; }
  860. {L002:}
  861.     $89/$1E/Buffer_head/           { MOV Buffer_head,BX }
  862.     $FF/$06/Async_Buffer_Used/     { INC Async_Buffer_Used }
  863.     $8B/$1E/Async_Buffer_Used/     { MOV BX,Async_Buffer_Used }
  864.     $3B/$1E/Async_MaxBufferUsed/   { CMP BX,Async_MaxBufferUsed }
  865.     $7E/$04/                       { JLE L003 }
  866.     $89/$1E/Async_MaxBufferUsed/   { MOV Async_MaxBufferUsed,BX }
  867. {L003:}
  868.       { disable interrupts }
  869.     $FA/                           { CLI }
  870.       { Port[$20] := $20; }        { use non-specific EOI }
  871.     $B0/$20/                       { MOV AL,20h }
  872.     $E6/$20                        { OUT 20h,AL }
  873.        )
  874. end; { Async_Isr }
  875.  
  876. procedure Async_Init;
  877. { initialize variables }
  878. begin
  879.   Async_Open_Flag := FALSE;
  880.   Async_Buffer_Overflow := FALSE;
  881.   Async_Buffer_Used := 0;
  882.   Async_MaxBufferUsed := 0;
  883. end; { Async_Init }
  884.  
  885. procedure Async_Close;
  886. { reset the interrupt system when UART interrupts no longer needed }
  887. var
  888.   i, m : Integer;
  889. begin
  890.   if Async_Open_Flag then
  891.     begin
  892.  
  893.       { disable the IRQ on the 8259 }
  894.       DisableInterrupts;
  895.       i := Port[I8088_IMR];        { get the interrupt mask register }
  896.       m := 1 shl Async_Irq;        { set mask to turn off interrupt }
  897.       Port[I8088_IMR] := i or m;
  898.  
  899.       { disable the 8250 data ready interrupt }
  900.       Port[UART_IER + base] := 0;
  901.  
  902.       { disable OUT2 on the 8250 }
  903.       Port[UART_MCR + base] := 0;
  904.       EnableInterrupts;
  905.  
  906.       SetIntVec(Async_Irq + 8,Async_OriginalVector);
  907.  
  908.       { re-initialize our data areas so we know the port is closed }
  909.       Async_Open_Flag := FALSE
  910.  
  911.     end
  912. end; { Async_Close }
  913.  
  914. function Async_Open(ComPort       : Integer;
  915.                     BaudRate      : Integer;
  916.                     Parity        : Char;
  917.                     WordSize      : Integer;
  918.                     StopBits      : Integer) : Boolean;
  919. { open a communications port }
  920. var
  921.   ComParm : Integer;
  922.   i, m : Integer;
  923. begin
  924.   if Async_Open_Flag then Async_Close;
  925.  
  926.   if (ComPort = 2) and (Async_BIOS_Port_Table[2] <> 0) then
  927.     Async_Port := 2
  928.   else
  929.     Async_Port := 1;  { default to COM1 }
  930.   base := Async_BIOS_Port_Table[Async_Port];
  931.   Async_Irq := Hi(base) + 1;
  932.  
  933.   if (Port[UART_IIR + base] and $00F8) <> 0 then
  934.     Async_Open := FALSE
  935.   else
  936.     begin
  937.       Buffer_head := 0;
  938.       Buffer_tail := 0;
  939.       Async_Buffer_Overflow := FALSE;
  940.  
  941.   { Build the ComParm for RS232_Init }
  942.   { See Technical Reference Manual for description }
  943.  
  944.       ComParm := $0000;
  945.  
  946.   { Set up the bits for the baud rate }
  947.       i := 0;
  948.       repeat
  949.         i := i + 1
  950.       until (Async_Baud_Table[i].Baud = BaudRate) or (i = Async_Num_Bauds);
  951.       ComParm := ComParm or Async_Baud_Table[i].Bits;
  952.  
  953.       if Parity in ['E', 'e'] then ComParm := ComParm or $0018
  954.       else if Parity in ['O', 'o'] then ComParm := ComParm or $0008
  955.       else ComParm := ComParm or $0000;  { default to No parity }
  956.  
  957.       if WordSize = 7 then ComParm := ComParm or $0002
  958.       else ComParm := ComParm or $0003;  { default to 8 data bits }
  959.  
  960.       if StopBits = 2 then ComParm := ComParm or $0004
  961.       else ComParm := ComParm or $0000;  { default to 1 stop bit }
  962.  
  963.   { use the BIOS COM port initialization routine to save typing the code }
  964.       BIOS_RS232_Init(Async_Port - 1, ComParm);
  965.  
  966.       GetIntVec(Async_Irq + 8, Async_OriginalVector);
  967.       SetIntVec(Async_Irq + 8, @Async_Isr);
  968.  
  969.   { read the RBR and reset any possible pending error conditions }
  970.   { first turn off the Divisor Access Latch Bit to allow access to RBR, etc. }
  971.  
  972.       DisableInterrupts;
  973.  
  974.       Port[UART_LCR + base] := Port[UART_LCR + base] and $7F;
  975.   { read the Line Status Register to reset any errors it indicates }
  976.       i := Port[UART_LSR + base];
  977.   { read the Receiver Buffer Register in case it contains a character }
  978.       i := Port[UART_RBR + base];
  979.  
  980.   { enable the irq on the 8259 controller }
  981.       i := Port[I8088_IMR];  { get the interrupt mask register }
  982.       m := (1 shl Async_Irq) xor $00FF;
  983.       Port[I8088_IMR] := i and m;
  984.  
  985.   { enable the data ready interrupt on the 8250 }
  986.       Port[UART_IER + base] := $01; { enable data ready interrupt }
  987.  
  988.   { enable OUT2 on 8250 }
  989.       i := Port[UART_MCR + base];
  990.       Port[UART_MCR + base] := i or $08;
  991.  
  992.       EnableInterrupts;
  993.       Async_Open_Flag := TRUE;  { bug fix by Scott Herr }
  994.       Async_Open := TRUE
  995.     end
  996. end; { Async_Open }
  997.  
  998. {End of Async Routines}
  999.  
  1000.  
  1001. function freek(d:integer):integer;
  1002.  
  1003. var r:registers;
  1004. begin
  1005.   r.ax:=$3600;
  1006.   r.dx:=d;
  1007.   msdos(r);
  1008.   freek:=trunc(1.0*r.bx*r.ax*r.cx/1024.0);
  1009. end;
  1010.  
  1011.  
  1012. function cs:boolean;
  1013.  
  1014. begin
  1015.   cs:=cosysop in seclev[thisuser.sl].anst;
  1016. end;
  1017.  
  1018.  
  1019. function so:boolean;
  1020.  
  1021. begin
  1022.   so:=thisuser.sl=255;
  1023. end;
  1024.  
  1025.  
  1026. function lcs:boolean;
  1027.  
  1028. begin
  1029.   lcs:=cs or ((lcosysop in seclev[thisuser.sl].anst) and ((board=thisuser.sbn) or (thisuser.sbn=0)));
  1030. end;
  1031.  
  1032.  
  1033. function nma:integer;
  1034.  
  1035. begin
  1036.   nma:=seclev[thisuser.sl].ttime;
  1037. end;
  1038.  
  1039.  
  1040. function okansi:boolean;
  1041.  
  1042. begin
  1043.   okansi:=ansi in thisuser.defaults;
  1044. end;
  1045.  
  1046.  
  1047. function commpressed : boolean;
  1048.  
  1049. begin
  1050.  commpressed := (buffer_tail<>buffer_head);
  1051. end;
  1052.  
  1053.  
  1054. procedure dump;
  1055.  
  1056. Begin
  1057.   disableinterrupts;  {Replaces the old inline $FA}
  1058.   buffer_head:=0;
  1059.   buffer_tail:=buffer_head;
  1060.   enableinterrupts;   {Replaces the old inline $FB}
  1061. end;
  1062.  
  1063.  
  1064. procedure remove_port;
  1065. {This routes all WWIV 3 calls to the new Close Port routine}
  1066.  
  1067. Begin
  1068. Async_Close;
  1069. end;
  1070.  
  1071.  
  1072. procedure term_ready(s:Boolean);
  1073.  
  1074. var x:byte;
  1075. begin
  1076.   x := port[4+base] and $FE;
  1077.   if s then x:=x+1;
  1078.   port[4+base] := x;
  1079. end;
  1080.  
  1081.  
  1082. procedure set_baud(r:integer);
  1083.  
  1084. var rl:real; a:byte;
  1085. begin
  1086.  
  1087.   if (r>=300) and (r<=9600) then begin
  1088.     rl:=115200.0/r;
  1089.     r:=trunc(rl);
  1090.     a:=port[3+base] or 128;
  1091.     port[base+3]:=a;
  1092.     port[base]:=lo(r);
  1093.     port[1+base]:=hi(r);
  1094.     port[3+base]:=a and 127;
  1095.   end;
  1096. end;
  1097.  
  1098.  
  1099. procedure iport;
  1100. {This routes all WWIV 3 calls to the new Intialize Port routine}
  1101.  
  1102. Begin
  1103. Async_init;
  1104. Write(Async_open(1,2400,'N',8,1));
  1105. end;
  1106.  
  1107.  
  1108. function cinkey1:char;
  1109.  
  1110. var t:char;
  1111. begin
  1112.   if buffer_Head = buffer_Tail Then
  1113.     t:=#0
  1114.   else begin
  1115.     disableinterrupts;
  1116.     t:=buffer[buffer_Tail];
  1117.     buffer_Tail:=(buffer_Tail+1) mod (buffer_max+1);
  1118.     enableinterrupts;
  1119.   end;
  1120.   cinkey1:=t;
  1121. end;
  1122.  
  1123.  
  1124. function cinkey:char;
  1125.  
  1126. var t:char;
  1127. begin
  1128.   t:=cinkey1;
  1129.   cinkey:=chr(ord(t) and andwith);
  1130. end;
  1131.  
  1132.  
  1133. procedure o1(c:char);
  1134.  
  1135. begin
  1136.   while (port[base+5] and 32)=0 do;
  1137.   port[base]:=ord(c);
  1138. end;
  1139.  
  1140.  
  1141. procedure o(c:char);
  1142.  
  1143. begin
  1144.   if outcom and (c<>#1) then
  1145.     o1(c);
  1146. end;
  1147.  
  1148.  
  1149. function timer:real;
  1150.  
  1151. var reg:registers;
  1152.     h,m,s,t:real;
  1153. begin
  1154.   reg.ax:=44*256;
  1155.   msdos(Dos.Registers(reg));
  1156.   h:=(reg.cx div 256);
  1157.   m:=(reg.cx mod 256);
  1158.   s:=(reg.dx div 256);
  1159.   t:=(reg.dx mod 256);
  1160.   timer:=h*3600+m*60+s+t/100;
  1161. end;
  1162.  
  1163.  
  1164. function nsl:real;
  1165.  
  1166. begin
  1167.   nsl:=(nma*60.0+extratime+chattime+timeon-timer);
  1168. end;
  1169.  
  1170.  
  1171. function sysop1:boolean;
  1172.  
  1173. begin
  1174.   if (mem[0:1047] and 16)=0 then sysop1:=false else sysop1:=true;
  1175. end;
  1176.  
  1177.  
  1178. function sysop:boolean;
  1179.  
  1180. begin
  1181.   sysop:=sysop1;
  1182.   if rchat in thisuser.ac then sysop:=false;
  1183.   if systat.lowtime<>systat.hitime then begin
  1184.     if systat.hitime>systat.lowtime then begin
  1185.       if (timer<=(systat.lowtime*60.0)) or (timer>=(systat.hitime*60.0))
  1186.         then sysop:=false;
  1187.     end else begin
  1188.       if (timer<=(systat.lowtime*60.0)) and (timer>=(systat.hitime*60.0))
  1189.         then sysop:=false;
  1190.     end;
  1191.   end;
  1192. end;
  1193.  
  1194.  
  1195. procedure sl1(i:astr);
  1196.  
  1197. begin
  1198.   writeln(sysopf,i);
  1199. end;
  1200.  
  1201.  
  1202. procedure sysoplog(i:astr);
  1203.  
  1204. begin
  1205.   if (realsl<>255) or incom then
  1206.     sl1('   '+i);
  1207. end;
  1208.  
  1209.  
  1210. function tch(i:astr):astr;
  1211.  
  1212. begin
  1213.   if length(i)>2 then i:=copy(i,length(i)-1,2) else
  1214.     if length(i)=1 then i:='0'+i;
  1215.   tch:=i;
  1216. end;
  1217.  
  1218.  
  1219. function time:astr;
  1220.  
  1221. var reg:registers;
  1222.     h,m,s:string[4];
  1223. begin
  1224.   reg.ax:=$2c00; intr($21,Dos.Registers(reg));
  1225.   str(reg.cx shr 8,h); str(reg.cx mod 256,m); str(reg.dx shr 8,s);
  1226.   time:=tch(h)+':'+tch(m)+':'+tch(s);
  1227. end;
  1228.  
  1229.  
  1230. function date:astr;
  1231.  
  1232. var reg:registers;
  1233.     m,d,y:string[4];
  1234. begin
  1235.   reg.ax:=$2a00; msdos(Dos.Registers(reg)); str(reg.cx,y); str(reg.dx mod 256,d);
  1236.   str(reg.dx shr 8,m);
  1237.   date:=tch(m)+'/'+tch(d)+'/'+tch(y);
  1238. end;
  1239.  
  1240.  
  1241. function value(I:astr):integer;
  1242.  
  1243. var n,n1:integer;
  1244. begin
  1245.   val(i,n,n1);
  1246.   if n1<>0 then begin
  1247.     i:=copy(i,1,n1-1);
  1248.     val(i,n,n1)
  1249.   end;
  1250.   value:=n;
  1251.   if i='' then value:=0;
  1252. end;
  1253.  
  1254.  
  1255. function cstr(i:integer):astr;
  1256.  
  1257. var c:astr;
  1258. begin
  1259.   str(i,c); cstr:=c;
  1260. end;
  1261.  
  1262.  
  1263. function nam:astr;
  1264.  
  1265. var s:astr; i:integer; tf:boolean;
  1266. begin
  1267.   s:=thisuser.name;
  1268.   tf:=true;
  1269.   for i:=1 to length(s) do
  1270.     if s[i]<'A' then
  1271.       tf:=true
  1272.     else begin
  1273.       if (s[i]<='Z') and not tf then
  1274.         s[i]:=chr(ord(s[i])+32);
  1275.       tf:=false;
  1276.     end;
  1277.   nam:=s+' #'+cstr(usernum);
  1278. end;
  1279.  
  1280.  
  1281. function leapyear(yr:integer):boolean;
  1282.  
  1283. begin
  1284.   leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
  1285. end;
  1286.  
  1287.  
  1288. function days(mo,yr:integer):integer;
  1289.  
  1290. var d:integer;
  1291. begin
  1292.   d:=value(copy('312831303130313130313031',1+(mo-1)*2,2));
  1293.   if (mo=2) and leapyear(yr) then d:=d+1;
  1294.   days:=d;
  1295. end;
  1296.  
  1297.  
  1298. function daycount(mo,yr:integer):integer;
  1299.  
  1300. var m,t:integer;
  1301. begin
  1302.   t:=0;
  1303.   for m:=1 to (mo-1) do t:=t+days(m,yr);
  1304.   daycount:=t;
  1305. end;
  1306.  
  1307.  
  1308. function daynum(dt:astr):integer;
  1309.  
  1310. var d,m,y,t,c:integer;
  1311. begin
  1312.   t:=0;
  1313.   m:=value(copy(dt,1,2));
  1314.   d:=value(copy(dt,4,2));
  1315.   y:=value(copy(dt,7,2))+1900;
  1316.   for c:=1985 to y-1 do
  1317.     if leapyear(c) then t:=t+366 else t:=t+365;
  1318.   t:=t+daycount(m,y)+(d-1);
  1319.   daynum:=t;
  1320.   if y<1985 then daynum:=0;
  1321. end;
  1322.  
  1323.  
  1324. function dat:astr;
  1325.  
  1326. var ap,x,y:astr; i:integer;
  1327. begin
  1328.   case daynum(date) mod 7 of
  1329.     0:x:='Tue';
  1330.     1:x:='Wed';
  1331.     2:x:='Thu';
  1332.     3:x:='Fri';
  1333.     4:x:='Sat';
  1334.     5:x:='Sun';
  1335.     6:x:='Mon';
  1336.   end;
  1337.   case value(copy(date,1,2)) of
  1338.     1:y:='Jan';
  1339.     2:y:='Feb';
  1340.     3:y:='Mar';
  1341.     4:y:='Apr';
  1342.     5:y:='May';
  1343.     6:y:='Jun';
  1344.     7:y:='Jul';
  1345.     8:y:='Aug';
  1346.     9:y:='Sep';
  1347.     10:y:='Oct';
  1348.     11:y:='Nov';
  1349.     12:y:='Dec';
  1350.   end;
  1351.   x:=x+' '+y+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
  1352.   y:=time; i:=value(copy(y,1,2));
  1353.   if i>11 then ap:='pm' else ap:='am';
  1354.   if i>12 then i:=i-12;
  1355.   if i=0 then i:=12;
  1356.   dat:=cstr(i)+copy(y,3,3)+' '+ap+'  '+x;
  1357. end;
  1358.  
  1359.  
  1360. function cdet:boolean;
  1361.  
  1362. begin
  1363.   cdet:=(port[base+6] and 128)<>0;
  1364. end;
  1365.  
  1366.  
  1367. procedure checkhangup;
  1368.  
  1369. begin
  1370.   if outcom and not cdet and (not hangup) then begin
  1371.     hangup:=true; hungup:=true;
  1372.   end;
  1373. end;
  1374.  
  1375.  
  1376. procedure ptime;
  1377. var i:astr;
  1378. begin
  1379.   if useron then begin
  1380.     i:=thisline;
  1381.     nl; nl; print(dat);
  1382.     print('Time left: '+tlef);
  1383.     print('Time on  : '+ctim(timer-timeon));
  1384.     nl; prompt(i);
  1385.   end;
  1386. end;
  1387.  
  1388. procedure skey(var c:char);
  1389. begin
  1390.   case ord(c) of
  1391.       6:if macok and (buf='') then dm(thisuser.macro[2],c);
  1392.       4:if macok and (buf='') then dm(thisuser.macro[1],c);
  1393.      20:ptime;
  1394.     127:c:=#8;
  1395.    end;
  1396. end;
  1397.  
  1398. procedure getkey(var c:char);
  1399.  
  1400. var t:real; b,tf,t1:boolean;
  1401. begin
  1402.   lil:=0;
  1403.   if buf<>'' then begin
  1404.     c:=buf[1]; buf:=copy(buf,2,length(buf)-1);
  1405.   end else
  1406.     if not empty then c:=inkey
  1407.     else begin
  1408.       t:=timer; t1:=false; tf:=false;
  1409.       c:=#0;
  1410.       while (c=#0) and not hangup do begin
  1411.         c:=inkey;
  1412.         if ((timer-t)>180) and (c=#0) then begin nl;
  1413.           print('Call back later when you are there.');hangup:=true;
  1414.           sysoplog('!-! Timeout !-!');
  1415.         end;
  1416.         if ((timer-t)>90) and (not tf) and (c=#0) then begin tf:=true; outkey(chr(7)); end;
  1417.         checkhangup;
  1418.       end;
  1419.     end;
  1420.     if checkit then
  1421.       if (ord(c) and 128)>0 then begin
  1422.         checkit:=false;
  1423.         andwith:=127;
  1424.         c:=chr(ord(c) and andwith);
  1425.       end;
  1426.   skey(c);
  1427. end;
  1428.  
  1429.  
  1430. procedure pr1(i:astr);
  1431.  
  1432. var c:integer;
  1433. begin
  1434.   for c:=1 to length(i) do o1(i[c]);
  1435. end;
  1436.  
  1437.  
  1438. procedure pr(i:astr);
  1439.  
  1440. begin
  1441.   pr1(i+#13);
  1442. end;
  1443.  
  1444.  
  1445. procedure sdc;
  1446.  
  1447. var f:integer;
  1448. begin
  1449.   f:=curco and 7;
  1450.   if (curco and 8)<>0 then f:=f+8;
  1451.   if (curco and 128)<>0 then f:=f+16;
  1452.   textcolor(f);
  1453.   textbackground((curco shr 4) and 7);
  1454. end;
  1455.  
  1456.  
  1457. procedure stsc;
  1458.  
  1459. begin
  1460.   textcolor(14); textbackground(0);
  1461. end;
  1462.  
  1463.  
  1464. function xclr(c:integer):astr;
  1465.  
  1466. begin
  1467.   case c of
  1468.     0:xclr:='0';
  1469.     1:xclr:='4';
  1470.     2:xclr:='2';
  1471.     3:xclr:='6';
  1472.     4:xclr:='1';
  1473.     5:xclr:='5';
  1474.     6:xclr:='3';
  1475.     7:xclr:='7';
  1476.   end;
  1477. end;
  1478.  
  1479.  
  1480. procedure setc(cl:byte);
  1481.  
  1482. var i:astr;
  1483.   procedure adto(ii:astr);
  1484.   begin
  1485.     if (i[length(i)]<>';') and (i[length(i)]<>'[') then i:=i+';';
  1486.     i:=i+ii;
  1487.   end;
  1488. begin
  1489.   if cl<>curco then begin
  1490.     if ((curco and (not cl)) and $88)<>0 then begin
  1491.       i:=#27+'[0';
  1492.       curco:=$07;
  1493.     end else i:=#27+'[';
  1494.     if (cl and 7)<>(curco and 7) then adto('3'+xclr(cl and 7));
  1495.     if (cl and $70)<>(curco and $70) then adto('4'+xclr((cl shr 4) and 7));
  1496.     if (cl and 128)<>0 then adto('5');
  1497.     if (cl and 8)<>0 then adto('1');
  1498.     i:=i+'m';
  1499.     curco:=cl;
  1500.     if okansi and outcom then pr1(i);
  1501.     sdc;
  1502.   end;
  1503. end;
  1504.  
  1505.  
  1506. procedure ansic(c:integer);
  1507.  
  1508. begin
  1509.   if c=0 then c:=1;
  1510.   if okansi then
  1511.     if color in thisuser.defaults then
  1512.       setc(thisuser.cols[true,c])
  1513.     else
  1514.       setc(thisuser.cols[false,c]);
  1515. end;
  1516.  
  1517.  
  1518. procedure prompt(i:astr);
  1519.  
  1520. var c:integer; cc:char;
  1521. begin
  1522.  checkhangup;
  1523.  if not hangup then begin
  1524.   for c:=1 to length(i) do begin
  1525.     if i[c]=#10 then
  1526.       if okansi then
  1527.         if (curco<>thisuser.cols[color in thisuser.defaults,1]) then
  1528.           ansic(0);
  1529.     if (not ((i[c]=chr(7)) and (incom))) and (i[c]<>chr(12)) and (i<>#1) then write(i[c]);
  1530.     o(i[c]);
  1531.     if i[c]>#31 then thisline:=thisline+i[c];
  1532.     if i[c]=#8 then if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
  1533.     if i[c]=chr(12) then begin lil:=0; clrscr; end;
  1534.     if i[c]=chr(13) then begin pap:=0; thisline:=''; end;
  1535.     if i[c]=chr(10) then begin
  1536.       lil:=lil+1;
  1537.       if (lil>=thisuser.pagelen-1) then begin
  1538.         lil:=0;
  1539.         if pause in thisuser.defaults then pausescr;
  1540.       end;
  1541.     end;
  1542.   end;
  1543.  end;
  1544. end;
  1545.  
  1546. procedure pausescr;
  1547.  
  1548. var i:integer; cc:char;
  1549. begin
  1550.   ansic(5); prompt('(-More-)'); ansic(0);
  1551.   getkey(cc);
  1552.   for i:=1 to 8 do
  1553.     prompt(#8+' '+#8);
  1554. end;
  1555.  
  1556. procedure print(i:astr);
  1557.  
  1558. begin
  1559.   prompt(i+chr(13)+chr(10))
  1560. end;
  1561.  
  1562.  
  1563. procedure nl;
  1564.  
  1565. begin
  1566.   prompt(chr(13)+chr(10))
  1567. end;
  1568.  
  1569.  
  1570. procedure prt(i:astr);
  1571.  
  1572. begin
  1573.   ansic(4); prompt(i); ansic(0);
  1574. end;
  1575.  
  1576.  
  1577. procedure ynq(i:astr);
  1578.  
  1579. begin
  1580.   ansic(7); prompt(i);
  1581. end;
  1582.  
  1583.  
  1584. procedure mpl(c:integer);
  1585.  
  1586. var n:integer; i:astr;
  1587. begin
  1588.  if okansi then begin
  1589.   ansic(6);
  1590.   i:='';
  1591.   for n:=1 to c do i:=i+' ';
  1592.   n:=wherex;
  1593.   prompt(i);
  1594.   gotoxy(n,wherey);
  1595.   if outcom then
  1596.     pr1(#27+'['+cstr(c)+'D');
  1597.  end;
  1598.  thisline:=copy(thisline,1,length(thisline)-c);
  1599. end;
  1600.  
  1601.  
  1602. procedure tleft;
  1603.  
  1604. var x,y:integer;
  1605. begin
  1606.  if okt then begin
  1607.   stsc;
  1608.   x:=wherex; y:=wherey; window(1,1,80,4);
  1609.   gotoxy(72,3);if chatcall then begin
  1610.     write('CHAT ON');
  1611.     if alert in thisuser.option then begin
  1612.       gotoxy(72,3);
  1613.       write('ALERT  ');
  1614.     end;
  1615.   end else write('       ');
  1616.   gotoxy(56,3); if sysop1 then write('Sysop Available') else
  1617.     write('----- ---------');
  1618.   if useron then begin
  1619.     gotoxy(35,3); if thisuser.ontoday<>1 then write('ML=',extramsgs+seclev[thisuser.sl].mallowed-mread,'   ');
  1620.     gotoxy(45,3); write('TL=',(nsl/60):7:2,' ');
  1621.   end;
  1622.   if hangup then begin
  1623.     gotoxy(72,3);
  1624.     write('HANG UP');
  1625.   end;
  1626.   gotoxy(74,1);
  1627.   if beepend then write('(-*-)') else write('     ');
  1628.   window(1,5,80,25);gotoxy(x,y);
  1629.   if timer<timeon then timeon:=timeon-24.0*60*60;
  1630.   if not ch and (nsl<0) and useron then
  1631.   begin nl; print('Time expired.'); hangup:=true; end;
  1632.   checkhangup;
  1633.   sdc;
  1634.  end;
  1635. end;
  1636.  
  1637.  
  1638. procedure prestrict(u:userrec);
  1639.  
  1640. var r:restrictions;
  1641. begin
  1642.   for r:=rlogon to rmsg do
  1643.     if r in u.ac then write(copy('LCVBA*PEKM',ORD(R)+1,1)) else write(' ');
  1644.   writeln;
  1645. end;
  1646.  
  1647.  
  1648. procedure ff(i:integer);
  1649.  
  1650. begin
  1651.   while wherex<i do write(' ');
  1652. end;
  1653.  
  1654.  
  1655. procedure topscr;
  1656.  
  1657. var c:char; x,y,i:integer;
  1658. begin
  1659.  if (usernum<>0) and okt then begin
  1660.   stsc;
  1661.   x:=wherex; y:=wherey;
  1662.   window(1,1,80,5);
  1663.   for i:=1 to 4 do
  1664.    begin
  1665.     gotoxy(1,i);
  1666.     clreol;
  1667.    End;
  1668.   gotoxy(1,1);
  1669.   write(chr(186),' ',nam); ff(35);
  1670.   with thisuser do begin
  1671.     write(realname);ff(50);write(ph);ff(65);
  1672.     if laston<>date then write(laston) else write(ontoday,'       ');
  1673.     ff(79); write(' ',chr(186));gotoxy(1,2);
  1674.     write(chr(186),' SL=',sl);ff(10);write('AR=');
  1675.     for c:='A' to 'G' do if c in ar then write(c) else write(' ');
  1676.     write(' LO=',loggedon);
  1677.     ff(28);write('P=',msgpost);ff(35);write('E=',emailsent);
  1678.     ff(42);write('F=',feedback);ff(48);
  1679.     write('W=',waiting);ff(53);
  1680.     if not useron then write('"',pw,'"') else write('SC=',thisuser.linelen,'X',
  1681.       thisuser.pagelen,' ',thisuser.sex,' ',thisuser.age);
  1682.     ff(68);write('FW=',fw); ff(74); write('D=',thisuser.dsl);
  1683.     gotoxy(80,2);write(#186);
  1684.     gotoxy(1,3);write(#186,' AC='); prestrict(thisuser);
  1685.     gotoxy(17,3);write('C=',comptyp[thisuser.comptype]);
  1686.     gotoxy(80,3);write(chr(186));
  1687.     gotoxy(1,4);write(chr(200));
  1688.     for i:=2 to 79 do
  1689.       write(chr(205));
  1690.     write(chr(188));
  1691.   end;
  1692.   window(1,5,80,25);
  1693.   gotoxy(x,y);
  1694.   tleft;
  1695.   sdc;
  1696.  end;
  1697. end;
  1698.  
  1699.  
  1700. function empty:boolean;
  1701.  
  1702. begin
  1703.   if incom then empty:=not commpressed else empty:=true;
  1704.   if keypressed then empty:=false;
  1705.   if hangup then begin dump; empty:=true; end;
  1706. end;
  1707.  
  1708. procedure skey1(var c:char);
  1709.  
  1710. var b:boolean;
  1711. begin
  1712.   case ord(c) of
  1713.     59:chsl;
  1714.     60:chac(thisuser);
  1715.     61:begin
  1716.          if outcom then incom:=not incom;
  1717.          writeln; if incom then writeln('<INPUT ENABLED>')
  1718.            else writeln('<COM DISABLED>');
  1719.          writeln;dump;
  1720.          write(thisline);
  1721.        end;
  1722.     62:begin chatcall:=false; thisuser.option:=thisuser.option-[alert]; end;
  1723.     63:hangup:=true;
  1724.     64:tleft;
  1725.     65:begin b:=ch; ch:=true; extratime:=extratime-5*60; tleft; ch:=b;end;
  1726.     66:begin b:=ch; ch:=true; extratime:=extratime+5*60; tleft; ch:=b;end;
  1727.     67:begin
  1728.           if thisuser.sl=255 then if realsl<>255 then begin
  1729.             thisuser.sl:=realsl; writeln;writeln;writeln('<SECLEV RESTORED>');
  1730.             writeln; write(thisline); end
  1731.           else else begin
  1732.             thisuser.sl:=255; writeln;writeln;writeln('<TEMP SYSOP GRANTED>');
  1733.             writeln; write(thisline);
  1734.           end; topscr;
  1735.         end;
  1736.     68:if ch then
  1737.          ch:=false
  1738.        else begin
  1739.          chat;
  1740.        end;
  1741.     71:if ch then tfile;
  1742.     84:chdsl;
  1743.     85:chbac;
  1744.     90:begin b:=ch; ch:=true; extramsgs:=extramsgs-10; tleft; ch:=b;  end;
  1745.     91:begin b:=ch; ch:=true; extramsgs:=extramsgs+10; tleft; ch:=b;  end;
  1746.     93:begin beepend:=not beepend; b:=ch; ch:=true; tleft; ch:=b; end;
  1747.   end;
  1748. end;
  1749.  
  1750.  
  1751. function inkey:char;
  1752.  
  1753. var c:char;
  1754. begin
  1755.   c:=chr(0); inkey:=chr(0);
  1756.   if keypressed then begin
  1757.     read(kbd,c); if c=chr(27) then
  1758.       if keypressed then begin
  1759.         read(kbd,c);
  1760.         skey1(c);
  1761.         if c=#68 then
  1762.           c:=#1
  1763.         else
  1764.           c:=#0;
  1765.       end;
  1766.     inkey:=c;
  1767.   end else begin
  1768.     if commpressed and incom then begin
  1769.       inkey:=cinkey;
  1770.     end;
  1771.   end;
  1772. end;
  1773.  
  1774.  
  1775. procedure oc(c:char);
  1776.  
  1777. begin
  1778.   if c<>#0 then write(c);
  1779.   o(c);
  1780. end;
  1781.  
  1782.  
  1783. procedure outkey(c:char);
  1784.  
  1785. begin
  1786.   if (c<>chr(12)) and (not ((c=chr(7)) and (incom))) then if c<>#0 then write(c);
  1787.   if (not echo) and (c>=' ') then c:='X';
  1788.   o(c);
  1789.   if c=chr(12) then begin clrscr; lil:=0; end;
  1790.   if c=#7 then begin o(#0); o(#0); o(#0); o(#0); end;
  1791. end;
  1792.  
  1793.  
  1794. procedure dm(i:astr; var c:char);
  1795.  
  1796. begin
  1797.   buf:=i;
  1798.   if buf<>'' then begin
  1799.     c:=buf[1];
  1800.     buf:=copy(buf,2,length(buf)-1);
  1801.   end;
  1802. end;
  1803.  
  1804.  
  1805. procedure cls;
  1806.  
  1807. begin
  1808.   outkey(chr(12));
  1809. end;
  1810.  
  1811.  
  1812. procedure wait(b:boolean);
  1813.  
  1814. var c:integer;
  1815. begin
  1816.   if b then begin
  1817.     prompt('[WAIT]');
  1818.     sll:=thisline;
  1819.     writeln; writeln;
  1820.   end else begin
  1821.     writeln; thisline:=sll; write(sll);
  1822.     sll:=''; for c:=1 to 6 do sll:=sll+chr(8)+' '+chr(8);
  1823.     topscr;
  1824.     prompt(sll);
  1825.   end;
  1826. end;
  1827.  
  1828.  
  1829. procedure chsl;
  1830.  
  1831. var ij,i:astr; c:integer;
  1832. begin
  1833.  wait(true);
  1834.  write('Enter new SL: ');
  1835.  readln(i); if i<>'' then thisuser.sl:=value(i); writeln;
  1836.  if thisuser.sl=99 then begin
  1837.    write('Board #? '); thisuser.sbn:=0;
  1838.    readln(i); thisuser.sbn:=value(i);
  1839.    writeln;
  1840.  end;
  1841.  realsl:=thisuser.sl;
  1842.  wait(false);
  1843. end;
  1844.  
  1845.  
  1846. procedure swac(var u:userrec;r:restrictions);
  1847.  
  1848. begin
  1849.   if r in u.ac then u.ac:=u.ac-[r] else u.ac:=u.ac+[r];
  1850. end;
  1851.  
  1852.  
  1853. procedure acch(c:char; var u:userrec);
  1854.  
  1855. begin
  1856.   case c of
  1857.     'L':swac(u,rlogon);
  1858.     'C':SWAC(u,RCHAT);
  1859.     'V':SWAC(u,RVALIDATE);
  1860.     'B':SWAC(u,RBACKSPACE);
  1861.     'A':SWAC(u,RAMSG);
  1862.     '*':SWAC(u,RPOSTAN);
  1863.     'P':SWAC(u,RPOST);
  1864.     'E':SWAC(u,REMAIL);
  1865.     'K':SWAC(u,RVOTING);
  1866.     'M':swac(u,rmsg);
  1867.   END;
  1868. end;
  1869.  
  1870.  
  1871. procedure chac(var thisuser:userrec);
  1872.  
  1873. var c:char; ij,i:astr; cc:integer;
  1874. begin
  1875.   wait(true);
  1876.   writeln('LCVBA*PEKM');writeln;write('Which? '); read(kbd,c); c:=upcase(c); writeln(c); writeln;
  1877.   acch(c,thisuser);
  1878.   wait(false);
  1879. end;
  1880.  
  1881.  
  1882. procedure chbac;
  1883.  
  1884. var c:char; ij,i:astr; cc:integer;
  1885. begin
  1886.   wait(true);
  1887.   write('Which board? '); read(kbd,c); c:=upcase(c); writeln(c);
  1888.   if c in ['A'..'G'] then
  1889.     if c in thisuser.ar then
  1890.       thisuser.ar:=thisuser.ar-[c]
  1891.     else
  1892.       thisuser.ar:=thisuser.ar+[c];
  1893.   wait(false);
  1894. end;
  1895.  
  1896.  
  1897. procedure chdsl;
  1898.  
  1899. var ij,i:astr; c:integer;
  1900. begin
  1901.  wait(true);
  1902.  writeln('UL=',thisuser.uploads,'-',thisuser.uk,'K   DL=',thisuser.downloads,'-',thisuser.dk,'K');
  1903.  write('Enter new DSL: ');
  1904.  readln(i); if i<>'' then thisuser.dsl:=value(i); writeln;
  1905.  wait(false);
  1906. end;
  1907.  
  1908.  
  1909. procedure tfile;
  1910.  
  1911. var i:astr; ii:integer;
  1912. bf:file of byte; cr:boolean;
  1913. begin
  1914.   if cfo then begin
  1915.     cfo:=false;
  1916.     close(cf);
  1917.     write('<CLOSED>');
  1918.   end else begin
  1919.     assign(cf,'gfiles\chat.msg');
  1920.     assign(bf,'gfiles\chat.msg'); cr:=false;
  1921.     {$I-} reset(bf); {$I+}
  1922.     if ioresult<>0 then cr:=true
  1923.     else begin
  1924.       if filesize(bf)=0 then cr:=true;
  1925.       close(bf);
  1926.     end;
  1927.     if cr then rewrite(cf) else append(cf);
  1928.     cfo:=true;
  1929.     i:=#13+#10+#13+#10+dat+#13+#10+'==============='+#13+#10;
  1930.     writeln(cf,i);
  1931.     write('<OPEN>');
  1932.   end;
  1933. end;
  1934.  
  1935.  
  1936. procedure inli1(var i:astr);
  1937.  
  1938. var cp:integer; c:char; cv,cc:integer;
  1939. begin
  1940.   cp:=1;
  1941.   i:='';
  1942.   if ll<>'' then begin prompt(ll); i:=ll; ll:=''; cp:=length(i)+1;end;
  1943.   repeat
  1944.     getkey(c); checkhangup;
  1945.     case ord(c) of
  1946.       32..255:if (cp<79) then begin
  1947.                 i[cp]:=c; cp:=cp+1; outkey(c);
  1948.               end;
  1949.       8:if cp>1 then begin c:=chr(8);
  1950.                prompt(c+' '+c); cp:=cp-1;
  1951.             end;
  1952.       24:begin
  1953.            for cv:=1 to cp-1 do prompt(chr(8)+' '+chr(8)); cp:=1;
  1954.          end;
  1955.        7:o(#7);
  1956.       23:if cp>1 then repeat
  1957.            prompt(chr(8)+' '+chr(8)); cp:=cp-1;
  1958.          until (cp=1) or (i[cp]=' ');
  1959.        9:begin
  1960.            cv:=5-(cp mod 5); if (cp+cv<79)  then
  1961.              for cc:=1 to cv do begin
  1962.                prompt(' ');
  1963.                i[cp]:=' '; cp:=cp+1;
  1964.              end;
  1965.          end;
  1966.   end;
  1967.   until (c=#13) or (cp=79) or hangup or (not ch);
  1968.   if not ch then begin c:=#13; ch:=false; end;
  1969.   i[0]:=chr(cp-1);
  1970.   if c<>chr(13) then begin
  1971.     cv:=cp-1;
  1972.     while (cv>0) and (i[cv]<>' ') and (i[cv]<>chr(8))do cv:=cv-1;
  1973.     if (cv>(cp div 2)) and (cv<>cp-1) then begin
  1974.       ll:=copy(i,cv+1,cp-cv); for cc:=cp-2 downto cv do prompt(chr(8));
  1975.       for cc:=cp-2 downto cv do prompt(' ');
  1976.       i[0]:=chr(cv-1);
  1977.     end;
  1978.   end;
  1979.   nl;
  1980. end;
  1981.  
  1982.  
  1983. procedure chat;
  1984.  
  1985. var c:char; tf:boolean; sp,xx:astr; x:integer; t,t1:real;
  1986. begin
  1987.   sp:=thisline; ch:=true; chatcall:=false; tf:=echo; echo:=true;nl;nl; t:=timer;
  1988.   thisuser.option:=thisuser.option-[alert];
  1989.   if chatr<>'' then
  1990.     begin
  1991.       writeln('                    *** Reason for Chat: ',chatr,' ***');
  1992.       chatr:='';
  1993.     end;
  1994.   ansic(5); print('Sysop''s here, go ahead '+ thisuser.realname + ' ...'); nl;
  1995.   repeat
  1996.     inli1(xx);
  1997.     if (xx='/quitchat') or (xx='/QUITCHAT') then begin
  1998.       t1:=timer; while (abs(t1-timer)<4.0) and (not keypressed) do;
  1999.       if not keypressed then ch:=false;
  2000.     end else if cfo then writeln(cf,xx);
  2001.   until (not ch) or hangup;
  2002.   nl; ansic(5); print('Chat mode completed, standby for return ...'); nl;
  2003.   chattime:=chattime+timer-t; ch:=false; echo:=tf;
  2004.   if hangup and cfo then begin
  2005.     writeln(cf); writeln(cf,'<HANGUP>');
  2006.   end;
  2007.   prompt(sp); thisline:=sp;
  2008.   if cfo then begin cfo:=false; close(cf); end;
  2009. end;
  2010.  
  2011.  
  2012. function yn:boolean;
  2013.  
  2014. var c:char;
  2015. begin
  2016.   if not hangup then begin
  2017.     ansic(3);
  2018.     repeat
  2019.       getkey(c);
  2020.       c:=upcase(c);
  2021.     until (c='Y') or (c='N') or (c=chr(13)) or hangup;
  2022.     if c='Y' then begin print('Yes'); yn:=true; end else begin print('No'); yn:=false; end;
  2023.     if hangup then yn:=false;
  2024.   end;
  2025. end;
  2026.  
  2027.  
  2028. procedure input1(var i:astr; ml:integer; tf:boolean);
  2029.  
  2030. var cp:integer;
  2031.     c:char;
  2032.     r:real;
  2033. begin
  2034.  checkhangup;
  2035.  if not hangup then begin
  2036.   r:=timer;
  2037.   cp:=1;
  2038.   repeat
  2039.     getkey(c);
  2040.     if c=#1 then r:=timer;
  2041.     if not tf then c:=upcase(c);
  2042.     if (c>=' ') and (c<chr(127)) then
  2043.       if cp<=ml then begin
  2044.       i[cp]:=c;
  2045.       cp:=cp+1;
  2046.       outkey(c);
  2047.       thisline:=thisline+c;
  2048.     end else else case ord(c) of
  2049.       8:if cp>1 then begin
  2050.                c:=chr(8);
  2051.                outkey(c);outkey(' '); outkey(c);
  2052.                cp:=cp-1;
  2053.                if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
  2054.              end;
  2055.       21,24:while cp<>1 do begin
  2056.                cp:=cp-1;
  2057.                outkey(#8);outkey(' '); outkey(#8);
  2058.                if length(thisline)>0 then thisline:=copy(thisline,1,length(thisline)-1);
  2059.              end;
  2060.     end;
  2061.     if (timer-r)>300.0 then hangup:=true;
  2062.   until (c=#13) or (c=#14) or hangup;
  2063.   i[0]:=chr(cp-1);
  2064.   nl;
  2065.  end;
  2066. end;
  2067.  
  2068.  
  2069. procedure input(var i:astr; ml:integer);
  2070.  
  2071. begin
  2072.   input1(i,ml,false);
  2073. end;
  2074.  
  2075.  
  2076. procedure inputl(var i:astr; ml:integer);
  2077.  
  2078. begin
  2079.   input1(i,ml,true);
  2080. end;
  2081.  
  2082.  
  2083. procedure onek(var c:char; ch:astr);
  2084.  
  2085. var i1,i:astr; tf:boolean;
  2086. begin
  2087.   i1:=thisline; tf:=false;
  2088.   repeat
  2089.     if not(onekey in thisuser.defaults) then begin
  2090.       if tf then prompt(i1);
  2091.       input(i,3);
  2092.       if length(i)=1 then c:=i[1] else c:=' ';
  2093.     end else begin
  2094.       getkey(c);
  2095.       c:=upcase(c);
  2096.     end;
  2097.     tf:=true;
  2098.   until (pos(c,ch)>0) or hangup;
  2099.   if hangup then c:=ch[1];
  2100.   if onekey in thisuser.defaults then print(''+c);
  2101. end;
  2102.  
  2103.  
  2104. procedure onek2(var c:char; ch:astr);
  2105.  
  2106. var i1,i:astr; tf:boolean;
  2107. begin
  2108.   i1:=thisline; tf:=false;
  2109.   repeat
  2110.     getkey(c);
  2111.     c:=upcase(c);
  2112.     tf:=true;
  2113.   until (pos(c,ch)>0) or hangup;
  2114.   if hangup then c:=ch[1];
  2115.   prt(''+c);
  2116. end;
  2117.  
  2118.  
  2119. procedure centre(var i:astr);
  2120.  
  2121. var n,n1:integer;
  2122. begin
  2123.   if pap<>0 then nl;
  2124.   if i[1]=#2 then i:=copy(i,2,length(i)-1);
  2125.   n:=length(i); n1:=1;
  2126.   while (n1<=length(i)) do begin
  2127.     if i[n1]=#3 then begin
  2128.       n:=n-2;
  2129.       n1:=n1+1;
  2130.     end;
  2131.     n1:=n1+1;
  2132.   end;
  2133.   if n<thisuser.linelen then
  2134.     i:=copy('                                               ',1,
  2135.       (thisuser.linelen-n) div 2)+i;
  2136. end;
  2137.  
  2138.  
  2139. procedure wkey(var abort,next:boolean);
  2140.  
  2141. var cc:char;
  2142.  begin
  2143.     while not (empty or hangup or abort) do begin
  2144.       getkey(cc);
  2145.       if (cc=' ') or (cc=chr(3)) or (cc=chr(24)) or (cc=chr(11)) then
  2146.         abort:=true;
  2147.       if (cc=chr(14)) then begin abort:=true; next:=true; end;
  2148.       if (cc=chr(19)) or (cc='P') or (cc='p') then begin
  2149.         getkey(cc);
  2150.       end;
  2151.     end;
  2152.  end;
  2153.  
  2154.  
  2155. procedure printa1(i:astr; var abort,next:boolean);
  2156.  
  2157. var c:integer;
  2158. begin
  2159.  checkhangup;
  2160.  if not hangup then begin
  2161.   abort:=false; next:=false; c:=1;
  2162.   if not empty then wkey(abort,next);
  2163.   while (not abort) and (c-1<length(i)) and (not hangup) do begin
  2164.     checkhangup;
  2165.     if i[c]=chr(8) then pap:=pap-1 else
  2166.       if i[c]=#3 then begin
  2167.         if i[c+1] in [#0..#8] then
  2168.           if okansi then
  2169.             ansic(ord(i[c+1]));
  2170.       end else
  2171.         if i[c]<>chr(10) then pap:=pap+1;
  2172.     if not empty then wkey(abort,next);
  2173.     if i[c]=#3 then
  2174.       c:=c+1
  2175.     else
  2176.       outkey(i[c]);
  2177.     c:=c+1;
  2178.   end;
  2179.  end else abort:=true;
  2180. end;
  2181.  
  2182. procedure printa(i:astr; var abort,next:boolean);
  2183. var s:astr; p,op,rp,rop,nca:integer; crend:boolean;
  2184. begin
  2185.   abort:=false;
  2186.   crend:=(i[length(i)]=#1) and (i[length(i)-1]<>#3);
  2187.   if crend then i:=copy(i,1,length(i)-1);
  2188.   if i[1]=#2 then begin
  2189.     centre(i);
  2190.     printa1(i,abort,next);
  2191.     nl;
  2192.   end else begin
  2193.     wkey(abort,next);
  2194.     if i='' then nl;
  2195.     while (i<>'') and (not abort) and (not hangup) do begin
  2196.       rp:=0; nca:=thisuser.linelen-pap-1; p:=0;
  2197.       while (rp<nca) and (p<length(i)) do begin
  2198.         if i[p+1]=#8 then rp:=rp-1 else
  2199.           if i[p+1]=#3 then
  2200.             p:=p+1
  2201.           else
  2202.             if (i[p+1]<>#10) then rp:=rp+1;
  2203.         p:=p+1;
  2204.       end;
  2205.       op:=p; rop:=rp;
  2206.       if (rp>=nca) and (p<length(i)) then begin
  2207.         while ((not (i[p] in [' ',#8,#10])) or (i[p-1]=#3)) and (p>1) do begin
  2208.           rp:=rp-1; p:=p-1;
  2209.         end;
  2210.         if p=1 then
  2211.           if not (i[1] in [' ',#8,#10]) then begin rp:=rp-1; p:=p-1; end;
  2212.       end;
  2213.       if abs(rop-rp)>=(thisuser.linelen div 2) then p:=op;
  2214.       s:=copy(i,1,p); delete(i,1,p);
  2215.       if (s[length(s)]=' ') then s[0]:=pred(s[0]);
  2216.       printa1(s,abort,next);
  2217.       if ((i='') and crend) or (i<>'') or abort then
  2218.         nl
  2219.       else
  2220.         printa1(' ',abort,next);
  2221.     end;
  2222.   end;
  2223. end;
  2224.  
  2225. procedure printacr(i:astr; var abort,next:boolean);
  2226. begin
  2227.  if not abort then
  2228.   if i[length(i)]=#1 then
  2229.     printa(i,abort,next)
  2230.   else
  2231.     printa(i+#1,abort,next);
  2232. end;
  2233.  
  2234. function ctim(rl:real):astr;
  2235. var h,m,s:astr;
  2236. begin
  2237.   s:=tch(cstr(trunc(rl-int(rl/60.0)*60.0)));
  2238.   m:=tch(cstr(trunc(int(rl/60.0)-int(rl/3600.0)*60.0)));
  2239.   h:=cstr(trunc(rl/3600.0));
  2240.   if length(h)=1 then h:='0'+h;
  2241.   ctim:=h+':'+m+':'+s;
  2242. end;
  2243.  
  2244. function tlef:astr;
  2245. begin
  2246.   tlef:=ctim(nsl);
  2247. end;
  2248.  
  2249.  
  2250. function cstrr(rl:real; base:integer):astr;
  2251. var c1,c2,c3:integer; i:astr; r1,r2:real;
  2252. begin
  2253.  if rl<=0.0 then cstrr:='0' else begin
  2254.   r1:=ln(rl)/ln(1.0*base);
  2255.   r2:=exp(ln(1.0*base)*(trunc(r1)));
  2256.   i:='';
  2257.   while (r2>0.999) do begin
  2258.     c1:=trunc(rl/r2);
  2259.     i:=i+copy('0123456789ABCDEF',c1+1,1);
  2260.     rl:=rl-c1*r2;
  2261.     r2:=r2/(1.0*base);
  2262.   end;
  2263.   cstrr:=i;
  2264.  end;
  2265. end;
  2266.  
  2267.  
  2268. procedure savesystat;
  2269. begin
  2270.   reset(systatf); write(systatf,systat); close(systatf);
  2271. end;
  2272.  
  2273.  
  2274. procedure pfl(fn:astr; var abort:boolean; cr:boolean);
  2275. var fil:text;
  2276.     i:astr;
  2277.     next:boolean;
  2278. begin
  2279.     if not hangup then begin
  2280.       assign(fil,fn);
  2281.       {$I-} reset(fil); {$I+}
  2282.       if ioresult<>0 then print('File not found.') else begin
  2283.         abort:=false;
  2284.         while not eof(fil) and (not abort) and (not hangup) do begin
  2285.           readln(fil,i);
  2286.           if cr then
  2287.             printacr(i,abort,next)
  2288.           else
  2289.             printa(i,abort,next);
  2290.         end;
  2291.         close(fil);
  2292.       end;
  2293.       nl;nl;
  2294.     end;
  2295. end;
  2296.  
  2297. procedure printfile(fn:astr);
  2298. var abort:boolean;
  2299. begin
  2300.   pfl(fn,abort,true);
  2301. end;
  2302.  
  2303. procedure print_file (fn:astr);
  2304. {This is a modification procedure that allows Ansi Graphics.  Take it out}
  2305. {If you do not want to use it, otherwise have fun with Real ANSI!!}
  2306.  
  2307. Var  fil:Text; i:char; abort,next:boolean; c:Integer; r:registers;
  2308. begin
  2309.  if not hangup then begin
  2310.    assign(fil,fn);
  2311.    {$I-} reset(fil); {$I+}
  2312.    if ioresult<>0 then print('File not found.') else begin
  2313.      abort:=false;
  2314.      while ((not eof(fil)) and (not abort) and (not hangup)) do begin
  2315.        checkhangup;
  2316.        if (not empty) then wkey(abort,next);
  2317.        read(fil,i);
  2318.           If outcom then o1(i);
  2319.           With r Do Begin
  2320.              DX := Ord(i);
  2321.              AX := $0200;
  2322.              MsDos (r);
  2323.           End;
  2324.      end;
  2325.      close(fil);
  2326.    end;
  2327.  end;
  2328.  topscr;
  2329. end;
  2330.  
  2331. END.
  2332.