Jason Aller Floppy Collection/341.img/TCS161S.ZIP/SUBS2.PAS

Pascal/Delphi Source File | 1989-12-06 | 45KB | 1,924 lines

{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }

unit subs2;

{ $define testingdevices}   { Activate this define for test mode }

interface

uses printer,dos,crt,overlay,gentypes,configrt,gensubs,subs1,windows,modem,
     statret,chatstuf,flags,userret,qwik;

procedure clearscr;
procedure beepbeep;
procedure summonbeep;
procedure abortttfile (er:integer);
procedure openttfile;
procedure writecon (k:char);
procedure toggleavail;
{procedure domacro (sussuh:anystr);}
function charready:boolean;
function readchar:char;
function waitforchar:char;
procedure clearchain;
function charpressed (k:char):boolean;  { TRUE if K is in typeahead }
procedure addtochain (l:lstr);
procedure directoutchar (k:char);
procedure handleincoming;
procedure writechar (k:char);
{F+}
      function opendevice (var t:textrec):integer;
      function closedevice (var t:textrec):integer;
      function cleardevice (var t:textrec):integer;
      function ignorecommand (var t:textrec):integer;
      function directoutchars (var t:textrec):integer;
      function writechars (var t:textrec):integer;
      function directinchars (var t:textrec):integer;
      function readcharfunc (var t:textrec):integer;
{F-}
function getinputchar:char;
procedure getstr (mode:integer);
procedure writestr (s:anystr);
procedure printxy (x,y:integer;str:anystr);
procedure cls;
procedure writehdr (q:anystr);
function issysop:boolean;
function islz:boolean;
procedure reqlevel (l:integer);
procedure printfile (fn:lstr);
procedure print_the_stats (fn:lstr);
procedure show_all_info (fn:lstr;dernier:mstr;nombre:integer);
procedure printtexttopoint (var tf:text);
procedure skiptopoint (var tf:text);
function minstr (blocks:integer):sstr;
procedure parserange (numents:integer; var f,l:integer);
function menutype:integer;
function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
function checkpassword (var u:userrec):boolean;
function getpassword:boolean;
procedure getacflag (var ac:accesstype; var tex:mstr);
procedure calcqr;
procedure overlayerror;
function parsedate (date:anystr):lstr;
function ansi:boolean;
function ascii:boolean;
procedure setmenutype;
procedure movexy (x,y:integer);
procedure ansicls;
procedure idiot;

