Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FORUM25C.ZIP/SUBS2.PAS

Pascal/Delphi Source File | 1989-02-08 | 14.5 KB | 572 lines

{$R-,S-,I-,D-,V-,B-,N-,L- }
{$O+}

unit subs2;

{ $define testingdevices}   (* Activate this define for test mode *)


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

interface

uses printer,
     dos,
     crt,
     StrLib,
     gentypes,
     configrt,
     gensubs,
     subs1,
     windows,
     modem,
     statret,
     chatstuf,
     flags;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

TYPE AllignTypes = (Left,Right,Middle);

Procedure beepbeep;
Procedure summonbeep;
Procedure abortttfile (er:integer);
Procedure openttfile;
Procedure writecon (k:char);
Procedure toggleavail;
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);
    { KEVIN: These aren't necessary, are they?? }
      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;

Function getinputchar:char;
Procedure getstr;
Procedure writestr (s:anystr);
Procedure cls;
Procedure writehdr (q:anystr);
Function issysop:boolean;
Procedure reqlevel (l:integer);
Procedure printfile (fn:lstr);
Procedure printtexttopoint (VAR tf:text);
Procedure skiptopoint (VAR tf:text);
Function minstr (blocks:integer):sstr;
Procedure parserange (numents:integer; VAR f,l: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);
Function Response(ChoiceList : String) : CHAR;
Procedure Center(CenterString : String; ScreenWidth : BYTE);
Procedure WaitReturn;
Procedure TopOfBox(ScreenWidth : BYTE);
Procedure BoxText(StringBox : String78; ScreenWidth : BYTE;
                  AllignMent : AllignTypes);
Procedure MiddleBar(ScreenWidth : BYTE);
Procedure BottomOfBox(ScreenWidth : BYTE);
Procedure BoxString(StringBox : String80; Size : BYTE);
Function WidthScreen : BYTE;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

implementation

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


Procedure beepbeep;
begin
  nosound;
  sound (200);
  delay (10);
  nosound
end;

{=============================================================================}

Procedure summonbeep;
VAR cnt:integer;
begin
  nosound;
  cnt:=1330;
  repeat
    sound (cnt);
    delay (10);
    cnt:=cnt+200;
  until cnt>4300;
  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
    Begin
      TextTrap := TRUE;
      Writeln(TtFile,'-%- Forum-PC Text Trap File -%-');
      Writeln(TtFile,'Date: ',DateStr(Now),'  ',TimeStr(Now),'');
      Writeln(TtFile);
    END
  ELSE
    abortttfile (n)
end;

{=============================================================================}

Procedure writecon (k:char);
VAR r:registers;
begin
  if k=^J
    then write (usr,k)
    else
      begin
        r.dl:=ord(k);
        r.ah:=2;
        intr($21,r)
      end
end;

{=============================================================================}

Procedure toggleavail;
begin
  if sysopavail=notavailable
    then sysopavail:=available
    else sysopavail:=succ(sysopavail)
end;

{=============================================================================}

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 (7);
          top;
          clrscr;
          write (usr,'File Level:     ',urec.udlevel,
                 ^M^J'File Points:    ',urec.udpoints,
                 ^M^J'XMODEM uploads: ',urec.uploads,
                 ^M^J'XMODEM dnloads: ',urec.downloads);
          window (40,1,80,5);
          gotoxy (1,1);
          write (usr,'Posts:      ',urec.nbu,
                 ^M^J'Uploads:    ',urec.nup,
                 ^M^J'Downloads:  ',urec.ndn,
                 ^M^J'Total Time: ',urec.totaltime:0:0,
                 ^M^J'Num. calls: ',urec.numon);
          window (1,1,80,5);
          bottom
        end;
  end;

  Procedure showhelp;
  begin
    if splitmode
      then unsplit
      else begin
        splitscreen (10);
        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,
'Grant user more time: Alt-M      Take away user''s time: Alt-L'^M^J,
'Take away ALL time: Alt-K        Refresh the bottom line: Alt-B'^M^J,
'Toggle printer echo: Ctrl-PrtSc  Toggle text trap: Alt-E'^M^J,
'View user''s status: Alt-V');
    end;
  end;

  Procedure toggletexttrap;
  VAR n:integer;
  begin
    if texttrap
      then
        begin
          Writeln(TtFile,'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=');
          Writeln(TtFile);
          textclose (ttfile);
          n:=ioresult;
          if n<>0 then abortttfile (n);
          texttrap:=false
        end
      else openttfile
  end;

VAR k:char;
    ret:char;
    dorefresh:boolean;
begin
  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
                k := #0;
                Command_proc;
                If NOT InChat THEN Write(^B^M^M^P,lastprompt);
                ChainStr := '';
              End;
            breakoutchar : halt(e_controlbreak);
            lesstimechar : urec.timetoday:=urec.timetoday-1;
            moretimechar : urec.timetoday:=urec.timetoday+1;
            notimechar : settimeleft (-1);
            Chatchar : Begin
                         If Inchat THEN
                            Begin
                              InChat := FALSE;
                              ChainStr := '';
                              write(^B^M^M^P,lastprompt);
                            End
                         ELSE
                           Begin
                             InChat := TRUE;
                             k := #0;
                             Chat_proc;
                           End;
                       End;
            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;
            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 : Begin
             beepbeep;
             SendChar(k);
           End;
      ^L : Begin
             cls;
             SendChar(k);
           End;
      ^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;

{=============================================================================}

{$I IOtxtFil.Sub}
{$I IOStrings.Sub}

{=============================================================================}

Procedure cls;
begin
  bottom;
  clrscr;
  bottomline
end;

{=============================================================================}

Procedure writehdr (q:anystr);
VAR cnt:integer;
begin
  writeln (^B^M);
  for cnt:=1 to (40-length(q)) div 2 do write (' ');
  write (q,^M^M^B)
end;

{=============================================================================}

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

{=============================================================================}

Procedure reqlevel (l:integer);
begin
  writeln (^B'Nice try, but level ',l,' is required.')
end;

{=============================================================================}

{$I Prntfile.sub}
{$I Ranges.sub}
{$I Menu.sub}
{$I Password.sub}

{=============================================================================}

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;

{=============================================================================}

{$I Frmstf.pas}

begin
end.