home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FAQ-S.ZIP / SUBS2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-05-04  |  57.1 KB  |  2,204 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit subs2;
  5.  
  6. { $define testingdevices}   { Activate this define for test mode }
  7.  
  8. interface
  9.  
  10. uses printer,dos,crt,overlay,gentypes,configrt,gensubs,subs1,windows,modem,
  11.      video,textret,mailret,statret,chatstuf,flags,userret;
  12.  
  13. procedure clearscr;
  14. procedure replace (var main:anystr; old,new:anystr);
  15. procedure beepbeep;
  16. procedure summonbeep;
  17. procedure abortttfile (er:integer);
  18. procedure openttfile;
  19. procedure writecon (k:char);
  20. procedure toggleavail;
  21. {procedure domacro (sussuh:anystr);}
  22. function charready:boolean;
  23. function readchar:char;
  24. function waitforupchar:char;
  25. function waitforchar:char;
  26. procedure clearchain;
  27. function charpressed (k:char):boolean;  { TRUE if K is in typeahead }
  28. procedure addtochain (l:lstr);
  29. procedure directoutchar (k:char);
  30. procedure handleincoming;
  31. procedure writechar (k:char);
  32. {F+}
  33.       function opendevice (var t:textrec):integer;
  34.       function closedevice (var t:textrec):integer;
  35.       function cleardevice (var t:textrec):integer;
  36.       function ignorecommand (var t:textrec):integer;
  37.       function directoutchars (var t:textrec):integer;
  38.       function writechars (var t:textrec):integer;
  39.       function directinchars (var t:textrec):integer;
  40.       function readcharfunc (var t:textrec):integer;
  41. {F-}
  42. function getinputchar:char;
  43. procedure getstr (mode:integer);
  44. procedure writestr (s:anystr);
  45. procedure printxy (x,y:integer;str:anystr);
  46. procedure printxy2 (x,y:integer;str:anystr);
  47. procedure cls;
  48. procedure writehdr (q:anystr);
  49. function issysop:boolean;
  50. {function islz:boolean;}
  51. procedure reqlevel (l:integer);
  52. procedure printfile (fn:lstr);
  53. {procedure print_the_stats (fn:lstr);}
  54. procedure show_all_info (fn:lstr;dernier:mstr;nombre:integer);
  55. procedure printtexttopoint (var tf:text);
  56. procedure skiptopoint (var tf:text);
  57. function minstr (blocks:integer):sstr;
  58. procedure parserange (numents:integer; var f,l:integer);
  59. function menutype:integer;
  60. function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
  61. procedure menuname (menunme:lstr);
  62. function checkpassword (var u:userrec):boolean;
  63. function getpassword:boolean;
  64. procedure getacflag (var ac:accesstype; var tex:mstr);
  65. procedure calcqr;
  66. procedure overlayerror;
  67. function parsedate (date:anystr):lstr;
  68. function ansi:boolean;
  69. function ascii:boolean;
  70. procedure setmenutype;
  71. procedure movexy (x,y:integer);
  72. procedure ansicls;
  73. {procedure idiot;}
  74. procedure showcredits;
  75. procedure ansi_window (xx,yy,xxx,yyy:integer);
  76. procedure write_menu (x,y:integer; c,s:string);
  77. procedure pause;
  78.  
  79. implementation
  80.  
  81.   procedure clearscr;
  82.   begin
  83.  if (ansigraphics in urec.config) then
  84.  write (direct,#27+'[2J') else
  85.  write (^L);
  86.   end;
  87.  
  88. procedure replace (var main:anystr; old,new:anystr);
  89. var p : byte;
  90. begin
  91.   repeat
  92.     p := pos (old,main);
  93.     if p <> 0 then
  94.     begin
  95.       delete (main,p,length(old));
  96.       insert (new,main,p)
  97.     end
  98.   until p = 0;
  99. end;
  100.  
  101. {procedure beepbeep;
  102. begin
  103.   nosound;
  104.   sound (200);
  105.   delay (50);
  106.   nosound
  107. end;}
  108.  
  109. procedure beepbeep;
  110. begin
  111.   nosound;
  112.   sound (200);
  113.   delay (20);
  114.   nosound
  115. end;
  116.  
  117. procedure summonbeep;
  118. var cnt:integer;
  119. begin
  120.   nosound;
  121.   cnt:=1330;
  122.   repeat
  123.     sound (cnt);
  124.     delay (10);
  125.     cnt:=cnt+200;
  126.   until cnt>4300;
  127.   nosound
  128. end;
  129.  
  130. procedure abortttfile (er:integer);
  131. var n:integer;
  132. begin
  133.   specialmsg ('Texttrap error '+strr(er)+'.');
  134.   texttrap:=false;
  135.   textclose (ttfile);
  136.   n:=ioresult
  137. end;
  138.  
  139. procedure openttfile;
  140. var n:integer;
  141. begin
  142.   appendfile (bbsdatadir+'Texttrap.dat',ttfile);
  143.   n:=ioresult;
  144.   if n=0
  145.     then texttrap:=true
  146.     else abortttfile (n)
  147. end;
  148.  
  149. function scramble (s:char):char;
  150. var f:text;
  151.     x,y:char;
  152.     z:integer;
  153. begin
  154.  scramble:=s;
  155.  if noscramble then exit;
  156.  if not scrambled then exit;
  157.  if not exist (faqdir+'Scramble.Dat') then exit;
  158.  if not (ord(s) in [65..90,97..122]) then exit;
  159.  assign (f,faqdir+'Scramble.Dat');
  160.  reset (f);
  161.  for z:=1 to ord(s) do
  162.  read (f,x);
  163.  scramble:=x;
  164.  close (f);
  165. end;
  166.  
  167. procedure overridescramble;
  168. begin
  169.  if scrambled then begin
  170.   scrambled:=false;
  171.  end else
  172.  if not scrambled then begin
  173.   scrambled:=true;
  174.  end;
  175.  textcolor (12);
  176.  writeln (usr);
  177.  writeln (usr);
  178.  beepbeep;
  179.  writeln (usr,'┌─────────────────────────────┐');
  180.  write (usr,'│ == ');
  181.  textcolor (9);
  182.  write (usr,'Data Scramble Override!!');
  183.  textcolor (12);
  184.  writeln (usr,' │');
  185.  write (usr,'│ == ');
  186.  textcolor (10);
  187.  write (usr,'Data Scramble is now:');
  188.  textcolor (11);
  189.  if scrambled then write (usr,'ON  ') else
  190.   if not scrambled then write (usr,'OFF ');
  191.  textcolor (12);
  192.  writeln (usr,'│');
  193.  writeln (usr,'└─────────────────────────────┘');
  194.  writeln (usr);
  195.  writeln (usr);
  196.  textcolor (urec.regularcolor);
  197. end;
  198.  
  199.  
  200. procedure togglescreenoutput;
  201. begin
  202.  if screenoutput then
  203.  screenoutput:=false else
  204.  screenoutput:=true;
  205. end;
  206.  
  207. procedure writecon (k:char);
  208. var r:registers;
  209.     kk:char;
  210. begin
  211.   if k=^J
  212.     then write (usr,k)
  213.     else
  214.       begin
  215.       { if scrambled then kk:=scramble (k)
  216.         else } kk:=k;
  217.         r.dl:=ord(kk);
  218.         r.ah:=2;
  219.         intr($21,r)
  220.       end
  221. end;
  222.  
  223. procedure toggleavail;
  224. begin
  225.   if sysopavail=Notavailable
  226.     then sysopavail:=available
  227.     else sysopavail:=succ(sysopavail)
  228. end;
  229.  
  230. procedure domacro (sussuh:anystr); forward;
  231.  
  232. function charready:boolean;
  233. var k:char;
  234. begin
  235.   if modeminlock then while numchars>0 do k:=getchar;
  236.   if hungupon or keyhit
  237.     then charready:=true
  238.     else if online
  239.       then charready:=(not modeminlock) and (numchars>0)
  240.       else charready:=false
  241. end;
  242.  
  243. function readchar:char;
  244.  
  245.   procedure toggletempsysop;
  246.   begin
  247.     if tempsysop
  248.       then ulvl:=regularlevel
  249.       else
  250.         begin
  251.           regularlevel:=ulvl;
  252.           ulvl:=sysoplevel
  253.         end;
  254.     tempsysop:=not tempsysop
  255.   end;
  256.  
  257.   procedure togviewstats;
  258.   begin
  259.     if splitmode
  260.       then unsplit
  261.       else
  262.         begin
  263.           splitscreen (14);
  264.           top;
  265.           clrscr;
  266.           write (usr,'[Level]:          ',urec.level,
  267.                  ^M^J'[File Level]:     ',urec.udlevel,
  268.                  ^M^J'[File Points]:    ',urec.udpoints,
  269.                  ^M^J'[User Note]:      ',urec.note,
  270.                  ^M^J'[# Downloads]:    ',urec.downloads,
  271.                  ^M^J'[# Uploads]:      ',urec.uploads,
  272.                  ^M^J'[# of Posts]:     ',urec.nbu,
  273.                  ^M^J'[G-File Ups]:     ',urec.nup,
  274.                  ^M^J'[G-File Downs]:   ',urec.ndn,
  275.                  ^M^J'[Total Time]:     ',urec.totaltime:0:0,
  276.                  ^M^J'[# of Calls]:     ',urec.numon);
  277.           bottom
  278.         end;
  279.   end;
  280.  
  281. type ScreenType = array [0..3999] of Byte;
  282. var ScreenAddr : ScreenType absolute $B800:$0000;
  283. const
  284.   HELP_ME_WIDTH=80;
  285.   HELP_ME_DEPTH=25;
  286.   HELP_ME_LENGTH=1064;
  287.   HELP_ME : array [1..1064] of Char = (
  288.     #16,#24,#9 ,'┌',#26,#77,'─','┐',#24,'│',' ',#15,'F','A','Q',' ','v',
  289.     #11,'1','.','0','0',' ',#15,'P','o','p','-','u','p',' ','H','e','l',
  290.     'p',#25,#55,#9 ,'│',#24,'├',#26,#37,'─','┬','┬',#26,#37,'─','┤',#24,
  291.     '│',#15,'[','F','1',']',' ','T','w','o','-','W','a','y',' ','C','h',
  292.     'a','t',' ','M','o','d','e',' ','w','i','t','h',' ','U','s','e','r',
  293.     #25,#5 ,#9 ,'│','│',#15,'[','A','l','t','-','A',']',' ','T','o','g',
  294.     'g','l','e',' ','C','h','a','t',' ','A','v','a','i','l','a','b','i',
  295.     'l','i','t','y',#25,#5 ,#9 ,'│',#24,'│',#15,'[','F','2',']',' ','L',
  296.     'i','n','e',' ','C','h','a','t',' ','M','o','d','e',' ','w','i','t',
  297.     'h',' ','U','s','e','r',#25,#8 ,#9 ,'│','│',#15,'[','A','l','t','-',
  298.     'T',']',' ','G','r','a','n','t',' ','T','e','m','p','o','r','a','r',
  299.     'y',' ','S','y','s','o','p',' ','A','c','c','e','s','s',' ',' ',#9 ,
  300.     '│',#24,'│',#15,'[','F','3',']',' ','H','a','n','g',' ','u','p',' ',
  301.     'o','n',' ','U','s','e','r',#25,#17,#9 ,'│','│',#15,'[','A','l','t',
  302.     '-','K',']',' ','T','a','k','e',' ','a','w','a','y',' ','a','l','l',
  303.     ' ','T','i','m','e',#25,#11,#9 ,'│',#24,'│',#15,'[','F','4',']',' ',
  304.     'Q','u','i','c','k',' ','V','a','l','i','d','a','t','e',' ','C','u',
  305.     'r','r','e','n','t',' ','U','s','e','r',#25,#5 ,#9 ,'│','│',#15,'[',
  306.     'A','l','t','-','B',']',' ','T','o','g','g','l','e',' ','t','h','e',
  307.     ' ','S','t','a','t','u','s',' ','B','a','r',#25,#8 ,#9 ,'│',#24,'│',
  308.     #15,'[','F','5',']',' ','O','n','-','L','i','n','e',' ','S','y','s',
  309.     'o','p',' ','U','t','i','l','i','t','i','e','s',' ','M','e','n','u',
  310.     #25,#4 ,#9 ,'│','│',#15,'[','A','l','t','-','E',']',' ','T','o','g',
  311.     'g','l','e',' ','T','e','x','t',' ','T','r','a','p',#25,#13,#9 ,'│',
  312.     #24,'│',#15,'[','F','6',']',#25,#33,#9 ,'│','│',#15,'[','A','l','t',
  313.     '-','V',']',' ','V','i','e','w',' ','C','u','r','r','e','n','t',' ',
  314.     'U','s','e','r','s',' ','S','t','a','t','u','s',#25,#4 ,#9 ,'│',#24,
  315.     '│',#15,'[','F','7',']',' ','E','x','i','t',' ','t','o',' ','D','O',
  316.     'S',' ','a','f','t','e','r',' ','C','a','l','l',#25,#10,#9 ,'│','│',
  317.     #15,'[','A','l','t','-','O',']',' ','O','v','e','r','r','i','d','e',
  318.     ' ','D','a','t','a',' ','S','c','r','a','m','b','l','i','n','g',#25,
  319.     #5 ,#9 ,'│',#24,'│',#15,'[','F','8',']',' ','L','o','c','k',' ','t',
  320.     'h','e',' ','T','i','m','e',#25,#19,#9 ,'│','│',#15,'[','A','l','t',
  321.     '-','D',']',' ','S','h','e','l','l',' ','t','o',' ','D','O','S',#25,
  322.     #17,#9 ,'│',#24,'│',#15,'[','F','9',']',' ','L','o','c','k',' ','o',
  323.     'u','t',' ','a','l','l',' ','M','o','d','e','m',' ','I','n','p','u',
  324.     't',#25,#8 ,#9 ,'│','│',#15,'[','A','l','t','-','F','1',']','-','[',
  325.     'A','l','t','-','F','1','0',']',' ','S','y','s','o','p',' ','M','a',
  326.     'c','r','o','s',' ','1','-','1','0',' ',' ',#9 ,'│',#24,'│',#15,'[',
  327.     'F','1','0',']',' ','L','o','c','k',' ','i','n',' ','a','l','l',' ',
  328.     'M','o','d','e','m',' ','O','u','t','p','u','t',#25,#7 ,#9 ,'│','│',
  329.     #15,'[','C','t','r','l','-','P','r','t','S','c','r',']',' ','T','o',
  330.     'g','g','l','e',' ','P','r','i','n','t','e','r',' ','E','c','h','o',
  331.     #25,#4 ,#9 ,'│',#24,'│',#25,#37,'│','│',#15,'[','U',' ','A','r','r',
  332.     'o','w',']',' ','I','n','c','r','e','a','s','e',' ','#',' ','o','f',
  333.     ' ','F','i','l','e',' ','P','o','i','n','t','s',#25,#2 ,#9 ,'│',#24,
  334.     '│',#25,#37,'│','│',#15,'[','D',' ','A','r','r','o','w',']',' ','D',
  335.     'e','c','r','e','a','s','e',' ','#',' ','o','f',' ','F','i','l','e',
  336.     ' ','P','o','i','n','t','s',#25,#2 ,#9 ,'│',#24,'│',#25,#37,'│','│',
  337.     #15,'[','L',' ','A','r','r','o','w',']',' ','D','e','c','r','e','a',
  338.     's','e',' ','T','i','m','e',' ','L','e','f','t',#25,#9 ,#9 ,'│',#24,
  339.     '│',#25,#37,'│','│',#15,'[','R',' ','A','r','r','o','w',']',' ','I',
  340.     'n','c','r','e','a','s','e',' ','T','i','m','e',' ','L','e','f','t',
  341.     #25,#9 ,#9 ,'│',#24,'│',#25,#37,'│','│',#15,'[','H','o','m','e',']',
  342.     ' ','D','e','c','r','e','a','s','e',' ','M','a','i','n',' ','L','e',
  343.     'v','e','l',#25,#11,#9 ,'│',#24,'│',#25,#37,'│','│',#15,'[','P','g',
  344.     'U','p',']',' ','I','n','c','r','e','a','s','e',' ','M','a','i','n',
  345.     ' ','L','e','v','e','l',#25,#11,#9 ,'│',#24,'│',#25,#37,'│','│',#15,
  346.     '[','E','n','d',']',' ','D','e','c','r','e','a','s','e',' ','F','i',
  347.     'l','e',' ','L','e','v','e','l',#25,#12,#9 ,'│',#24,'│',#25,#37,'│',
  348.     '│',#15,'[','P','g','D','n',']',' ','I','n','c','r','e','a','s','e',
  349.     ' ','F','i','l','e',' ','L','e','v','e','l',#25,#11,#9 ,'│',#24,'└',
  350.     #26,#37,'─','┴','┴',#26,#37,'─','┘',#24);
  351.  
  352. procedure UNCRUNCH (var Addr1,Addr2; BlkLen:Integer);
  353. begin
  354.   inline (
  355. $1E/$C5/$B6/Addr1/$C4/$BE/Addr2/$8B/$8E/BlkLen/$8B/$D7/$33/$C0/
  356. $FC/$AC/$3C/$1B/$75/$05/$80/$F4/$80/$EB/$4D/$3C/$10/$73/$07/
  357. $80/$E4/$70/$0A/$E0/$EB/$42/$3C/$18/$74/$13/$73/$19/$2C/$10/
  358. $02/$C0/$02/$C0/$02/$C0/$02/$C0/$80/$E4/$8F/$0A/$E0/$EB/$2B/
  359. $81/$C2/$A0/$00/$8B/$FA/$EB/$23/$3C/$19/$75/$0B/$AC/$51/$32/$ED/
  360. $8A/$C8/$B0/$20/$EB/$0D/$90/$3C/$1A/$75/$0F/$AC/$49/$51/$32/$ED/
  361. $8A/$C8/$AC/$E3/$03/$AB/$E2/$FD/$59/$49/$AB/$E3/$02/$E2/$A5/$1F);
  362. end;
  363.  
  364. procedure help;
  365.  var s:screens;c:char;x,y:byte;
  366.  begin
  367.   x:=wherex;
  368.   y:=wherey;
  369.   readscr(s);
  370.   cursor (false);
  371.   clrscr;
  372.   UNCRUNCH(HELP_ME,ScreenAddr[(1*2)+(1*160)-162],HELP_ME_LENGTH);
  373.   repeat
  374.    c:=#255;
  375.    c:=readkey;
  376.   until c<>#255;
  377.   writescr(s);
  378.   gotoxy(x,y);
  379.   cursor (true);
  380.  end;
  381.  
  382.   procedure showhelp;
  383.   begin
  384.    help;
  385.   end;
  386.  
  387.   procedure toggletexttrap;
  388.   var n:integer;
  389.   begin
  390.     if texttrap
  391.       then
  392.         begin
  393.           textclose (ttfile);
  394.           n:=ioresult;
  395.           if n<>0 then abortttfile (n);
  396.           texttrap:=false
  397.         end
  398.       else openttfile
  399.   end;
  400.  
  401. procedure printsysopmacro (n:integer);
  402. begin
  403.  case n of
  404.   1:domacro (sysopmacro1);
  405.   2:domacro (sysopmacro2);
  406.   3:domacro (sysopmacro3);
  407.   4:domacro (sysopmacro4);
  408.   5:domacro (sysopmacro5);
  409.   6:domacro (sysopmacro6);
  410.   7:domacro (sysopmacro7);
  411.   8:domacro (sysopmacro8);
  412.   9:domacro (sysopmacro9);
  413.  10:domacro (sysopmacro10);
  414.  end;
  415. end;
  416.  
  417.  
  418. var k:char;
  419.     ret:char;
  420.     linenoise:anystr;
  421.     dorefresh:boolean;
  422.     iamlaym:byte;
  423.     i,cnt:integer;
  424. begin
  425.   requestchat1:=false;
  426.   requestchat2:=false;
  427.   requestcom:=false;
  428.   reqspecial:=false;
  429.   if keyhit
  430.     then
  431.       begin
  432.         k:=bioskey;
  433.         ret:=k;
  434.         if ord(k)>127 then begin
  435.           ret:=#0;
  436.           dorefresh:=ingetstr;
  437.           case ord(k)-128 of
  438.             availtogglechar:
  439.               begin
  440.                 toggleavail;
  441.                 chatmode:=false;
  442.                 dorefresh:=true
  443.               end;
  444.             doschar:begin
  445.                 writeln ('Sysop in DOS:');
  446.                 window (1,1,80,25);
  447.                 gotoxy (1,25);
  448.                 writeln (usr,^M^J^J^J);
  449.                 updateuserstats (false);
  450.                 execcomcom;
  451.                 clrscr;
  452.               end;
  453.             sysopcomchar:
  454.               begin
  455.                 requestcom:=true;
  456.                 requestchat1:=true;
  457.                {requestchat2:=true}
  458.               end;
  459.  
  460.           astaline:
  461.               begin
  462.                   writeln;
  463.                 linenoise:='╬╪╫£¢Θw-s=@%*4';
  464.                 for cnt:=1 to 8 do write (linenoise[cnt]);
  465.                 forcehangup:=true;
  466.                 hangup;
  467.               end;
  468.  
  469.             breakoutchar:halt(e_controlbreak);
  470.             lesstimechar:urec.timetoday:=urec.timetoday-1;
  471.             moretimechar:urec.timetoday:=urec.timetoday+1;
  472.             uparrow:urec.udpoints:=urec.udpoints+1;
  473.             downarrow:urec.udpoints:=urec.udpoints-1;
  474.             leftarrow:urec.timetoday:=urec.timetoday-1;
  475.             rightarrow:urec.timetoday:=urec.timetoday+1;
  476.             home:ulvl:=ulvl-1;
  477.             pageup:ulvl:=ulvl+1;
  478.             endkey:urec.udlevel:=urec.udlevel-1;
  479.             pagedown:urec.udlevel:=urec.udlevel+1;
  480.             leftarrow:urec.timetoday:=urec.timetoday-1;
  481.             rightarrow:urec.timetoday:=urec.timetoday+1;
  482.             notimechar:settimeleft (-1);
  483.             chat1char:requestchat1:=true;
  484.             chat2char:requestchat2:=true;
  485.             sysnextchar:sysnext:=not sysnext;
  486.             timelockchar:if timelock then timelock:=false else begin
  487.                            timelock:=true;
  488.                            lockedtime:=timeleft
  489.                          end;
  490.             inlockchar:modeminlock:=not modeminlock;
  491.             outlockchar:setoutlock (not modemoutlock);
  492.             tempsysopchar:toggletempsysop;
  493.             bottomchar:begin
  494.                        if statusbar then statusbar:=false else statusbar:=true;
  495.                        bottomline; end;
  496.             validate:begin
  497.             ulvl:=qvmainl;
  498.             urec.udlevel:=qvxferl;
  499.             urec.udpoints:=qvxferp;
  500.             urec.gflevel:=qvgfile;
  501.             urec.note:=qvnote;
  502.             cnt:=urec.level;
  503.             if cnt<1 then cnt:=1;
  504.             if cnt>100 then cnt:=100;
  505.             urec.timetoday:=usertime[cnt];
  506.             writeurec;
  507.             end;
  508.             viewstatchar:togviewstats;
  509.             sysophelpchar:if dorefresh then showhelp;
  510.             texttrapchar:toggletexttrap;
  511.             printerechochar:printerecho:=not printerecho;
  512.             sm1char:printsysopmacro(1);
  513.             sm2char:printsysopmacro(2);
  514.             sm3char:printsysopmacro(3);
  515.             sm4char:printsysopmacro(4);
  516.             sm5char:printsysopmacro(5);
  517.             sm6char:printsysopmacro(6);
  518.             sm7char:printsysopmacro(7);
  519.             sm8char:printsysopmacro(8);
  520.             sm9char:printsysopmacro(9);
  521.             sm10char:printsysopmacro(10);
  522.             phunkey:write (direct,^G);
  523.             scroverride:overridescramble;
  524.             noscreenoutput:togglescreenoutput;
  525.             72:ret:=^E;
  526.             75:ret:=^S;
  527.             77:ret:=^D;
  528.             80:ret:=^X;
  529.             115:ret:=^A;
  530.             116:ret:=^F;
  531.             73:ret:=^R;
  532.             81:ret:=^C;
  533.             71:ret:=^Q;
  534.             79:ret:=^W;
  535.             83:ret:=^G;
  536.             82:ret:=^V;
  537.             117:ret:=^P;
  538.           end;
  539.           if dorefresh then bottomline
  540.         end
  541.       end
  542.     else
  543.       begin
  544.         k:=getchar;
  545.         if modeminlock
  546.           then ret:=#0
  547.           else ret:=k
  548.       end;
  549.   if ret='+' then write (' '^H);
  550.   readchar:=ret
  551. end;
  552.  
  553. function waitforchar:char;
  554. var t:integer;
  555.     k:char;
  556. begin
  557.   t:=timer+mintimeout;
  558.   if t>=1440 then t:=t-1440;
  559.   repeat
  560.     if timer=t then forcehangup:=true
  561.   until charready;
  562.   waitforchar:=readchar
  563. end;
  564.  
  565. function waitforupchar:char;
  566. var t:integer;
  567.     k:char;
  568. begin
  569.   t:=timer+mintimeout;
  570.   if t>=1440 then t:=t-1440;
  571.   repeat
  572.     if timer=t then forcehangup:=true
  573.   until charready;
  574.   waitforupchar:=upcase(readchar)
  575. end;
  576.  
  577. procedure clearchain;
  578. begin
  579.   chainstr[0]:=#0
  580. end;
  581.  
  582. function charpressed (k:char):boolean;  { TRUE if K is in typeahead }
  583. begin
  584.   charpressed:=pos(k,chainstr)>0
  585. end;
  586.  
  587. procedure addtochain (l:lstr);
  588. begin
  589.   if length(chainstr)<>0 then chainstr:=chainstr+',';
  590.   chainstr:=chainstr+l
  591. end;
  592.  
  593. procedure directoutchar (k:char);
  594. var n:integer;
  595. begin
  596.   if inuse<>1
  597.     then writecon (k)
  598.     else begin
  599.       bottom;
  600.       writecon (k);
  601.       top
  602.     end;
  603.   if wherey>lasty then gotoxy (wherex,lasty);
  604.   if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
  605.     then sendchar(k);
  606.   if texttrap then begin
  607.     write (ttfile,k);
  608.     n:=ioresult;
  609.     if n<>0 then abortttfile (n)
  610.   end;
  611.   if printerecho then write (lst,k)
  612. end;
  613.  
  614. procedure handleincoming;
  615. var k:char;
  616. begin
  617.   k:=readchar;
  618.   case upcase(k) of
  619.     'X',^X,^K,^C,#27,' ':begin
  620.       writeln (direct);
  621.       break:=true;
  622.       linecount:=0;
  623.       xpressed:=(upcase(k)='X') or (k=^X);
  624.       if k=#27 then clearoutput;
  625.       if k=^C then clearoutput;
  626.       if k=^X then clearoutput;
  627.       if k=^Q then clearoutput;
  628.       if xpressed then clearchain
  629.     end;
  630.     ^S:k:=waitforchar;
  631.     else if length(chainstr)<255 then chainstr:=chainstr+k
  632.   end
  633. end;
  634.  
  635. procedure writechar (k:char);
  636.  
  637.   procedure endofline;
  638.  
  639.     procedure writeback (k:char; many:byte);
  640.     var n:integer;
  641.     begin
  642.       for n:=1 to many do directoutchar (k)
  643.     end;
  644.  
  645.   var b:boolean;
  646.   begin
  647.     writeln (direct);
  648.     if timelock then settimeleft (lockedtime);
  649.     if curattrib=urec.statcolor then ansicolor (urec.regularcolor);
  650.     linecount:=linecount+1;
  651.     if (linecount>=urec.displaylen-1) and (not dontstop)
  652.           and (moreprompts in urec.config) then begin
  653.       linecount:=1;
  654.       write (direct,'[Pause] [Y/N/C]: ');
  655.       repeat
  656.         k:=upcase(waitforchar)
  657.       until (k in [^M,' ','C','N','Y']) or hungupon;
  658.       writeback (^H,17);
  659.       writeback (' ',17);
  660.       writeback (^H,17);
  661.       if k='N' then break:=true else if k='C' then dontstop:=true
  662.     end
  663.   end;
  664.  
  665. begin
  666.   if hungupon then exit;
  667.   if k<=^Z then
  668.     case k of
  669.       ^J,#0:exit;
  670.       ^Q:k:=^H;
  671.       ^B:begin
  672.            clearbreak;
  673.            exit
  674.          end
  675.     end;
  676.   if break then exit;
  677.   if k<=^Z then begin
  678.     case k of
  679.       ^G:beepbeep;
  680.       ^L:cls;
  681.       ^N,^R:begin {ansireset;} ansicolor (urec.regularcolor); end;
  682.       ^A:textcolor (normbotcolor);
  683.       ^C:textcolor (normtopcolor);
  684.       ^S:ansicolor (urec.statcolor);
  685.       ^P:ansicolor (urec.promptcolor);
  686.       ^U:ansicolor (urec.inputcolor);
  687.       ^H:directoutchar (k);
  688.       ^M:endofline;
  689.       ^X:ansicolor (urec.bordercolor);
  690.       ^Y:ansicolor (urec.bstatuscolor);
  691.     end;
  692.     exit
  693.   end;
  694.   if usecapsonly then k:=upcase(k);
  695.   directoutchar (k);
  696.   if (keyhit or ((not modemoutlock) and online and (numchars>0)))
  697.      and (not nobreak) then handleincoming
  698. end;
  699.  
  700. function getinputchar:char;
  701. var k:char;
  702. begin
  703.   if length(chainstr)=0 then begin
  704.     getinputchar:=waitforchar;
  705.     exit
  706.   end;
  707.   k:=chainstr[1];
  708.   delete (chainstr,1,1);
  709.   if (k=',') and (not nochain) then k:=#13;
  710.   getinputchar:=k
  711. end;
  712.  
  713. {$ifdef testingdevices}
  714.  
  715. procedure devicedone (var t:textrec; m:mstr);
  716. var r:registers;
  717.     cnt:integer;
  718. begin
  719.   write (usr,'Device ');
  720.   cnt:=0;
  721.   while t.name[cnt]<>#0 do begin
  722.     write (usr,t.name[cnt]);
  723.     cnt:=cnt+1
  724.   end;
  725.   writeln (usr,' ',m,'... press any key');
  726.   r.ax:=0;
  727.   intr ($16,r);
  728.   if r.al=3 then halt
  729. end;
  730.  
  731. {$endif}
  732.  
  733. {$F+}
  734.  
  735. function opendevice;
  736. begin
  737.   {$ifdef testingdevices}  devicedone (t,'opened');  {$endif}
  738.   t.handle:=1;
  739.   t.mode:=fminout;
  740.   t.bufend:=0;
  741.   t.bufpos:=0;
  742.   opendevice:=0
  743. end;
  744.  
  745. function closedevice;
  746. begin
  747.   {$ifdef testingdevices}  devicedone (t,'closed');  {$endif}
  748.   t.handle:=0;
  749.   t.mode:=fmclosed;
  750.   t.bufend:=0;
  751.   t.bufpos:=0;
  752.   closedevice:=0
  753. end;
  754.  
  755. function cleardevice;
  756. begin
  757.   {$ifdef testingdevices}  devicedone (t,'cleared');  {$endif}
  758.   t.bufend:=0;
  759.   t.bufpos:=0;
  760.   cleardevice:=0
  761. end;
  762.  
  763. function ignorecommand;
  764. begin
  765.   {$ifdef testingdevices}  devicedone (t,'ignored');  {$endif}
  766.   ignorecommand:=0
  767. end;
  768.  
  769. function directoutchars;
  770. var cnt:integer;
  771. begin
  772.   for cnt:=t.bufend to t.bufpos-1 do
  773.     directoutchar (t.bufptr^[cnt]);
  774.   t.bufend:=0;
  775.   t.bufpos:=0;
  776.   directoutchars:=0
  777. end;
  778.  
  779. function writechars;
  780. var cnt:integer;
  781. begin
  782.   for cnt:=t.bufend to t.bufpos-1 do
  783.     writechar (t.bufptr^[cnt]);
  784.   t.bufend:=0;
  785.   t.bufpos:=0;
  786.   writechars:=0
  787. end;
  788.  
  789. function directinchars;
  790. begin
  791.   with t do begin
  792.     bufptr^[0]:=waitforchar;
  793.     t.bufpos:=0;
  794.     t.bufend:=1
  795.   end;
  796.   directinchars:=0
  797. end;
  798.  
  799. function readcharfunc;
  800. begin
  801.   with t do begin
  802.     bufptr^[0]:=getinputchar;
  803.     t.bufpos:=0;
  804.     t.bufend:=1
  805.   end;
  806.   readcharfunc:=0
  807. end;
  808.  
  809. procedure usermacro (m:char);
  810.  
  811.   procedure doithonky (k:char);
  812.   var n:integer;
  813.   begin
  814.     if inuse<>1
  815.       then writecon (k)
  816.       else begin
  817.         bottom;
  818.         writecon (k);
  819.         top
  820.       end;
  821.     if wherey>lasty then gotoxy (wherex,lasty);
  822.     if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
  823.       then sendchar(k);
  824.     if texttrap then begin
  825.       write (ttfile,k);
  826.       n:=ioresult;
  827.       if n<>0 then abortttfile (n)
  828.     end;
  829.     if printerecho then write (lst,k)
  830.   end;
  831.  
  832.   procedure doumacro (var mm:anystr);
  833.   var x:integer;
  834.   begin
  835.    for x:=1 to length(mm) do begin
  836.     if mm[x]='~' then writeln else
  837.     doithonky (mm[x]);
  838.    end;
  839.   end;
  840.  
  841. begin
  842.  case upcase (m) of
  843.   'A':doumacro (urec.macro1);
  844.   'D':doumacro (urec.macro2);
  845.   'F':doumacro (urec.macro3);
  846.  end;
  847. end;
  848.  
  849.  
  850. {$F-}
  851.  
  852. procedure getstr (mode:integer);
  853. var marker,cnt:integer;
  854.     p:byte absolute input;
  855.     k:char;
  856.     oldinput:anystr;
  857.     done,wrapped,number:boolean;
  858.     wordtowrap:lstr;
  859.  
  860.   procedure bkspace;
  861.  
  862.     procedure bkwrite (q:sstr);
  863.     begin
  864.       write (q);
  865.       if splitmode and echodot then write (usr,q)
  866.     end;
  867.  
  868.   begin
  869.     if p<>0
  870.       then
  871.         begin
  872.           if input[p]=^Q
  873.             then bkwrite (' ')
  874.             else bkwrite (k+' '+k);
  875.           p:=p-1
  876.         end
  877.       else if wordwrap
  878.         then
  879.           begin
  880.             input:=k;
  881.             done:=true
  882.           end
  883.   end;
  884.  
  885.   procedure sendit (k:char; n:integer);
  886.   var temp:anystr;
  887.   begin
  888.     temp[0]:=chr(n);
  889.     fillchar (temp[1],n,k);
  890.     nobreak:=true;
  891.     write (temp)
  892.   end;
  893.  
  894.   procedure superbackspace (r1:integer);
  895.   var cnt,n:integer;
  896.   begin
  897.     n:=0;
  898.     for cnt:=r1 to p do
  899.       if input[cnt]=^Q
  900.         then n:=n-1
  901.         else n:=n+1;
  902.     if n<0 then sendit (' ',-n) else begin
  903.       sendit (^H,n);
  904.       sendit (' ',n);
  905.       sendit (^H,n)
  906.     end;
  907.     p:=r1-1
  908.   end;
  909.  
  910.   procedure cancelent;
  911.   begin
  912.     superbackspace (1)
  913.   end;
  914.  
  915.   function findspace:integer;
  916.   var s:integer;
  917.   begin
  918.     s:=p;
  919.     while (input[s]<>' ') and (s>0) do s:=s-1;
  920.     findspace:=s
  921.   end;
  922.  
  923.   procedure wrapaword (q:char);
  924.   var s:integer;
  925.   begin
  926.     done:=true;
  927.     if q=' ' then exit;
  928.     s:=findspace;
  929.     if s=0 then exit;
  930.     wrapped:=true;
  931.     wordtowrap:=copy(input,s+1,255)+q;
  932.     superbackspace (s)
  933.   end;
  934.  
  935.   procedure deleteword;
  936.   var s,n:integer;
  937.   begin
  938.     if p=0 then exit;
  939.     s:=findspace;
  940.     if s<>0 then s:=s-1;
  941.     n:=p-s;
  942.     p:=s;
  943.     sendit (^H,n);
  944.     sendit (' ',n);
  945.     sendit (^H,n)
  946.   end;
  947.  
  948.   procedure addchar (k:char);
  949.   begin
  950.     if p<buflen
  951.       then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
  952.         then begin
  953.          p:=p+1;
  954.          input[p]:=k;
  955.          if echodot then begin
  956.           writechar (dotchar);
  957.           if splitmode then write (usr,k)
  958.          end
  959.          else writechar (k)
  960.         end
  961.       else
  962.     else if wordwrap then wrapaword (k)
  963.   end;
  964.  
  965.   procedure addcharnoecho (k:char);
  966.   begin
  967.     if p<buflen
  968.       then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
  969.         then begin
  970.          p:=p+1;
  971.          input[p]:=k;
  972.          if echodot then begin
  973.          {writechar (dotchar);}
  974.           if splitmode then {write (usr,k)}
  975.          end
  976.          else {writechar (k)}
  977.         end
  978.       else
  979.     else if wordwrap then wrapaword (k)
  980.   end;
  981.  
  982.   procedure repeatent;
  983.   var cnt:integer;
  984.   begin
  985.     for cnt:=1 to length(oldinput) do addchar (oldinput[cnt])
  986.   end;
  987.  
  988.   procedure tab;
  989.   var n,c:integer;
  990.   begin
  991.     n:=(p+8) and 248;
  992.     if n>buflen then n:=buflen;
  993.     for c:=1 to n-p do addchar (' ')
  994.   end;
  995.  
  996.   procedure getinput;
  997.     begin
  998.     oldinput:=input;
  999.     ingetstr:=true;
  1000.     done:=false;
  1001.     slash:=false;
  1002.     number:=false;
  1003.     bottomline;
  1004.     if splitmode and echodot then top;
  1005.     p:=0;
  1006.     repeat
  1007.       clearbreak;
  1008.       nobreak:=true;
  1009.       k:=getinputchar;
  1010.       if hungupon then begin
  1011.         input:='';
  1012.         k:=#13;
  1013.         done:=true
  1014.       end;
  1015.       case k of
  1016.         ^I:tab;
  1017.         ^H:bkspace;
  1018.         ^M:done:=true;
  1019.         ^R:repeatent;
  1020.         ^X,#27:cancelent;
  1021.         ^W:deleteword;
  1022.         ' '..'~':addchar (k);
  1023.         ^Q:if wordwrap and bkspinmsgs then addchar (k);
  1024.         ^A:usermacro ('A');
  1025.         ^D:usermacro ('D');
  1026.         ^F:usermacro ('F');
  1027.       end;
  1028.       if (urec.menutype=1) and (atmenu) and (k in ['0'..'9']) then
  1029.       begin
  1030.        number:=true;
  1031.       end;
  1032.       if (urec.menutype=1) and (atmenu) and (k='/') then begin
  1033.        slash:=true;
  1034.       end;
  1035.       if requestchat1 then begin
  1036.         p:=0;
  1037.         writeln (^B^N^M^M^B);
  1038.         chat1 (requestcom);
  1039.         write (^B^M^M^P,lastprompt);
  1040.         requestchat1:=false;
  1041.       end;
  1042.       if requestchat2 then begin
  1043.         p:=0;
  1044.         writeln (^B^N^M^M^B);
  1045.         chat2 (requestcom);
  1046.         write (^B^M^M^P,lastprompt);
  1047.         requestchat2:=false;
  1048.       end;
  1049.       if (urec.menutype=1) and (atmenu) and (not slash) and (not number)
  1050.       then begin done:=true end;
  1051.     until done;
  1052.     writeln;
  1053.     if splitmode and echodot then begin
  1054.       writeln (usr);
  1055.       bottom
  1056.     end;
  1057.     ingetstr:=false;
  1058.     ansireset
  1059.   end;
  1060.  
  1061.   procedure onekeyinput;
  1062.   var timele:integer;
  1063.   begin
  1064.     oldinput:=input;
  1065.     ingetstr:=true;
  1066.     done:=false;
  1067.     slash:=false;
  1068.     bottomline;
  1069.     if splitmode and echodot then top;
  1070.     p:=0;
  1071.     repeat
  1072.       clearbreak;
  1073.       nobreak:=true;
  1074.       k:=getinputchar;
  1075.       if hungupon then begin
  1076.         input:='';
  1077.         k:=#13;
  1078.         done:=true
  1079.       end;
  1080.       case k of
  1081.         ^I:tab;
  1082.         ^H:addcharnoecho (^H);
  1083.         ^M:addcharnoecho (^M);
  1084.         ^R:{repeatent};
  1085.         ^X,#27:cancelent;
  1086.         ^W:deleteword;
  1087.         ' '..'~':addcharnoecho (k);
  1088.         ^Q:if wordwrap and bkspinmsgs then addchar (k);
  1089.       end;
  1090.       done:=true;
  1091.       if (urec.menutype=1) and (atmenu) and (k='/') then begin
  1092.        slash:=true;
  1093.       end;
  1094.       if requestchat1 then begin
  1095.         p:=0;
  1096.         writeln (^B^N^M^M^B);
  1097.         timele:=urec.timetoday;
  1098.         chat1 (requestcom);
  1099.         write (^B^M^M^P,lastprompt);
  1100.         requestchat1:=false;
  1101.         urec.timetoday:=timele
  1102.       end;
  1103.       if requestchat2 then begin
  1104.         p:=0;
  1105.         writeln (^B^N^M^M^B);
  1106.         timele:=urec.timetoday;
  1107.         chat2 (requestcom);
  1108.         write (^B^M^M^P,lastprompt);
  1109.         requestchat2:=false;
  1110.         urec.timetoday:=timele
  1111.       end;
  1112.       if (urec.menutype=1) and (atmenu) and (not slash) then done:=true
  1113.     until done;
  1114.     if splitmode and echodot then begin
  1115.       writeln (usr);
  1116.       bottom
  1117.     end;
  1118.     ingetstr:=false;
  1119.     ansireset
  1120.   end;
  1121.  
  1122.   procedure onekeyinputii;
  1123.   begin
  1124.     oldinput:=input;
  1125.     ingetstr:=true;
  1126.     done:=false;
  1127.     slash:=false;
  1128.     bottomline;
  1129.     if splitmode and echodot then top;
  1130.     p:=0;
  1131.     repeat
  1132.       clearbreak;
  1133.       nobreak:=true;
  1134.       k:=getinputchar;
  1135.       if hungupon then begin
  1136.         input:='';
  1137.         k:=#13;
  1138.         done:=true
  1139.       end;
  1140.       case k of
  1141.         ^I:tab;
  1142.         ^H:addcharnoecho (^H);
  1143.         ^M:addcharnoecho (^M);
  1144.         ^X,#27:cancelent;
  1145.         ^W:deleteword;
  1146.         ' '..'~':addcharnoecho (k);
  1147.         ^Q:if wordwrap and bkspinmsgs then addchar (k);
  1148.       end;
  1149.       done:=true;
  1150.     until done;
  1151.     if splitmode and echodot then begin
  1152.       writeln (usr);
  1153.       bottom
  1154.     end;
  1155.     ingetstr:=false;
  1156.     ansireset
  1157.   end;
  1158.  
  1159.   procedure divideinput;
  1160.   var p:integer;
  1161.   begin
  1162.     p:=pos(',',input);
  1163.     if p=0 then exit;
  1164.     addtochain (copy(input,p+1,255)+#13);
  1165.     input[0]:=chr(p-1)
  1166.   end;
  1167.  
  1168. begin
  1169.   che;
  1170.   clearbreak;
  1171.   linecount:=1;
  1172.   wrapped:=false;
  1173.   nochain:=nochain or wordwrap;
  1174.   ansicolor (urec.inputcolor);
  1175.   if mode=1 then getinput else
  1176.   if mode=2 then onekeyinput else
  1177.   if mode=3 then onekeyinputii;
  1178.   if not nochain then divideinput;
  1179.   while input[length(input)]=' ' do input[0]:=pred(input[0]);
  1180.   if (not wordwrap) and (mode<2) then
  1181.     while (length(input)>0) and (input[1]=' ') do delete (input,1,1);
  1182.   if wrapped then chainstr:=wordtowrap;
  1183.   wordwrap:=false;
  1184.   nochain:=false;
  1185.   beginwithspacesok:=false;
  1186.   echodot:=false;
  1187.   buflen:=80;
  1188.   linecount:=1
  1189. end;
  1190.  
  1191. procedure writestr (s:anystr);
  1192. var k:char;
  1193.     ex:boolean;
  1194. begin
  1195.   che;
  1196.   clearbreak;
  1197.   ansireset;
  1198.   uselinefeeds:=linefeeds in urec.config;
  1199.   usecapsonly:=not (lowercase in urec.config);
  1200.   k:=s[length(s)];
  1201.   s:=copy(s,1,length(s)-1);
  1202.   case k of
  1203.     ':':begin
  1204.           write (^P,s,': ');
  1205.           lastprompt:=s+': ';
  1206.           getstr (1)
  1207.         end;
  1208.     ';':write (s);
  1209.     '*':begin
  1210.           write (^P,s);
  1211.           lastprompt:=s;
  1212.           getstr (1)
  1213.         end;
  1214.     '@':begin
  1215.           write (^P,s);
  1216.           lastprompt:=s;
  1217.           getstr (2)
  1218.         end;
  1219.     '&':begin
  1220.           nochain:=true;
  1221.           write (^P,s);
  1222.           lastprompt:=s;
  1223.           getstr (1)
  1224.         end
  1225.     else writeln (s,k)
  1226.   end;
  1227.   clearbreak
  1228. end;
  1229.  
  1230. procedure printxy (x,y:integer; str:anystr);
  1231. var dum1,dum2:string;
  1232. begin
  1233.  writestr(#27+'['+strr(y)+';'+strr(x)+'f'+^S+str+^R);
  1234. end;
  1235.  
  1236. procedure printxy2 (x,y:integer; str:anystr);
  1237. var dum1,dum2:string;
  1238. begin
  1239.  writestr(#27+'['+strr(y)+';'+strr(x)+'f'+str);
  1240. end;
  1241.  
  1242. procedure cls;
  1243. begin
  1244.   bottom;
  1245.   clrscr;
  1246.   bottomline
  1247. end;
  1248.  
  1249. procedure writehdr (q:anystr);
  1250. var cnt,cnt2,x,xx,y,yy,z,zz,m2:integer;
  1251. const l=40;
  1252. begin
  1253.    if (asciigraphics in urec.config) then begin
  1254.    writeln (^B^M);
  1255.    write (^R'                 '^X'┌');
  1256.    for x:=1 to (l-length(q)) div 2 do write (^X'─');
  1257.    for z:=1 to length(q) do write (^X'─');
  1258.    for xx:=1 to (l-length(q)) div 2 do write (^X'─');
  1259.    writeln (^X'╖'^R);
  1260.    write (^R'                 '^X'│');
  1261.    ansicolor (urec.bstatuscolor);
  1262.    for cnt:=1 to (l-length(q)) div 2 do write (^Y' ');
  1263.    write (^Y+q,^B);
  1264.    m2:=(l-length(q)) div 2;
  1265.    m2:=m2+length(q);
  1266.    m2:=l-m2;
  1267.    if (length(q) mod 2)<>0 then m2:=m2-1;
  1268.    for cnt2:=1 to m2 do write (' ');
  1269.    writeln (^X'║'^R);
  1270.    write (^R'                 '^X'╘');
  1271.    for y:=1 to (l-length(q)) div 2 do write (^X'═');
  1272.    for zz:=1 to length(q) do write (^X'═');
  1273.    for yy:=1 to (l-length(q)) div 2 do write (^X'═');
  1274.    writeln (^X'╝'^R);
  1275.    writeln;
  1276.   end
  1277.  else
  1278.   begin
  1279.    writeln (^B^M);
  1280.    ansicolor (urec.bordercolor);
  1281.    write (^X'                 +');
  1282.    for x:=1 to (l-length(q)) div 2 do write (^X'=');
  1283.    for z:=1 to length(q) do write (^X'=');
  1284.    for xx:=1 to (l-length(q)) div 2 do write (^X'=');
  1285.    writeln (^X'+');
  1286.    write (^X'                 |');
  1287.    ansicolor (urec.bstatuscolor);
  1288.    for cnt:=1 to (l-length(q)) div 2 do write (^Y' ');
  1289.    write (^Y+q,^B);
  1290.    m2:=(l-length(q)) div 2;
  1291.    m2:=m2+length(q);
  1292.    m2:=l-m2;
  1293.    if (length(q) mod 2)<>0 then m2:=m2-1;
  1294.    for cnt2:=1 to m2 do write (' ');
  1295.    writeln (^X'|');
  1296.    write (^X'                 +');
  1297.    for y:=1 to (l-length(q)) div 2 do write (^X'=');
  1298.    for zz:=1 to length(q) do write (^X'=');
  1299.    for yy:=1 to (l-length(q)) div 2 do write (^X'=');
  1300.    writeln (^X'+'^R);
  1301.    writeln;
  1302.   end;
  1303. end;
  1304.  
  1305. function issysop:boolean;
  1306. begin
  1307.   issysop:=(ulvl>=sysoplevel) or (cursection in urec.config)
  1308. end;
  1309.  
  1310. {function islz:boolean;
  1311. begin
  1312.   if (unam=xxxa) or (unam=xxxb) then islz:=true;
  1313. end;}
  1314.  
  1315. procedure reqlevel (l:integer);
  1316. begin
  1317.   writeln (^B'Level ',l,' is required for that!')
  1318. end;
  1319.  
  1320. procedure printfile (fn:lstr);
  1321.  
  1322.   procedure getextension (var fname:lstr);
  1323.  
  1324.     procedure tryfiles (a,b,c,d:integer);
  1325.     var q:boolean;
  1326.  
  1327.       function tryfile (n:integer):boolean;
  1328.       const exts:array [1..4] of string[3]=('','ANS','ASC','40');
  1329.       begin
  1330.         if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
  1331.           tryfile:=true;
  1332.           fname:=fname+'.'+exts[n]
  1333.         end
  1334.       end;
  1335.  
  1336.     begin
  1337.       if tryfile (a) then exit;
  1338.       if tryfile (b) then exit;
  1339.       if tryfile (c) then exit;
  1340.       q:=tryfile (d)
  1341.     end;
  1342.  
  1343.   begin
  1344.     if pos ('.',fname)<>0 then exit;
  1345.     if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
  1346.     if asciigraphics in urec.config then tryfiles (3,1,4,2) else
  1347.     if eightycols in urec.config    then tryfiles (1,4,3,2) else
  1348.                                          tryfiles (4,1,3,2)
  1349.   end;
  1350.  
  1351. var tf:text;
  1352.     k:char;
  1353. begin
  1354.   clearbreak;
  1355.   writeln;
  1356.   getextension (fn);
  1357.   assign (tf,fn);
  1358.   reset (tf);
  1359.   iocode:=ioresult;
  1360.   if iocode<>0 then begin
  1361.     fileerror ('Printfile',fn);
  1362.     exit
  1363.   end;
  1364.   clearbreak;
  1365.   while not (eof(tf) or break or hungupon) do
  1366.     begin
  1367.       read (tf,k);
  1368.       write (k)
  1369.     end;
  1370.   if break then writeln (^B);
  1371.   writeln;
  1372.   textclose (tf);
  1373.   curattrib:=0;
  1374.   ansireset
  1375. end;
  1376.  
  1377. procedure show_all_info (fn:lstr;dernier:mstr;nombre:integer);
  1378.  
  1379.   procedure getextension (var fname:lstr);
  1380.  
  1381.     procedure tryfiles (a,b,c,d:integer);
  1382.     var q:boolean;
  1383.  
  1384.       function tryfile (n:integer):boolean;
  1385.       const exts:array [1..4] of string[3]=('','ANS','ASC','40');
  1386.       begin
  1387.         if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
  1388.           tryfile:=true;
  1389.           fname:=fname+'.'+exts[n]
  1390.         end
  1391.       end;
  1392.  
  1393.     begin
  1394.       if tryfile (a) then exit;
  1395.       if tryfile (b) then exit;
  1396.       if tryfile (c) then exit;
  1397.       q:=tryfile (d)
  1398.     end;
  1399.  
  1400.   begin
  1401.     if pos ('.',fname)<>0 then exit;
  1402.     if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
  1403.     if asciigraphics in urec.config then tryfiles (3,1,4,2) else
  1404.     if eightycols in urec.config    then tryfiles (1,4,3,2) else
  1405.                                          tryfiles (4,1,3,2)
  1406.   end;
  1407.  
  1408. var tf:text;
  1409.     k:char;
  1410.     udr,pcr:real;
  1411.     deux:char;
  1412.     mp:boolean;
  1413.     avrcps:longint;
  1414.     nmsgs,nfiles,ngfiles,ndbases:integer;
  1415. begin
  1416.   mp:=moreprompts in urec.config;
  1417.   if mp then urec.config:=urec.config-[moreprompts];
  1418.   clearbreak;
  1419.   writeln;
  1420.   getextension (fn);
  1421.   assign (tf,fn);
  1422.   reset (tf);
  1423.   iocode:=ioresult;
  1424.   if iocode<>0 then begin
  1425.     fileerror ('Printfile',fn);
  1426.     exit
  1427.   end;
  1428.   clearbreak;
  1429.   while not (eof(tf) or break or hungupon) do
  1430.     begin
  1431.       deux:=k;
  1432.       read (tf,k);
  1433.       if k='@' then
  1434.       begin
  1435.          read(tf,k);
  1436.          if k='B' then
  1437.          begin
  1438.             ndbases:=(dbases-urec.lastdbases);
  1439.             if ndbases<1 then write('None') else write(strr(ndbases));
  1440.          end
  1441.          else
  1442.          if k='C' then write(dernier) else
  1443.          if (k='D') then
  1444.          begin
  1445.             xlaston:=laston;
  1446.             subs1.laston:=laston;
  1447.             laston:=now;
  1448.             if urec.laston<>0 then write(datestr(laston))
  1449.             else write('Never');
  1450.          end
  1451.          else
  1452.          if k='d' then
  1453.          begin
  1454.             xlaston:=laston;
  1455.             subs1.laston:=laston;
  1456.             laston:=now;
  1457.             if urec.laston<>0 then write(timestr(laston))
  1458.             else write('Never');
  1459.          end
  1460.          else
  1461.          if k='E' then
  1462.          begin
  1463.             nombre:=getnummail(unum);
  1464.             if nombre < 1 then write('None') else
  1465.             write(strr(nombre));
  1466.          end
  1467.          else
  1468.          if k='F' then
  1469.          begin
  1470.             nfiles:=(ups-urec.lastups);
  1471.             if nfiles<1 then write('None') else write(strr(nfiles));
  1472.          end
  1473.          else
  1474.          if k='G' then
  1475.          begin
  1476.             ngfiles:=(gfilez-urec.lastgfiles);
  1477.             if ngfiles<1 then write('None') else write(strr(ngfiles));
  1478.          end
  1479.          else
  1480.          if k='g' then write(strr(urec.gflevel)) else
  1481.          if k='H' then write(unam) else
  1482.          if k='h' then
  1483.          begin
  1484.             if urec.hack=0 then write('None')
  1485.             else write (strr(urec.hack));
  1486.             urec.hack:=0;
  1487.          end
  1488.          else
  1489.          if k='i' then write(cliche) else
  1490.          if k='L' then write(strr(urec.level)) else
  1491.          if k='M' then
  1492.          begin
  1493.             nmsgs:=(messages-urec.lastmessages);
  1494.             if nmsgs<1 then write('None') else write(strr(nmsgs));
  1495.          end
  1496.          else
  1497.          if k='N' then write(urec.note)
  1498.          else
  1499.          if k='Q' then
  1500.          begin
  1501.             calcqr;
  1502.             write(strr(qr));
  1503.          end
  1504.          else
  1505.          if k='p' then write(urec.password) else
  1506.          if k='T' then write(streal(urec.totaltime)) else
  1507.          if k='t' then write(urec.timetoday) else
  1508.          if k='#' then begin
  1509.          if urec.numon>0 then write(strr(urec.numon)) else
  1510.          write(strr(0)) end else
  1511.          if k='1' then
  1512.          begin
  1513.             if (urec.defcon[1]) and (length(confm[1])>0) then write (confm[1]) else write (''); end else
  1514.          if k='2' then
  1515.          begin
  1516.             if (urec.defcon[2]) and (length(confm[2])>0) then write (confm[2]) else write (''); end else
  1517.          if k='3' then
  1518.          begin
  1519.             if (urec.defcon[3]) and (length(confm[3])>0) then write (confm[3]) else write (''); end else
  1520.          if k='4' then
  1521.          begin
  1522.             if (urec.defcon[4]) and (length(confm[4])>0) then write (confm[4]) else write (''); end else
  1523.          if k='5' then
  1524.          begin
  1525.             if (urec.defcon[5]) and (length(confm[5])>0) then write (confm[5]) else write (''); end else
  1526.          if k='6' then
  1527.          begin
  1528.             if (urec.defcon[6]) and (length(confx[1])>0) then write (confx[1]) else write (''); end else
  1529.          if k='7' then
  1530.          begin
  1531.             if (urec.defcon[7]) and (length(confx[2])>0) then write (confx[2]) else write (''); end else
  1532.          if k='8' then
  1533.          begin
  1534.             if (urec.defcon[8]) and (length(confx[3])>0) then write (confx[3]) else write (''); end else
  1535.          if k='9' then
  1536.          begin
  1537.             if (urec.defcon[9]) and (length(confx[4])>0) then write (confx[4]) else write (''); end else
  1538.          if k='0' then
  1539.          begin
  1540.             if (urec.defcon[10]) and (length(confx[5])>0) then write (confx[5]) else write (''); end else
  1541.          if k='l' then write(strr(urec.udlevel)) else
  1542.          if k='f' then begin if leechweek then write('N/A') else
  1543.          write(strr(urec.udpoints)) end else
  1544.          if k='U' then write(strr(urec.uploads)) else
  1545.          if k='W' then write(strr(urec.downloads)) else
  1546.          if k='u' then write(streal(urec.upk/1024)+'k') else
  1547.          if k='w' then write(streal(urec.downk/1024) +'k') else
  1548.          if k='R' then begin
  1549.            if urec.downloads > 0 then udr:=(urec.uploads div urec.downloads)*100 else
  1550.                                       udr:=(urec.uploads)*100;
  1551.            write (streal(udr)+'%'); end else
  1552.          if k='r' then begin
  1553.            if urec.numon>0 then pcr:=(urec.nbu div urec.numon) * 100 else
  1554.            pcr:=0.00;
  1555.            write (streal(pcr)+'%'); end else
  1556.          if k='P' then write (strr(urec.nbu)) else
  1557.          if k='A' then begin
  1558.            avrcps:=baudrate div 10; write (avrcps); end else
  1559.          begin
  1560.             write (deux);
  1561.             write (k);
  1562.          end;
  1563.       end (* If k='^' *)
  1564.       else
  1565.       write (k)
  1566.     end; (* While not *)
  1567.   urec.hack:= 0;
  1568.   subs1.laston:=urec.laston;
  1569.   urec.laston:=now;
  1570.   if break then writeln (^B);
  1571.   writeln;
  1572.   textclose (tf);
  1573.   curattrib:=0;
  1574.   ansireset;
  1575.   if mp then urec.config:=urec.config+[moreprompts]
  1576. end;
  1577.  
  1578. procedure printtexttopoint (var tf:text);
  1579. var l:lstr;
  1580. begin
  1581.   l:='';
  1582.   clearbreak;
  1583.   while not (eof(tf) or hungupon) and (l<>'.') do begin
  1584.     if not break then writeln (l);
  1585.     readln (tf,l)
  1586.   end
  1587. end;
  1588.  
  1589. procedure skiptopoint (var tf:text);
  1590. var l:lstr;
  1591. begin
  1592.   l:='';
  1593.   while not eof(tf) and (l<>'.') do
  1594.     readln (tf,l)
  1595. end;
  1596.  
  1597. function minstr (blocks:integer):sstr;
  1598. var min,sec:integer;
  1599.     rsec:real;
  1600.     ss:sstr;
  1601. begin
  1602.   rsec:=1.38 * blocks * (1200/baudrate);
  1603.   min:=trunc (rsec/60.0);
  1604.   sec:=trunc (rsec-(min*60.0));
  1605.   ss:=strr(sec);
  1606.   if length(ss)<2 then ss:='0'+ss;
  1607.   minstr:=strr(min)+':'+ss
  1608. end;
  1609.  
  1610. procedure parserange (numents:integer; var f,l:integer);
  1611. var rf,rl:mstr;
  1612.     p,v1,v2:integer;
  1613. begin
  1614.   f:=0;
  1615.   l:=0;
  1616.   if numents<1 then exit;
  1617.   repeat
  1618.     writestr ('Range [1-'+strr(numents)+'] [CR/All] [?/Help]:');
  1619.     if input='?' then printfile (textfiledir+'Rangehlp');
  1620.     if (length(input)>0) and (upcase(input[1])='Q') then exit
  1621.   until (input<>'?') or hungupon;
  1622.   if hungupon then exit;
  1623.   if length(input)=0 then begin
  1624.     f:=1;
  1625.     l:=numents
  1626.   end else begin
  1627.     p:=pos('-',input);
  1628.     v1:=valu(copy(input,1,p-1));
  1629.     v2:=valu(copy(input,p+1,255));
  1630.     if p=0 then begin
  1631.       f:=v2;
  1632.       l:=v2
  1633.     end else if p=1 then begin
  1634.       f:=1;
  1635.       l:=v2
  1636.     end else if p=length(input) then begin
  1637.       f:=v1;
  1638.       l:=numents
  1639.     end else begin
  1640.       f:=v1;
  1641.       l:=v2
  1642.     end
  1643.   end;
  1644.   if (f<1) or (l>numents) or (f>l) then begin
  1645.     f:=0;
  1646.     l:=0;
  1647.     writestr ('Invalid range!')
  1648.   end;
  1649.   writeln (^B)
  1650. end;
  1651.  
  1652. function menutype:integer;
  1653. begin
  1654.  menutype:=0;
  1655.  if urec.menutype=0 then menutype:=0 else
  1656.  if urec.menutype=1 then menutype:=1;
  1657. end;
  1658.  
  1659. function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
  1660. var k:char;
  1661.     sysmenu,percent,needsys:boolean;
  1662.     z,n,p,i,utime:integer;
  1663.     prompt:anystr;
  1664.  
  1665. procedure write_time;
  1666. var hour,minute,second,sec100:word;am:boolean;
  1667. begin
  1668.  gettime(hour,minute,second,sec100);
  1669.  if hour<10 then write('0');
  1670.  am:=true;
  1671.  if hour>12 then
  1672.  begin
  1673.   am:=false;
  1674.   hour:=hour-12;
  1675.  end;
  1676.  write(hour);
  1677.  write(':');
  1678.  if minute<10 then write('0');
  1679.  write(minute);
  1680.  if am then write(' am') else write(' pm');
  1681. end;
  1682. procedure write_date;
  1683. var year,month,day,dow:word;
  1684. begin
  1685.  getdate(year,month,day,dow);
  1686.  if month<12 then write('0');
  1687.  write(month,'/');
  1688.  if day<12 then write('0');
  1689.  write(day,'/');
  1690.  year:=year-1900;
  1691.  if year<10 then write('0');
  1692.  write(year);
  1693. end;
  1694.  
  1695. procedure we(s:string);
  1696.     begin
  1697.      write(#27+'['+s+'m');
  1698.     end;
  1699.  
  1700. procedure do_me(k_me:string);
  1701. begin
  1702.        if k_me='00' then we('0;30') else
  1703.        if k_me='01' then we('0;34') else
  1704.        if k_me='02' then we('0;32') else
  1705.        if k_me='03' then we('0;36') else
  1706.        if k_me='04' then we('0;31') else
  1707.        if k_me='05' then we('0;35') else
  1708.        if k_me='06' then we('0;33') else
  1709.        if k_me='07' then we('0;37') else
  1710.        if k_me='08' then we('1;30') else
  1711.        if k_me='09' then we('1;34') else
  1712.        if k_me='10' then we('1;32') else
  1713.        if k_me='11' then we('1;36') else
  1714.        if k_me='12' then we('1;31') else
  1715.        if k_me='13' then we('1;35') else
  1716.        if k_me='14' then we('1;33') else
  1717.        if k_me='15' then we('1;37') else
  1718.        if k_me='B0' then we('40') else
  1719.        if k_me='B1' then we('44') else
  1720.        if k_me='B2' then we('42') else
  1721.        if k_me='B3' then we('46') else
  1722.        if k_me='B4' then we('41') else
  1723.        if K_me='B5' then we('45') else
  1724.        if K_me='B6' then we('43') else
  1725.        if K_me='B7' then we('47') else
  1726.        if k_me='CT' then write_time else
  1727.        if k_me='CD' then write_date else
  1728.  
  1729.        write('|'+k_me);
  1730. end;
  1731.  
  1732. procedure prompt_write(b:Byte;s:string);
  1733. var i:integer;s2:string[2];
  1734. begin
  1735.  i:=1;
  1736.  if length(s)<1 then begin
  1737.   writeln;
  1738.   exit;
  1739.  end;
  1740.  write(#27+'[0m');
  1741.  repeat
  1742.   if s[i]='^' then begin
  1743.    s2:=copy(s,i+1,2);
  1744.    if s2 = 'CP' then write (mname) else
  1745.    if s2 = 'TL' then write (timeleft) else
  1746.    if s2= 'UH' then write (urec.handle) else
  1747.    do_me(s2);
  1748.    i:=i+3;
  1749.   end else begin
  1750.    write(s[i]);
  1751.    inc(i);
  1752.   end;
  1753.  until i > length(s);
  1754.  if (b=3) or (prompt[b+1]='') then writestr ('*') else
  1755.  writeln;
  1756. end;
  1757.  
  1758. begin
  1759.   utime:=timeleft;
  1760.   prompt:=promptformat+promptformat1;
  1761.   sysmenu:=false;
  1762.   percent:=false;
  1763.   atmenu:=true;
  1764.   for p:=1 to length(choices)-1 do
  1765.     if choices[p]='%'
  1766.       then if choices[p+1]='@'
  1767.         then percent:=true
  1768.         else
  1769.       else if choices[p+1]='@'
  1770.         then sysmenu:=true;
  1771.   writeln (^B);
  1772.   repeat
  1773.     if chatmode then begin
  1774.       write(^R'Paging Sysop'^S);
  1775.       write(^S^G^G^G^G'.');
  1776.       delay(50);
  1777.       write(^S^G^G^G^G'.');
  1778.       delay(50);
  1779.       write(^S^G^G^G^G'.');
  1780.       delay(50);
  1781.       write(^S^G^G^G^G'.');
  1782.       delay(50);
  1783.       writeln(^S^G^G^G^G'.'^R);
  1784.      {for n:=1 to 3 do summonbeep} end;
  1785.     if (timeleft=10) then writehdr ('You have 10 minutes left.');
  1786.     if (timeleft=5) then Writehdr ('You have 5 minutes left.');
  1787.     if (timeleft=2) then Writehdr ('You have 2 minutes left.');
  1788.     if (timeleft=1) then Writehdr ('You have 1 minute left.');
  1789.     if (timeleft<1) or (timetillevent<=3) then begin
  1790.       if exist (textfiledir+'Timesup') then
  1791.       printfile (textfiledir+'Timesup') else
  1792.       begin
  1793.        writeln;
  1794.        writeln ('Sorry, your time''s up for today!');
  1795.        writeln;
  1796.       end;
  1797.       forcehangup:=true;
  1798.       menu:=0;
  1799.       exit
  1800.     end;
  1801.    {if showtime in urec.config
  1802.      then prompt:=^P+'['^R+strr(timeleft)+^P' - '
  1803.      else prompt:='';
  1804.     prompt:=prompt+^P'['^R+mname+^P' - '^R'?'^P'/'^R'Help'^P']'^S': '^U'*';}
  1805.     replace (prompt,'^1',mname+' Section');
  1806.     replace (prompt,'^2',strr(utime));
  1807.     replace (prompt,'^01',^P);
  1808.     replace (prompt,'^02',^U);
  1809.     replace (prompt,'^03',^R);
  1810.     replace (prompt,'^04',^S);
  1811.     replace (prompt,'^05',^X);
  1812.     replace (prompt,'^06',^Y);
  1813.     replace (prompt,'^07',^M);
  1814.     replace (prompt,'^08',datestr (now));
  1815.     replace (prompt,'^09',timestr (now));
  1816.     writestr (prompt+^U'*');
  1817.     {for z:=1 to 3 do
  1818.     if prompt[z]='' then else prompt_write(z,prompt[z]);}
  1819.     utime:=timeleft;
  1820.     prompt:=promptformat+promptformat1;
  1821.     n:=0;
  1822.     if length(input)=0
  1823.       then k:='_'
  1824.       else
  1825.         begin
  1826.       if match(input,'/OFF') or match(input,'/O') then begin
  1827.             forcehangup:=true;
  1828.             menu:=0;
  1829.             exit
  1830.           end;
  1831.           {if match(input,'-') then begin
  1832.             quickmenu;
  1833.           end;}
  1834.           n:=valu(input);
  1835.           if n>0
  1836.             then k:='#'
  1837.             else k:=upcase(input[1])
  1838.         end;
  1839.     p:=1;
  1840.     i:=1;
  1841. {    if k='?'
  1842.       then
  1843.         begin
  1844.           printfile (textfiledir+mfn+'M');
  1845.           if sysmenu and issysop then printfile (textfiledir+mfn+'S')
  1846.         end
  1847.       else }
  1848.         while p<=length(choices) do begin
  1849.           needsys:=false;
  1850.           if p<length(choices)
  1851.             then if choices[p+1]='@'
  1852.               then needsys:=true;
  1853.           if upcase(choices[p])=k
  1854.             then if needsys and (not issysop)
  1855.               then
  1856.                 begin
  1857.                   reqlevel (sysoplevel);
  1858.                   p:=255;
  1859.                   needsys:=false
  1860.                 end
  1861.               else p:=256
  1862.             else
  1863.               begin
  1864.                 p:=p+1;
  1865.                 if needsys then p:=p+1;
  1866.                 i:=i+1
  1867.               end
  1868.         end;
  1869.   until (p=256) or hungupon;
  1870.   writeln (^B);
  1871.   if hungupon
  1872.     then menu:=0
  1873.     else
  1874.       if k='#' then menu:=-n else menu:=i;
  1875.   atmenu:=false
  1876. end;
  1877.  
  1878. procedure menuname (menunme:lstr);
  1879. var ii:integer;
  1880. begin
  1881.              cursor (false);
  1882.              clearscr;
  1883.              if asciigraphics in urec.config then begin
  1884.              printxy2(1,1,^P+'┌'); for ii:=2 to 79 do printxy2 (ii,1,^P+'─');
  1885.              printxy2(80,1,^P+'┐');
  1886.              for ii:=2 to 20 do begin printxy2(1,ii,^P+'│');
  1887.                                       printxy2(80,ii,^P+'│');
  1888.                                       end;
  1889.              printxy2 (1,21,^P+'└'); for ii:=2 to 79 do printxy2 (ii,21,^P+'─');
  1890.              printxy2 (80,21,^P+'┘') end else begin
  1891.              printxy2(1,1,^P+'+'); for ii:=2 to 79 do printxy2 (ii,1,^P+'-');
  1892.              printxy2(80,1,^P+'+');
  1893.              for ii:=2 to 20 do begin printxy2(1,ii,^P+'|');
  1894.                                       printxy2(80,ii,^P+'|');
  1895.                                       end;
  1896.              printxy2 (1,21,^P+'+'); for ii:=2 to 79 do printxy2 (ii,21,^P+'-');
  1897.              printxy2 (80,21,^P+'+'); end;
  1898.              printxy2 (10,1,^P+'[ '+^R+'FAQ '+ver+' '+^P+'- '+^S+menunme+^P+' ]');
  1899. end;
  1900.  
  1901. function getpassword:boolean;
  1902. var t,gog,p:sstr;
  1903.     c:char;
  1904.     frm,yiyiyi,ii:integer;
  1905. begin
  1906.   echodot:=true;
  1907.   buflen:=15;
  1908.   getpassword:=false;
  1909.   getstr (1);
  1910.   gog:=input;
  1911.   p:='';
  1912.   t:='';
  1913.   frm:=6;
  1914.   if gog='' then begin
  1915.    randomize;
  1916.    for yiyiyi:=1 to frm do begin
  1917.     ii:=random(36);
  1918.     if ii<10 then c:=chr(ord('0')+ii)
  1919.      else c:=chr(ord('A')+ii-10);
  1920.     gog:=gog+c;
  1921.    end;
  1922.   end;
  1923. {  repeat
  1924.     frm:=random (15);
  1925.    until frm in [6..10];
  1926.    writeln ('frm:',frm);
  1927.    for yiyiyi:=1 to frm do
  1928.    begin
  1929.     repeat
  1930.      c[yiyiyi]:=chr(random(90));
  1931.     until c[yiyiyi] in ['0'..'9','A'..'Z'];
  1932.     writeln ('c[yiyiyi]:'+c[yiyiyi]);
  1933.     p:=p+c[yiyiyi];
  1934.     writeln ('p:'+p);
  1935.    end;
  1936.    gog:=p;
  1937.   end; }
  1938.   begin
  1939.    t:=gog;
  1940.    writeln (^R'Password'^P': '^S+t);
  1941.    echodot:=true;
  1942.    writestr (^R'Re-Enter for verification:');
  1943.    if not match(t,input) then begin
  1944.     writeln ('They don''t match!');
  1945.     getpassword:=hungupon;
  1946.     exit
  1947.    end;
  1948.    urec.password:=t;
  1949.    getpassword:=true
  1950.  end;
  1951.  echodot:=false;
  1952. end;
  1953.  
  1954. function checkpassword (var u:userrec):boolean;
  1955. var tries:integer;
  1956. begin
  1957.   tries:=0;
  1958.   checkpassword:=true;
  1959.   repeat
  1960.     splitscreen (5);
  1961.     top;
  1962.     writeln (usr,'[Password Entry]:');
  1963.     writeln (usr,'[User Name]:          ',u.handle);
  1964.     writeln (usr,'[Password ]:          ',u.password);
  1965.       write (usr,'[Has entered so far]: ');
  1966.     bottom;
  1967.     echodot:=true;
  1968.     writestr (^R'Login Password'^P': '^U'*');
  1969.     unsplit;
  1970.     if hungupon then begin
  1971.       checkpassword:=false;
  1972.       exit
  1973.     end;
  1974.     if match(input,u.password)
  1975.       then exit
  1976.       else tries:=tries+1;
  1977.       writelog(0,6,unam+input);
  1978.   until tries>3;
  1979.   checkpassword:=false
  1980. end;
  1981.  
  1982. procedure getacflag (var ac:accesstype; var tex:mstr);
  1983. begin
  1984.   writestr ('[K]ick off, [B]y level, [L]et in:');
  1985.   ac:=invalid;
  1986.   if length(input)=0 then exit;
  1987.   case upcase(input[1]) of
  1988.     'B':ac:=bylevel;
  1989.     'L':ac:=letin;
  1990.     'K':ac:=keepout
  1991.   end;
  1992.   tex:=accessstr[ac]
  1993. end;
  1994.  
  1995. procedure calcqr;
  1996. begin
  1997.  with urec do begin
  1998.   qr := qrmultifactor*(urec.uploads+urec.nbu)-urec.downloads;
  1999.  end;
  2000. end;
  2001.  
  2002. procedure overlayerror;
  2003. begin
  2004.  if ovrresult <> 0 then begin
  2005.  write ('Overlay Manager Error [',ovrresult,': ');
  2006.  case ovrresult of
  2007.   -1:write ('Overlay Manager Error.]');
  2008.   -2:write ('Overlay File not found.]');
  2009.   -3:write ('Not enough memory.]');
  2010.   -4:write ('I/O Error.]');
  2011.   -5:write ('EMS Driver not installed.]');
  2012.   -6:write ('Not enough EMS memory.]');
  2013.  end;
  2014.  writeln;
  2015.  halt(4);
  2016.  end;
  2017. end;
  2018.  
  2019. function parsedate (date:anystr):lstr;
  2020. var m,d,y,inc,gog:sstr;
  2021.     year,month,day,dayofweek:word;
  2022. begin
  2023.  if length(date)<>8 then begin
  2024.   parsedate:=date;
  2025.   exit;
  2026.  end else
  2027.  begin
  2028.   m:=copy (date,1,2);
  2029.   d:=copy (date,4,2);
  2030.   y:=copy (date,7,2);
  2031.   if m='01' then gog:='Jan.';
  2032.   if m='02' then gog:='Feb.';
  2033.   if m='03' then gog:='Mar.';
  2034.   if m='04' then gog:='Apr.';
  2035.   if m='05' then gog:='May.';
  2036.   if m='06' then gog:='Jun.';
  2037.   if m='07' then gog:='Jul.';
  2038.   if m='08' then gog:='Aug.';
  2039.   if m='09' then gog:='Sep.';
  2040.   if m='10' then gog:='Oct.';
  2041.   if m='11' then gog:='Nov.';
  2042.   if m='12' then gog:='Dec.';
  2043.   getdate (year,month,day,dayofweek);
  2044.   inc:=copy (strr(year),1,2);
  2045.   parsedate:=gog+' '+d+' '+inc+y;
  2046.  end;
  2047. end;
  2048.  
  2049. function ansi:boolean;
  2050. begin
  2051.  if (ansigraphics in urec.config) then ansi:=true else
  2052.   ansi:=false;
  2053. end;
  2054.  
  2055. function ascii:boolean;
  2056. begin
  2057.  if (asciigraphics in urec.config) then ascii:=true else
  2058.   ascii:=false;
  2059. end;
  2060.  
  2061. procedure setmenutype;
  2062. var ockmaster:char;
  2063. begin
  2064.    repeat
  2065.    writestr (^R'Use Hotkeys '^S'[CR/No]: '^U'*');
  2066.    if length(input)=0 then ockmaster:='N' else
  2067.    ockmaster:=upcase(input[1]);
  2068.    until (ockmaster in ['Y','N']) or hungupon;
  2069.    case ockmaster of
  2070.    'Y':urec.menutype:=1;
  2071.    'N':urec.menutype:=0;
  2072.    end;
  2073.    writeurec
  2074. end;
  2075.  
  2076.   Procedure AsciiGotoxy(x,y:Integer);
  2077.     Var a,b,c,d:Integer;
  2078.     Begin
  2079.     if vt52 in urec.config then begin
  2080.       wvt52(#234+#234+#01+chr(x)+chr(y));gotoxy(x,y);
  2081.     end else begin
  2082.       A:=y-WhereY;
  2083.       If a>0 Then For c:=1 To a Do WriteLn;
  2084.       a:=x-WhereX;
  2085.       If a>0 Then For c:=1 To a Do Write(' ');
  2086.     End;
  2087.   end;
  2088.  
  2089. procedure movexy (x,y:integer);
  2090.     Begin
  2091.       If Not(ansigraphics In urec.config) Then asciigotoxy(x,y);
  2092.       If Not(ansigraphics In urec.config) Then exit;
  2093.       Write(direct,#27'[');
  2094.       If y<>1 Then Write(direct,strr(y));
  2095.       If x<>1 Then Write(direct,';',strr(x));
  2096.       Write('H');
  2097.     End;
  2098.  
  2099. procedure ansicls;
  2100. begin
  2101.  if (ansigraphics in urec.config) then
  2102.  write (direct,#27+'[2J') else
  2103.  write (^L);
  2104. end;
  2105.  
  2106.   procedure doitbro (k:char);
  2107.   var n:integer;
  2108.   begin
  2109.     if inuse<>1
  2110.       then writecon (k)
  2111.       else begin
  2112.         bottom;
  2113.         writecon (k);
  2114.         top
  2115.       end;
  2116.     if wherey>lasty then gotoxy (wherex,lasty);
  2117.     if (not modemoutlock) and ((k<>#10) or uselinefeeds)
  2118.       then begin
  2119.        if online then sendchar(k);
  2120.       end;
  2121.     if texttrap then begin
  2122.       write (ttfile,k);
  2123.       n:=ioresult;
  2124.       if n<>0 then abortttfile (n)
  2125.     end;
  2126.     if printerecho then write (lst,k)
  2127.   end;
  2128.  
  2129.   procedure domacro (sussuh:anystr);
  2130.   var x:integer;
  2131.   begin
  2132.    for x:=1 to length(sussuh) do
  2133.    begin
  2134.     if sussuh[x]='~' then writeln(input) else
  2135.     doitbro (sussuh[x]);
  2136.    end;
  2137.   end;
  2138.  
  2139.   {procedure idiot;
  2140.   begin
  2141.    writeln ('You are stupid!');
  2142.   end;}
  2143.  
  2144. procedure showcredits;
  2145. begin
  2146. clearscr;
  2147. writeln;
  2148. writeln (^P'           ┌───────────────────────────────────┐');
  2149. writeln (^P'           │'^R'FAQ was written and developed by   '^P'│');
  2150. writeln (^P'           │'^R'The Firegod and The Witch Doctor of'^P'│');
  2151. writeln (^P'           │'^R'The BaseTwo Software Company.      '^P'│');
  2152. writeln (^P'           │'^R'The Version of FAQ the BBS is      '^P'│');
  2153. writeln (^P'           │'^R'running is FAQ Version '+ver+'.       '^P'│');
  2154. write   (^P'           │'^R'Registered to: '^S);
  2155. tab (reg.handle,20);
  2156. writeln (^P'│');
  2157. write   (^P'           │'^R'Serial Number: '^S);
  2158. tab (strlong(reg.serial),20);
  2159. writeln(^P'│');
  2160. writeln (^P'           └───────────────────────────────────┘');
  2161. writeln;
  2162. end;
  2163.  
  2164. procedure ansi_window (xx,yy,xxx,yyy:integer);
  2165. var i,cnt:integer;
  2166. begin
  2167. movexy(xx,yy);
  2168. write (^B^P);Dontstop:=true;
  2169. if ascii then Write ('┌') else Write ('+');
  2170. for cnt:=(xx+1) to xxx do begin
  2171. if ascii then write ('─') else write ('-'); end; if ascii then
  2172. writeln ('┐') else writeln ('┐');
  2173. for cnt:=(yy+1) to ((yyy)-1) do begin
  2174. i:=xxx-xx;
  2175. movexy (xx,cnt); if ascii then write ('│'+#27+'['+strr(i)+'C│') else
  2176. write ('|'+#27+'['+strr(i)+'C|'); end;
  2177. movexy (xx,yyy);
  2178. if ascii then Write ('└') else Write ('+');
  2179. for cnt:=(xx+1) to xxx do begin
  2180. if ascii then write ('─') else write ('-'); end; if ascii then
  2181. writeln ('┘') else writeln ('+');
  2182. dontstop:=false;
  2183. write (^B^R);
  2184. end;
  2185.  
  2186. procedure write_menu (x,y:integer; c,s:string);
  2187. begin
  2188. movexy (x,y); writeln (^P'['^S+c+^P'] '^R+s);
  2189. end;
  2190.  
  2191. procedure pause;
  2192. var i:integer;
  2193. begin
  2194. write (^P^R'Press '^P'['^S'Enter'^P'] '^R'to continue'^P': '^U);
  2195. repeat
  2196. until (waitforchar=#13) or (hungupon);
  2197. if ansigraphics in urec.config then
  2198. for i:=1 to 27 do begin write (^H,' ',^H); end;
  2199. end;
  2200.  
  2201. begin
  2202. end.
  2203.  
  2204.