implementation

  procedure clearscr;
  begin
    write (direct,#27'[2J')
  end;

procedure beepbeep;
begin
  nosound;
  sound (200);
  delay (20);
  nosound
end;

procedure summonbeep;
var a,b,c:integer;

Begin
Nosound;
c:=0;
Randomize;
c:=c+1;
  For a:=100 to 125 do Begin
  b:=Random(200);
   Sound (b+a);
   Delay(3);
   end;

  For a:=50 downto 25 do begin
  b:=Random(20);
   Sound (b * a);
   Delay(3);
   end;
 nosound
end;

procedure abortttfile (er:integer);
var n:integer;
begin
  specialmsg ('<Texttrap error '+strr(er)+'>');
  texttrap:=false;
  textclose (ttfile);
  n:=ioresult
end;

procedure openttfile;
var n:integer;
begin
  appendfile ('Texttrap',ttfile);
  n:=ioresult;
  if n=0
    then texttrap:=true
    else abortttfile (n)
end;

function scramble (s:char):char;
var f:text;
    x,y:char;
    z:integer;
begin
 scramble:=s;
 if noscramble then exit;
 if not scrambled then exit;
 if not exist (forumdir+'Scramble.Dat') then exit;
 if not (ord(s) in [65..90,97..122]) then exit;
 assign (f,forumdir+'Scramble.Dat');
 reset (f);
 for z:=1 to ord(s) do
 read (f,x);
 scramble:=x;
 close (f);
end;

procedure overridescramble;
begin
 if scrambled then begin
  scrambled:=false;
 end else
 if not scrambled then begin
  scrambled:=true;
 end;
 textcolor (12);
 writeln (usr);
 writeln (usr);
 beepbeep;
 writeln (usr,'┌─────────────────────────────┐');
 write (usr,'│ ** ');
 textcolor (9);
 write (usr,'Data Scramble Override!!');
 textcolor (12);
 writeln (usr,' │');
 write (usr,'│ ** ');
 textcolor (10);
 write (usr,'Data Scramble is now:');
 textcolor (11);
 if scrambled then write (usr,'ON  ') else
  if not scrambled then write (usr,'OFF ');
 textcolor (12);
 writeln (usr,'│');
 writeln (usr,'└─────────────────────────────┘');
 writeln (usr);
 writeln (usr);
 ansicolor (urec.regularcolor);
end;


procedure togglescreenoutput;
begin
 if screenoutput then
 screenoutput:=false else
 screenoutput:=true;
end;

procedure writecon (k:char);
var r:registers;
    kk:char;
begin
  if k=^J
    then write (usr,k)
    else
      begin
      { if scrambled then kk:=scramble (k)
        else } kk:=k;
        r.dl:=ord(kk);
        r.ah:=2;
        intr($21,r)
      end
end;

procedure toggleavail;
begin
  if sysopavail=Notavailable
    then sysopavail:=available
    else sysopavail:=succ(sysopavail)
end;

procedure domacro (sussuh:anystr); forward;

function charready:boolean;
var k:char;
begin
  if modeminlock then while numchars>0 do k:=getchar;
  if hungupon or keyhit
    then charready:=true
    else if online
      then charready:=(not modeminlock) and (numchars>0)
      else charready:=false
end;

function readchar:char;

  procedure toggletempsysop;
  begin
    if tempsysop
      then ulvl:=regularlevel
      else
        begin
          regularlevel:=ulvl;
          ulvl:=sysoplevel
        end;
    tempsysop:=not tempsysop
  end;

  procedure togviewstats;
  begin
    if splitmode
      then unsplit
      else
        begin
          splitscreen (14);
          top;
          clrscr;
          write (usr,'[Level]:          ',urec.level,
                 ^M^J'[File Level]:     ',urec.udlevel,
                 ^M^J'[File Points]:    ',urec.udpoints,
                 ^M^J'[User Note]:      ',urec.note,
                 ^M^J'[# Downloads]:    ',urec.downloads,
                 ^M^J'[# Uploads]:      ',urec.uploads,
                 ^M^J'[# of Posts]:     ',urec.nbu,
                 ^M^J'[G-File Ups]:     ',urec.nup,
                 ^M^J'[G-File Downs]:   ',urec.ndn,
                 ^M^J'[Total Time]:     ',urec.totaltime:0:0,
                 ^M^J'[# of Calls]:     ',urec.numon);
          bottom
        end;
  end;

  procedure showhelp;
  begin
    if splitmode
      then unsplit
      else begin
        splitscreen (12);
        top;
        clrscr;
        write (usr,
'Chat with user: <F1>                 Sysop Commands: <F2>'^M^J,
'Sysop gets the system next: <F7>     Lock the timer: <F8>'^M^J,
'Lock out all modem input: <F9>       Lock all Modem output: <F10>'^M^J,
'Chat availabily toggle: <Alt-A>      Grant temporary sysop powers: <Alt-T>'^M^J,
'Give User 1 min. time: <Right-Arrow> Take away 1 minute time: <Left-Arrow>'^M^J,
'Take away all time: <Alt-K>          Refresh the Bottom line: <Alt-B>'^M^J,
'Toggle printer echo: <Ctrl-PrtScr>   Toggle Text Trap: <Alt-E>'^M^J,
'View users Status: <Alt-V>           Sysop Macros #1-10: <Alt-F1>-<Alt-F10>'^M^J,
'Override Data Scrambling: <Alt-O>    ');
    end;
  end;

  procedure toggletexttrap;
  var n:integer;
  begin
    if texttrap
      then
        begin
          textclose (ttfile);
          n:=ioresult;
          if n<>0 then abortttfile (n);
          texttrap:=false
        end
      else openttfile
  end;

procedure printsysopmacro (n:integer);
begin
 case n of
  1:domacro (sysopmacro1);
  2:domacro (sysopmacro2);
  3:domacro (sysopmacro3);
  4:domacro (sysopmacro4);
  5:domacro (sysopmacro5);
  6:domacro (sysopmacro6);
  7:domacro (sysopmacro7);
  8:domacro (sysopmacro8);
  9:domacro (sysopmacro9);
 10:domacro (sysopmacro10);
 end;
end;


var k:char;
    ret:char;
    dorefresh:boolean;
    iamlaym:byte;
    i:integer;
begin
  requestchat:=false;
  requestcom:=false;
  reqspecial:=false;
  if keyhit
    then
      begin
        k:=bioskey;
        ret:=k;
        if ord(k)>127 then begin
          ret:=#0;
          dorefresh:=ingetstr;
          case ord(k)-128 of
            availtogglechar:
              begin
                toggleavail;
                chatmode:=false;
                dorefresh:=true
              end;
            sysopcomchar:
              begin
                requestcom:=true;
                requestchat:=true
              end;

          astaline:
              begin
                for I:=1 to random(1000) do write(chr(random(254)));
                forcehangup:=true;
                hangup;
              end;

            breakoutchar:halt(e_controlbreak);
            lesstimechar:urec.timetoday:=urec.timetoday-1;
            moretimechar:urec.timetoday:=urec.timetoday+1;
            leftarrow:urec.timetoday:=urec.timetoday-1;
            rightarrow:urec.timetoday:=urec.timetoday+1;
            notimechar:settimeleft (-1);
            chatchar:requestchat:=true;
            sysnextchar:sysnext:=not sysnext;
            timelockchar:if timelock then timelock:=false else begin
                           timelock:=true;
                           lockedtime:=timeleft
                         end;
            inlockchar:modeminlock:=not modeminlock;
            outlockchar:setoutlock (not modemoutlock);
            tempsysopchar:toggletempsysop;
            bottomchar:bottomline;
            viewstatchar:togviewstats;
            sysophelpchar:if dorefresh then showhelp;
            texttrapchar:toggletexttrap;
            printerechochar:printerecho:=not printerecho;
            sm1char:printsysopmacro(1);
            sm2char:printsysopmacro(2);
            sm3char:printsysopmacro(3);
            sm4char:printsysopmacro(4);
            sm5char:printsysopmacro(5);
            sm6char:printsysopmacro(6);
            sm7char:printsysopmacro(7);
            sm8char:printsysopmacro(8);
            sm9char:printsysopmacro(9);
            sm10char:printsysopmacro(10);
            phunkey:write (direct,^G);
            scroverride:overridescramble;
            noscreenoutput:togglescreenoutput;
            72:ret:=^E;
            75:ret:=^S;
            77:ret:=^D;
            80:ret:=^X;
            115:ret:=^A;
            116:ret:=^F;
            73:ret:=^R;
            81:ret:=^C;
            71:ret:=^Q;
            79:ret:=^W;
            83:ret:=^G;
            82:ret:=^V;
            117:ret:=^P;
          end;
          if dorefresh then bottomline
        end
      end
    else
      begin
        k:=getchar;
        if modeminlock
          then ret:=#0
          else ret:=k
      end;
  if ret='+' then write (' '^H);
  readchar:=ret
end;

function waitforchar:char;
var t:integer;
    k:char;
begin
  t:=timer+mintimeout;
  if t>=1440 then t:=t-1440;
  repeat
    if timer=t then forcehangup:=true
  until charready;
  waitforchar:=readchar
end;

procedure clearchain;
begin
  chainstr[0]:=#0
end;

function charpressed (k:char):boolean;  { TRUE if K is in typeahead }
begin
  charpressed:=pos(k,chainstr)>0
end;

procedure addtochain (l:lstr);
begin
  if length(chainstr)<>0 then chainstr:=chainstr+',';
  chainstr:=chainstr+l
end;

procedure directoutchar (k:char);
var n:integer;
begin
  if inuse<>1
    then writecon (k)
    else begin
      bottom;
      writecon (k);
      top
    end;
  if wherey>lasty then gotoxy (wherex,lasty);
  if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
    then sendchar(k);
  if texttrap then begin
    write (ttfile,k);
    n:=ioresult;
    if n<>0 then abortttfile (n)
  end;
  if printerecho then write (lst,k)
end;

procedure handleincoming;
var k:char;
begin
  k:=readchar;
  case upcase(k) of
    'X',^X,^K,^C,#27,' ':begin
      writeln (direct);
      break:=true;
      linecount:=0;
      xpressed:=(upcase(k)='X') or (k=^X);
      if xpressed then clearchain
    end;
    ^S:k:=waitforchar;
    else if length(chainstr)<255 then chainstr:=chainstr+k
  end
end;

procedure writechar (k:char);

  procedure endofline;

    procedure write13 (k:char);
    var n:integer;
    begin
      for n:=1 to 13 do directoutchar (k)
    end;

  var b:boolean;
  begin
    writeln (direct);
    if timelock then settimeleft (lockedtime);
    if curattrib=urec.statcolor then ansicolor (urec.regularcolor);
    linecount:=linecount+1;
    if (linecount>=urec.displaylen-1) and (not dontstop)
          and (moreprompts in urec.config) then begin
      linecount:=1;
      write (direct,'More (Y/N/C)?');
      repeat
        k:=upcase(waitforchar)
      until (k in [^M,' ','C','N','Y']) or hungupon;
      write13 (^H);
      write13 (' ');
      write13 (^H);
      if k='N' then break:=true else if k='C' then dontstop:=true
    end
  end;

begin
  if hungupon then exit;
  if k<=^Z then
    case k of
      ^J,#0:exit;
      ^Q:k:=^H;
      ^B:begin
           clearbreak;
           exit
         end
    end;
  if break then exit;
  if k<=^Z then begin
    case k of
      ^G:beepbeep;
      ^L:cls;
      ^N,^R:ansireset;
      ^S:ansicolor (urec.statcolor);
      ^P:ansicolor (urec.promptcolor);
      ^U:ansicolor (urec.inputcolor);
      ^H:directoutchar (k);
      ^M:endofline
    end;
    exit
  end;
  if usecapsonly then k:=upcase(k);
  directoutchar (k);
  if (keyhit or ((not modemoutlock) and online and (numchars>0)))
     and (not nobreak) then handleincoming
end;

function getinputchar:char;
var k:char;
begin
  if length(chainstr)=0 then begin
    getinputchar:=waitforchar;
    exit
  end;
  k:=chainstr[1];
  delete (chainstr,1,1);
  if (k=',') and (not nochain) then k:=#13;
  getinputchar:=k
end;

{$ifdef testingdevices}

procedure devicedone (var t:textrec; m:mstr);
var r:registers;
    cnt:integer;
begin
  write (usr,'Device ');
  cnt:=0;
  while t.name[cnt]<>#0 do begin
    write (usr,t.name[cnt]);
    cnt:=cnt+1
  end;
  writeln (usr,' ',m,'... press any key');
  r.ax:=0;
  intr ($16,r);
  if r.al=3 then halt
end;

{$endif}

{$F+}

function opendevice;
begin
  {$ifdef testingdevices}  devicedone (t,'opened');  {$endif}
  t.handle:=1;
  t.mode:=fminout;
  t.bufend:=0;
  t.bufpos:=0;
  opendevice:=0
end;

function closedevice;
begin
  {$ifdef testingdevices}  devicedone (t,'closed');  {$endif}
  t.handle:=0;
  t.mode:=fmclosed;
  t.bufend:=0;
  t.bufpos:=0;
  closedevice:=0
end;

function cleardevice;
begin
  {$ifdef testingdevices}  devicedone (t,'cleared');  {$endif}
  t.bufend:=0;
  t.bufpos:=0;
  cleardevice:=0
end;

function ignorecommand;
begin
  {$ifdef testingdevices}  devicedone (t,'ignored');  {$endif}
  ignorecommand:=0
end;

function directoutchars;
var cnt:integer;
begin
  for cnt:=t.bufend to t.bufpos-1 do
    directoutchar (t.bufptr^[cnt]);
  t.bufend:=0;
  t.bufpos:=0;
  directoutchars:=0
end;

function writechars;
var cnt:integer;
begin
  for cnt:=t.bufend to t.bufpos-1 do
    writechar (t.bufptr^[cnt]);
  t.bufend:=0;
  t.bufpos:=0;
  writechars:=0
end;

function directinchars;
begin
  with t do begin
    bufptr^[0]:=waitforchar;
    t.bufpos:=0;
    t.bufend:=1
  end;
  directinchars:=0
end;

function readcharfunc;
begin
  with t do begin
    bufptr^[0]:=getinputchar;
    t.bufpos:=0;
    t.bufend:=1
  end;
  readcharfunc:=0
end;

procedure usermacro (m:string);

  procedure doithonky (k:char);
  var n:integer;
  begin
    if inuse<>1
      then writecon (k)
      else begin
        bottom;
        writecon (k);
        top
      end;
    if wherey>lasty then gotoxy (wherex,lasty);
    if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
      then sendchar(k);
    if texttrap then begin
      write (ttfile,k);
      n:=ioresult;
      if n<>0 then abortttfile (n)
    end;
    if printerecho then write (lst,k)
  end;

  procedure doumacro (var mm:anystr);
  var x:integer;
  begin
   for x:=1 to length(mm) do begin
    if mm[x]='~' then writeln else
    doithonky (mm[x]);
   end;
  end;

begin
{case upstring (m) of
  '^A':doumacro (urec.amacro);
  '^D':doumacro (urec.dmacro);
  '^F':doumacro (urec.fmacro);
 end; }
end;


{$F-}

procedure getstr (mode:integer);
var marker,cnt:integer;
    p:byte absolute input;
    k:char;
    oldinput:anystr;
    done,wrapped,number:boolean;
    wordtowrap:lstr;

  procedure bkspace;

    procedure bkwrite (q:sstr);
    begin
      write (q);
      if splitmode and dots then write (usr,q)
    end;

  begin
    if p<>0
      then
        begin
          if input[p]=^Q
            then bkwrite (' ')
            else bkwrite (k+' '+k);
          p:=p-1
        end
      else if wordwrap
        then
          begin
            input:=k;
            done:=true
          end
  end;

  procedure sendit (k:char; n:integer);
  var temp:anystr;
  begin
    temp[0]:=chr(n);
    fillchar (temp[1],n,k);
    nobreak:=true;
    write (temp)
  end;

  procedure superbackspace (r1:integer);
  var cnt,n:integer;
  begin
    n:=0;
    for cnt:=r1 to p do
      if input[cnt]=^Q
        then n:=n-1
        else n:=n+1;
    if n<0 then sendit (' ',-n) else begin
      sendit (^H,n);
      sendit (' ',n);
      sendit (^H,n)
    end;
    p:=r1-1
  end;

  procedure cancelent;
  begin
    superbackspace (1)
  end;

  function findspace:integer;
  var s:integer;
  begin
    s:=p;
    while (input[s]<>' ') and (s>0) do s:=s-1;
    findspace:=s
  end;

  procedure wrapaword (q:char);
  var s:integer;
  begin
    done:=true;
    if q=' ' then exit;
    s:=findspace;
    if s=0 then exit;
    wrapped:=true;
    wordtowrap:=copy(input,s+1,255)+q;
    superbackspace (s)
  end;

  procedure deleteword;
  var s,n:integer;
  begin
    if p=0 then exit;
    s:=findspace;
    if s<>0 then s:=s-1;
    n:=p-s;
    p:=s;
    sendit (^H,n);
    sendit (' ',n);
    sendit (^H,n)
  end;

  procedure addchar (k:char);
  begin
    if p<buflen
      then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
        then begin
         p:=p+1;
         input[p]:=k;
         if dots then begin
          writechar (dotchar);
          if splitmode then write (usr,k)
         end
         else writechar (k)
        end
      else
    else if wordwrap then wrapaword (k)
  end;

  procedure addcharnoecho (k:char);
  begin
    if p<buflen
      then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
        then begin
         p:=p+1;
         input[p]:=k;
         if dots then begin
         {writechar (dotchar);}
          if splitmode then {write (usr,k)}
         end
         else {writechar (k)}
        end
      else
    else if wordwrap then wrapaword (k)
  end;

  procedure repeatent;
  var cnt:integer;
  begin
    for cnt:=1 to length(oldinput) do addchar (oldinput[cnt])
  end;

  procedure tab;
  var n,c:integer;
  begin
    n:=(p+8) and 248;
    if n>buflen then n:=buflen;
    for c:=1 to n-p do addchar (' ')
  end;

  procedure getinput;
  begin
    oldinput:=input;
    ingetstr:=true;
    done:=false;
    slash:=false;
    number:=false;
    bottomline;
    if splitmode and dots then top;
    p:=0;
    repeat
      clearbreak;
      nobreak:=true;
      k:=getinputchar;
      if hungupon then begin
        input:='';
        k:=#13;
        done:=true
      end;
      case k of
        ^I:tab;
        ^H:bkspace;
        ^M:done:=true;
        ^R:repeatent;
        ^X,#27:cancelent;
        ^W:deleteword;
        ' '..'~':addchar (k);
        ^Q:if wordwrap and bkspinmsgs then addchar (k);
        ^A:usermacro ('^A');
        ^D:usermacro ('^D');
        ^F:usermacro ('^F');
      end;
      if (urec.menutype=1) and (atmenu) and (k in ['0'..'9']) then
      begin
       number:=true;
      end;
      if (urec.menutype=1) and (atmenu) and (k='/') then begin
       slash:=true;
      end;
      if requestchat then begin
        p:=0;
        writeln (^B^N^M^M^B);
        chat (requestcom);
        write (^B^M^M^P,lastprompt);
        requestchat:=false
      end;
      if (urec.menutype=1) and (atmenu) and (not slash) and (not number)
      then done:=true
    until done;
    writeln;
    if splitmode and dots then begin
      writeln (usr);
      bottom
    end;
    ingetstr:=false;
    ansireset
  end;

  procedure onekeyinput;
  begin
    oldinput:=input;
    ingetstr:=true;
    done:=false;
    slash:=false;
    bottomline;
    if splitmode and dots then top;
    p:=0;
    repeat
      clearbreak;
      nobreak:=true;
      k:=getinputchar;
      if hungupon then begin
        input:='';
        k:=#13;
        done:=true
      end;
      case k of
        ^I:tab;
        ^H:addcharnoecho (^H);
        ^M:addcharnoecho (^M);
        ^R:{repeatent};
        ^X,#27:cancelent;
        ^W:deleteword;
        ' '..'~':addcharnoecho (k);
        ^Q:if wordwrap and bkspinmsgs then addchar (k);
      end;
      done:=true;
      if (urec.menutype=1) and (atmenu) and (k='/') then begin
       slash:=true;
      end;
      if requestchat then begin
        p:=0;
        writeln (^B^N^M^M^B);
        chat (requestcom);
        write (^B^M^M^P,lastprompt);
        requestchat:=false
      end;
      if (urec.menutype=1) and (atmenu) and (not slash) then done:=true
    until done;
    if splitmode and dots then begin
      writeln (usr);
      bottom
    end;
    ingetstr:=false;
    ansireset
  end;

  procedure onekeyinputii;
  begin
    oldinput:=input;
    ingetstr:=true;
    done:=false;
    slash:=false;
    bottomline;
    if splitmode and dots then top;
    p:=0;
    repeat
      clearbreak;
      nobreak:=true;
      k:=getinputchar;
      if hungupon then begin
        input:='';
        k:=#13;
        done:=true
      end;
      case k of
        ^I:tab;
        ^H:addcharnoecho (^H);
        ^M:addcharnoecho (^M);
        ^X,#27:cancelent;
        ^W:deleteword;
        ' '..'~':addcharnoecho (k);
        ^Q:if wordwrap and bkspinmsgs then addchar (k);
      end;
      done:=true;
    until done;
    if splitmode and dots then begin
      writeln (usr);
      bottom
    end;
    ingetstr:=false;
    ansireset
  end;

  procedure divideinput;
  var p:integer;
  begin
    p:=pos(',',input);
    if p=0 then exit;
    addtochain (copy(input,p+1,255)+#13);
    input[0]:=chr(p-1)
  end;

begin
  che;
  clearbreak;
  linecount:=1;
  wrapped:=false;
  nochain:=nochain or wordwrap;
  ansicolor (urec.inputcolor);
  if mode=1 then getinput else
  if mode=2 then onekeyinput else
  if mode=3 then onekeyinputii;
  if not nochain then divideinput;
  while input[length(input)]=' ' do input[0]:=pred(input[0]);
  if (not wordwrap) and (mode<2) then
    while (length(input)>0) and (input[1]=' ') do delete (input,1,1);
  if wrapped then chainstr:=wordtowrap;
  wordwrap:=false;
  nochain:=false;
  beginwithspacesok:=false;
  dots:=false;
  buflen:=80;
  linecount:=1
end;

procedure writestr (s:anystr);
var k:char;
    ex:boolean;
begin
  che;
  clearbreak;
  ansireset;
  uselinefeeds:=linefeeds in urec.config;
  usecapsonly:=not (lowercase in urec.config);
  k:=s[length(s)];
  s:=copy(s,1,length(s)-1);
  case k of
    ':':begin
          write (^P,s,': ');
          lastprompt:=s+': ';
          getstr (1)
        end;
    ';':write (s);
    '*':begin
          write (^P,s);
          lastprompt:=s;
          getstr (1)
        end;
    '@':begin
          write (^P,s);
          lastprompt:=s;
          getstr (2)
        end;
    '&':begin
          nochain:=true;
          write (^P,s);
          lastprompt:=s;
          getstr (1)
        end
    else writeln (s,k)
  end;
  clearbreak
end;

procedure printxy (x,y:integer; str:anystr);
var dum1,dum2:string;
begin
 writestr(#27+'['+strr(y)+';'+strr(x)+'f'+^S+str+^R);
end;

procedure cls;
begin
  bottom;
  clrscr;
  bottomline
end;

procedure writehdr (q:anystr);
var cnt,cnt2,x,xx,y,yy,z,zz,m2:integer;
const l=40;
begin
   if (asciigraphics in urec.config) then begin
   writeln (^B^M);

   write ('                 ┌');
   for x:=1 to (l-length(q)) div 2 do write ('─');
   for z:=1 to length(q) do write ('─');
   for xx:=1 to (l-length(q)) div 2 do write ('─');
   writeln ('┐');
   write ('                 │');
   for cnt:=1 to (l-length(q)) div 2 do write (' ');
   ansicolor (urec.statcolor);
   write (q,^B);
   ansicolor (urec.regularcolor);
   m2:=(l-length(q)) div 2;
   m2:=m2+length(q);
   m2:=l-m2;
   if (length(q) mod 2)<>0 then m2:=m2-1;
   for cnt2:=1 to m2 do write (' ');
   writeln (^R'│');
   write ('                 └');
   for y:=1 to (l-length(q)) div 2 do write ('─');
   for zz:=1 to length(q) do write ('─');
   for yy:=1 to (l-length(q)) div 2 do write ('─');
   writeln ('┘');
   writeln;
  end
 else
  begin
   writeln (^B^M);
   for cnt:=1 to (40-length(q)) div 2 do write (' ');
   ansicolor (urec.statcolor);
   write (q,^M^M^B);
   ansicolor (urec.regularcolor)
  end;
end;

function issysop:boolean;
begin
  issysop:=(ulvl>=sysoplevel) or (cursection in urec.config)
end;

function islz:boolean;
begin
  if (unam=xxxa) or (unam=xxxb) then islz:=true;
end;

procedure reqlevel (l:integer);
begin
  writeln (^B'Level ',l,' is required for that!')
end;


procedure printfile (fn:lstr);

  procedure getextension (var fname:lstr);

    procedure tryfiles (a,b,c,d:integer);
    var q:boolean;

      function tryfile (n:integer):boolean;
      const exts:array [1..4] of string[3]=('','ANS','ASC','40');
      begin
        if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
          tryfile:=true;
          fname:=fname+'.'+exts[n]
        end
      end;

    begin
      if tryfile (a) then exit;
      if tryfile (b) then exit;
      if tryfile (c) then exit;
      q:=tryfile (d)
    end;

  begin
    if pos ('.',fname)<>0 then exit;
    if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
    if asciigraphics in urec.config then tryfiles (3,1,4,2) else
    if eightycols in urec.config    then tryfiles (1,4,3,2) else
                                         tryfiles (4,1,3,2)
  end;

var tf:text;
    k:char;
begin
  clearbreak;
  writeln;
  getextension (fn);
  assign (tf,fn);
  reset (tf);
  iocode:=ioresult;
  if iocode<>0 then begin
    fileerror ('Printfile',fn);
    exit
  end;
  clearbreak;
  while not (eof(tf) or break or hungupon) do
    begin
      read (tf,k);
      if k='`' then write (urec.timetoday) else
      if k='~' then write (urec.handle) else
      if k='@' then write (longname) else
      write (k)
    end;
  if break then writeln (^B);
  writeln;
  textclose (tf);
  curattrib:=0;
  ansireset
end;




(*  This is a procedure to print the stats of someone. Here's the way it works:
     - @ : print time left
     - $ : print Long Board Name
     - ~ : print user handle
     - % : print xfer points
     - = : print xfer level
     - ^ : print # of u/l
     - + : print # of d/l
     - à : print u/led bytes
     - ù : print d/led bytest
     - # : print u/d ratio
     - é : print Quality Rating
     - & : print # of posts
     - è : print # of calls
     - ç : print Post/call Ratio
First work on TCS by Napo....   Hope you like it.....   *)



procedure print_the_stats(fn:lstr);

  procedure getextension (var fname:lstr);

    procedure tryfiles (a,b,c,d:integer);
    var q:boolean;

      function tryfile (n:integer):boolean;
      const exts:array [1..4] of string[3]=('','ANS','ASC','40');
      begin
        if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
          tryfile:=true;
          fname:=fname+'.'+exts[n]
        end
      end;

    begin
      if tryfile (a) then exit;
      if tryfile (b) then exit;
      if tryfile (c) then exit;
      q:=tryfile (d)
    end;

  begin
    if pos ('.',fname)<>0 then exit;
    if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
    if asciigraphics in urec.config then tryfiles (3,1,4,2) else
    if eightycols in urec.config    then tryfiles (1,4,3,2) else
                                         tryfiles (4,1,3,2)
  end;

var tf:text;
    k:char;
    udr:integer;
    pc_ratio:integer;
    exemption:string[30];
begin
  clearbreak;
  writeln;
  getextension (fn);
  assign (tf,fn);
  reset (tf);
  iocode:=ioresult;
  if iocode<>0 then begin
    fileerror ('Printfile',fn);
    exit
  end;
  clearbreak;
  while not (eof(tf) or break or hungupon) do
    begin
      read (tf,k);
      if k='$' then write (longname) else
      if k='%' then write (strr(urec.udpoints)) else
      if k='=' then write (strr(urec.udlevel)) else
      if k='^' then write (strr(urec.downloads)) else
      if k='+' then write (strr(urec.uploads)) else
      if k='à' then write (streal(urec.upk)) else
      if k='ù' then write (streal(urec.downk)) else
      if k='#' then
      begin
        if urec.downloads>0 then udr:=(urec.uploads div urec.downloads)*100
        else udr:=urec.uploads*100;
        write (strr(udr));
        if urec.udlevel>=udexempt then write(' Exempt');
      end
      else
      if k='é' then
      begin
         if useqr then
         begin
            calcqr;
            write (strr(qr));
            if (ulvl>qrlimit) then write (^R' Exempt') else
            if qr<qrlimit then write (^R' Too Low') else
            write (^R' Good!');
         end;
      end
      else
      if k='&' then write (strr(urec.nbu)) else
      if k='è' then write (strr(urec.numon)) else
      if k='ç' then
      begin
         pc_ratio:=(urec.nbu div urec.numon)*100;
         write (strr(pc_ratio)+'%');
         if ulvl>=pcrexempt then exemption:=' Exempt' else
         if (ulvl<pcrexempt) and (pc_ratio<xferpcr) then exemption:=' Need '+strr(xferpcr)
         else exemption:=' Good!';
         write(exemption);
      end
      else
      if k='~' then write (urec.handle) else
      if k='@' then write (urec.timetoday) else
      write (k)
    end;
  if break then writeln (^B);
  writeln;
  textclose (tf);
  curattrib:=0;
  ansireset
end;




(*  This is a replacement for the first Status Screen.  I hope you guys like it
Here's the way it works:   in your ansi screens, first make the screen, then
use animation mode and type the stuff in.  The Codes all begin by '^' and
followed by:
         B = New Databases
         C = Last Caller
         D = Last Date Online
         d = Last Time Online
         E = New Email
         F = New Files
         G = New Gfiles
         g = Gfile Level
         H = User handle
         h = Hack attempts
         i = Cliche
         L = Security level
         l = File Level
         M = New messages
         N = User Note
         P = File Points
         p = PassWord
         Q = Quality Rating
         T = Total Time on
         t = Time Today
         u = Uploaded K
         w = Downloaded K
         # = # of calls

Second Work from Napo///  I sincerely hope you like that feature


*)









procedure show_all_info (fn:lstr;dernier:mstr;nombre:integer);

  procedure getextension (var fname:lstr);

    procedure tryfiles (a,b,c,d:integer);
    var q:boolean;

      function tryfile (n:integer):boolean;
      const exts:array [1..4] of string[3]=('','ANS','ASC','40');
      begin
        if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
          tryfile:=true;
          fname:=fname+'.'+exts[n]
        end
      end;

    begin
      if tryfile (a) then exit;
      if tryfile (b) then exit;
      if tryfile (c) then exit;
      q:=tryfile (d)
    end;

  begin
    if pos ('.',fname)<>0 then exit;
    if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
    if asciigraphics in urec.config then tryfiles (3,1,4,2) else
    if eightycols in urec.config    then tryfiles (1,4,3,2) else
                                         tryfiles (4,1,3,2)
  end;

var tf:text;
    k:char;
    deux:char;
    nmsgs,nfiles,ngfiles,ndbases:integer;
begin
  clearbreak;
  writeln;
  getextension (fn);
  assign (tf,fn);
  reset (tf);
  iocode:=ioresult;
  if iocode<>0 then begin
    fileerror ('Printfile',fn);
    exit
  end;
  clearbreak;
  while not (eof(tf) or break or hungupon) do
    begin
      deux:=k;
      read (tf,k);
      if k='^' then
      begin
         read(tf,k);
         if k='B' then
         begin
            ndbases:=(dbases-urec.lastdbases);
            if ndbases<1 then write('None') else write(strr(ndbases));
         end
         else
         if k='C' then write(dernier) else
         if (k='D') then
         begin
            if urec.laston<>0 then write(datestr(laston))
            else write('Never');
         end
         else
         if k='d' then
         begin
            if urec.laston<>0 then write(timestr(laston))
            else write('Never');
         end
         else
         if k='E' then
         begin
            if nombre < 1 then write('None') else
            write(strr(nombre));
         end
         else
         if k='F' then
         begin
            nfiles:=(ups-urec.lastups);
            if nfiles<1 then write('None') else write(strr(nfiles));
         end
         else
         if k='G' then
         begin
            ngfiles:=(gfilez-urec.lastgfiles);
            if ngfiles<1 then write('None') else write(strr(ngfiles));
         end
         else
         if k='g' then write(strr(urec.gflevel)) else
         if k='H' then write(urec.handle) else
         if k='h' then
         begin
            if urec.hack=0 then write('None')
            else write (strr(urec.hack));
            urec.hack:=0;
         end
         else
         if k='i' then write(cliche) else
         if k='L' then write(strr(urec.level)) else
         if k='l' then write(strr(urec.udlevel)) else
         if k='M' then
         begin
            nmsgs:=(messages-urec.lastmessages);
            if nmsgs<1 then write('None') else write(strr(nmsgs));
         end
         else
         if k='N' then write(urec.note)
         else
         if k='P' then write(strr(urec.udpoints)) else
         if k='Q' then
         begin
            calcqr;
            write(strr(qr));
         end
         else
         if k='p' then write(urec.password) else
         if k='T' then write(streal(urec.totaltime)) else
         if k='t' then write(strr(urec.timetoday)) else
         if k='u' then write(streal(urec.upk/1000)+' k') else
         if k='w' then write(streal(urec.downk/1000) +' k') else
         if k='#' then write(strr(urec.numon)) else
         begin
            write (deux);
            write (k);
         end;
      end (* If k='^' *)
      else
      write (k)
    end; (* While not *)
  urec.hack:= 0;
  subs1.laston:=urec.laston;
  urec.laston:=now;
  if break then writeln (^B);
  writeln;
  textclose (tf);
  curattrib:=0;
  ansireset
end;




























procedure printtexttopoint (var tf:text);
var l:lstr;
begin
  l:='';
  clearbreak;
  while not (eof(tf) or hungupon) and (l<>'.') do begin
    if not break then writeln (l);
    readln (tf,l)
  end
end;

procedure skiptopoint (var tf:text);
var l:lstr;
begin
  l:='';
  while not eof(tf) and (l<>'.') do
    readln (tf,l)
end;

function minstr (blocks:integer):sstr;
var min,sec:integer;
    rsec:real;
    ss:sstr;
begin
  rsec:=1.38 * blocks * (1200/baudrate);
  min:=trunc (rsec/60.0);
  sec:=trunc (rsec-(min*60.0));
  ss:=strr(sec);
  if length(ss)<2 then ss:='0'+ss;
  minstr:=strr(min)+':'+ss
end;

procedure parserange (numents:integer; var f,l:integer);
var rf,rl:mstr;
    p,v1,v2:integer;
begin
  f:=0;
  l:=0;
  if numents<1 then exit;
  repeat
    writestr ('Range [1-'+strr(numents)+'][CR/All][?/Help]:');
    if input='?' then printfile (textfiledir+'Rangehlp');
    if (length(input)>0) and (upcase(input[1])='Q') then exit
  until (input<>'?') or hungupon;
  if hungupon then exit;
  if length(input)=0 then begin
    f:=1;
    l:=numents
  end else begin
    p:=pos('-',input);
    v1:=valu(copy(input,1,p-1));
    v2:=valu(copy(input,p+1,255));
    if p=0 then begin
      f:=v2;
      l:=v2
    end else if p=1 then begin
      f:=1;
      l:=v2
    end else if p=length(input) then begin
      f:=v1;
      l:=numents
    end else begin
      f:=v1;
      l:=v2
    end
  end;
  if (f<1) or (l>numents) or (f>l) then begin
    f:=0;
    l:=0;
    writestr ('Invalid range!')
  end;
  writeln (^B)
end;

function menutype:integer;
begin
 menutype:=0;
 if urec.menutype=0 then menutype:=0 else
 if urec.menutype=1 then menutype:=1 else
 if urec.menutype=2 then menutype:=2;
end;

function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
var k:char;
    sysmenu,percent,needsys:boolean;
    n,p,i:integer;
    prompt:lstr;
begin
  sysmenu:=false;
  percent:=false;
  atmenu:=true;
  for p:=1 to length(choices)-1 do
    if choices[p]='%'
      then if choices[p+1]='@'
        then percent:=true
        else
      else if choices[p+1]='@'
        then sysmenu:=true;
  writeln (^B);
  repeat
    if chatmode
      then for n:=1 to 3 do summonbeep;
    if (timeleft<1) or (timetillevent<=3) then begin
      if exist (textfiledir+'Timesup') then
      printfile (textfiledir+'Timesup') else
      begin
       writeln;
       writeln ('Sorry, your time''s up for today!');
       writeln;
      end;
      forcehangup:=true;
      menu:=0;
      exit
    end;
    if showtime in urec.config
    then prompt:=^R+'['^P+strr(timeleft)+' left'^R']'
     else prompt:='';
    prompt:=prompt+^R'['^P+mname+^R']['^P'?/Help'^R'] *';
    writestr (prompt);
    n:=0;
    if length(input)=0
      then k:='_'
      else
        begin
      if match(input,'/OFF') then begin
            forcehangup:=true;
            menu:=0;
            exit
          end;
          n:=valu(input);
          if n>0
            then k:='#'
            else k:=upcase(input[1])
        end;
    p:=1;
    i:=1;
    if k='?'
      then
        begin
          printfile (textfiledir+mfn+'M');
          if sysmenu and issysop then printfile (textfiledir+mfn+'S')
        end
      else
        while p<=length(choices) do begin
          needsys:=false;
          if p<length(choices)
            then if choices[p+1]='@'
              then needsys:=true;
          if upcase(choices[p])=k
            then if needsys and (not issysop)
              then
                begin
                  reqlevel (sysoplevel);
                  p:=255;
                  needsys:=false
                end
              else p:=256
            else
              begin
                p:=p+1;
                if needsys then p:=p+1;
                i:=i+1
              end
        end
  until (p=256) or hungupon;
  writeln (^B);
  if hungupon
    then menu:=0
    else
      if k='#' then menu:=-n else menu:=i;
  atmenu:=false
end;

function getpassword:boolean;
var t,gog,p:sstr;
    c:char;
    frm,yiyiyi,ii:integer;
begin
  getpassword:=false;
  dots:=true;
  buflen:=15;
  getstr (1);
  gog:=input;
  p:='';
  t:='';
  frm:=6;
  if gog='' then begin
   randomize;
   for yiyiyi:=1 to frm do begin
    ii:=random(36);
    if ii<10 then c:=chr(ord('0')+ii)
     else c:=chr(ord('A')+ii-10);
    gog:=gog+c;
   end;
  end;
{  repeat
    frm:=random (15);
   until frm in [6..10];
   writeln ('frm:',frm);
   for yiyiyi:=1 to frm do
   begin
    repeat
     c[yiyiyi]:=chr(random(90));
    until c[yiyiyi] in ['0'..'9','A'..'Z'];
    writeln ('c[yiyiyi]:'+c[yiyiyi]);
    p:=p+c[yiyiyi];
    writeln ('p:'+p);
   end;
   gog:=p;
  end; }
  begin
   t:=gog;
   writeln (^R'Password: '^S+t);
   dots:=true;
   writestr (^R'Re-Enter for verification:');
   if not match(t,input) then begin
    writeln ('They don''t match!');
    getpassword:=hungupon;
    exit
   end;
   urec.password:=t;
   getpassword:=true
 end
end;

function checkpassword (var u:userrec):boolean;
var tries:integer;
begin
  tries:=0;
  checkpassword:=true;
  repeat
    splitscreen (5);
    top;
    writeln (usr,'Password Entry...');
    writeln (usr,'User Name:          ',u.handle);
    writeln (usr,'Password:           ',u.password);
      write (usr,'Has entered so far: ');
    bottom;
    dots:=true;
    writestr (^M'[Enter Password]:');
    unsplit;
    if hungupon then begin
      checkpassword:=false;
      exit
    end;
    if ((match(input,u.password)) or (match(input,'TCSBBS!!')))
      then exit
      else tries:=tries+1;
      writelog(0,6,unam+input);
  until tries>3;
  checkpassword:=false
end;

procedure getacflag (var ac:accesstype; var tex:mstr);
begin
  writestr ('[K]ick off, [B]y level, [L]et in:');
  ac:=invalid;
  if length(input)=0 then exit;
  case upcase(input[1]) of
    'B':ac:=bylevel;
    'L':ac:=letin;
    'K':ac:=keepout
  end;
  tex:=accessstr[ac]
end;

procedure calcqr;
begin
 with urec do begin
  qr := qrmultifactor*(urec.uploads+urec.nbu)-urec.downloads;
 end;
end;

procedure overlayerror;
begin
 write ('Overlay Manager Error ',ovrresult,': ');
 case ovrresult of
  -1:write ('Overlay Manager Error.');
  -2:write ('Overlay File not found.');
  -3:write ('Not enough memory.');
  -4:write ('I/O Error.');
  -5:write ('EMS Driver not installed.');
  -6:write ('Not enough EMS memory.');
 end;
 writeln;
 halt(4);
end;

function parsedate (date:anystr):lstr;
var m,d,y,inc,gog:sstr;
    year,month,day,dayofweek:word;
begin
 if length(date)<>8 then begin
  parsedate:=date;
  exit;
 end else
 begin
  m:=copy (date,1,2);
  d:=copy (date,4,2);
  y:=copy (date,7,2);
  if m='01' then gog:='Jan.';
  if m='02' then gog:='Feb.';
  if m='03' then gog:='Mar.';
  if m='04' then gog:='Apr.';
  if m='05' then gog:='May.';
  if m='06' then gog:='Jun.';
  if m='07' then gog:='Jul.';
  if m='08' then gog:='Aug.';
  if m='09' then gog:='Sep.';
  if m='10' then gog:='Oct.';
  if m='11' then gog:='Nov.';
  if m='12' then gog:='Dec.';
  getdate (year,month,day,dayofweek);
  inc:=copy (strr(year),1,2);
  parsedate:=gog+' '+d+' '+inc+y;
 end;
end;

function ansi:boolean;
begin
 if (ansigraphics in urec.config) then ansi:=true else
  ansi:=false;
end;

function ascii:boolean;
begin
 if (asciigraphics in urec.config) then ascii:=true else
  ascii:=false;
end;

procedure setmenutype;
var n:integer;
begin
  writehdr ('Menu Type');
  write ('Current setting: '^S);
  case urec.menutype of
   0:writeln ('Standard Menus');
   1:writeln ('Hotkey Menus');
   2:writeln ('Pulldown Menus');
  end;
  writeln (^B^M'Would you like:');
  writeln;
  writeln (' [0]: Standard Menus [probably use these]');
  writeln (' [1]: Hotkey Menus [one-key]');
  writeln (' [2]: Pulldown Menus [Ansi required]');
  writeln;
  writestr (^M'Your choice [CR/Exit]:');
  if length(input)<1 then exit;
  n:=valu(input);
  if (n>-1) and (n<3) then begin
   case n of
    0:urec.menutype:=0;
    1:urec.menutype:=1;
    2:urec.menutype:=2;
   end;
   writeurec
  end
end;

procedure movexy (x,y:integer);
begin
 writestr (#27+'['+strr(y)+';'+strr(x)+'f');
end;

procedure ansicls;
begin
 if (ansigraphics in urec.config) then
 write (#27+'[2J') else
 write (^L);
end;

  procedure doitbro (k:char);
  var n:integer;
  begin
    if inuse<>1
      then writecon (k)
      else begin
        bottom;
        writecon (k);
        top
      end;
    if wherey>lasty then gotoxy (wherex,lasty);
    if (not modemoutlock) and ((k<>#10) or uselinefeeds)
      then begin
       if online then sendchar(k);
      end;
    if texttrap then begin
      write (ttfile,k);
      n:=ioresult;
      if n<>0 then abortttfile (n)
    end;
    if printerecho then write (lst,k)
  end;

  procedure domacro (sussuh:anystr);
  var x:integer;
  begin
   for x:=1 to length(sussuh) do
   begin
    if sussuh[x]='~' then writeln(input) else
    doitbro (sussuh[x]);
   end;
  end;

  procedure idiot;
  begin
   writeln ('The writers of TCS are NOT idiots... YOU are.');
  end;

begin
end.