Jason Aller Floppy Collection/189.img/TCS120S.ZIP/CHATMOD.PAS

Pascal/Delphi Source File | 1989-02-24 | 11KB | 451 lines

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

unit chatstuf;

interface

uses crt,dos,
     gentypes,gensubs,subs1,userret,flags,mainr1,modem,windows,statret,configrt;

function specialcommand:boolean;
procedure specialseries;
procedure chat (gotospecial:boolean);

implementation

function specialcommand:boolean;

  procedure getnewtime;
  var q:sstr;
      n:integer;
  begin
    n:=timeleft;
    writeln (usr,'The user has ',n,' minutes left.');
    write (usr,'New time left for today? ');
    readline (q);
    if length(q)>0 then begin
      urec.timetoday:=urec.timetoday+(valu(q)-n);
      writeurec;
      writeln ('You have been granted ',timeleft,' minutes for today.')
    end
  end;

  procedure getnewlevel;
  var q:sstr;
      n:integer;
  begin
    writeln (usr,'Current level: ',ulvl);
    write (usr,'New level [-1 to trash]: ');
    readline (q);
    if length (q)>0 then begin
     n:=valu(q);
     ulvl:=n;
     urec.level:=n;
     writeurec;
     writeln ('You have been granted level ',n,' access.');
     if n=-1 then writeln ('That means you''ve been thrown off this system.')
    end
  end;

  procedure getnewaccess;
  var q,bname:sstr;
      bn:integer;
      ac:accesstype;
      wasopen:boolean;
      k:char;

    function inputaccess (q:sstr):accesstype;
    begin
      inputaccess:=invalid;
      if length(q)=0 then exit;
      case upcase(q[1]) of
        'L':inputaccess:=letin;
        'B':inputaccess:=bylevel;
        'K':inputaccess:=keepout
      end
    end;

    procedure getallaccess;

      procedure setallaccess (ac:accesstype);
      var cnt:integer;
      begin
        setalluserflags (urec,ac);
        writeln ('Your access to all sub-boards: ',accessstr[ac]);
        writeurec
      end;

    begin
      write (usr,'Grant ALL access ([B]y level, [L]et in, [K]eep out, or CR): ');
      readline (q);
      ac:=inputaccess(q);
      if ac<>invalid then setallaccess(ac)
    end;

  var bd:boardrec;
  begin
    write (usr,'Which board for which to change access [*=all]: ');
    readline (bname);
    if length(bname)=0 then exit;
    if bname='*' then
      begin
        getallaccess;
        exit
      end;
    opentempbdfile;
    bn:=searchboard(bname);
    if bn=-1 then
      begin
        closetempbdfile;
        writeln (usr,'No such board!  Press any key..');
        k:=bioskey;
        exit
      end;
    writeln (usr,'Board ',bname,'... Current access: ',
      accessstr[getuseraccflag(urec,bn)]);
    write (usr,'Grant access ([B]y level, [L]et in, [K]eep out, or CR: ');
    readline (q);
    ac:=inputaccess(q);
    if ac=invalid then begin
      closetempbdfile;
      exit
    end;
    setuseraccflag (urec,bn,ac);
    writeurec;
    closetempbdfile;
    writeln ('New access for board ',bname,': ',accessstr[ac])
  end;

  procedure hangupyn;
  var q:sstr;
  begin
    write (usr,'Hang up on him (Y/N)? ');
    readline (q);
    if length(q)>0 then if upcase(q[1])='Y' then
      begin
        writeln ('*** System going down ***    '^M^M);
        hangup;
        forcehangup:=true;
        specialcommand:=true
      end
  end;

  procedure getnewname;
  var m:mstr;
      n:integer;
      t:string[1];
  begin
    writeln (usr,'Current name: ',unam);
    write (usr,'New name: ');
    readline (m);
    if length(m)<>0 then begin
      if not validuname(m) then begin
        writeln (usr,'Invalid name!');
        exit
      end;
      n:=lookupuser(m);
      if n<>0 then begin
        write (usr,'Name already exists!  Are you sure? ');
        buflen:=1;
        readline (t);
        if upcase(t[1])<>'Y' then exit
      end;
      unam:=m;
      urec.handle:=m;
      writeurec;
      writeln ('Your name is changed to ',unam,'.')
    end
  end;

  procedure getnewpassword;
  var m:mstr;
  begin
    writeln (usr,'Current password: ',urec.password);
    write (usr,'New password: ');
    readline (m);
    if length(m)<>0 then begin
      urec.password:=m;
      writeurec;
      writeln ('Your password has been changed.')
    end
  end;

  procedure getnewud;
  var m:mstr;

    procedure getnewud1 (var i:integer; q:sstr);
    begin
      if length(m)>1
        then i:=valu(copy(m,2,255))
        else begin
          writeln (usr,'New file transfer '+q+'? ');
          readline (m);
          if length(m)=0
            then exit
            else i:=valu(m)
        end;
      writeln ('New file transfer ',q,': ',i);
      writeurec
    end;

  begin
    writeln (usr,'Current upload L)evel:  ',urec.udlevel);
    writeln (usr,'Current upload P)oints: ',urec.udpoints);
    write (usr,'Enter L, P, or CR for neither: ');
    readline (m);
    if length(m)>0 then begin
      case upcase(m[1]) of
        'L':getnewud1 (urec.udlevel,'level');
        'P':getnewud1 (urec.udpoints,'points')
      end
    end
  end;

  procedure snoopmode;
  begin
    writeln (usr,'All I/O to the modem is locked.');
    modeminlock:=true;
    setoutlock (true)
  end;

  procedure unsnoop;
  begin
    writeln (usr,'I/O to the modem is re-enabled.');
    modeminlock:=false;
    setoutlock (false)
  end;

  procedure gotodos;
  begin
    writeln ('The sysop has dropped into DOS; please wait...');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
    updateuserstats (false);
    writereturnbat;
    ensureclosed;
    halt (4)
  end;

  procedure getsysopaccess;
  const sysopstr:array [false..true] of string[6]=('Normal','Sysop');
        sectionnames:array [udsysop..databasesysop] of string[20]=
          ('File transfer','Bulletin section','Voting booths',
           'E-mail section','Doors','Main menu','Databases');
  var cnt:configtype;
      x:string[10];
      n,mx:integer;
      v:boolean;
  begin
    repeat
      clrscr;
      mx:=1;
      for cnt:=udsysop to databasesysop do begin
        write (usr,mx:3,'. ',sectionnames[cnt]);
        mx:=mx+1;
        gotoxy (25,wherey);
        writeln (usr,sysopstr[cnt in urec.config])
      end;
      write (usr,^M^J'Number to toggle [CR to exit]: ');
      buflen:=1;
      readline (x);
      n:=valu(x);
      v:=(n>0) and (n<mx);
      if v then begin
        cnt:=configtype(ord(udsysop)+n-1);
        if cnt in urec.config
          then
            begin
              urec.config:=urec.config-[cnt];
              x:='denied'
            end
          else
            begin
              urec.config:=urec.config+[cnt];
              x:='granted'
            end;
        writeln ('You have been ',x,' sysop priveleges for the ',
                 sectionnames[cnt],'.')
      end
    until not v;
    writeurec
  end;

var scom:sstr;
    k:char;
begin
  writeln (^B^M'One moment please...');
  splitscreen (12);
  top;
  clrscr;
  specialcommand:=false;
  writeln (usr,'Special commands:');
  writeln (usr,'N)ame, P)assword, L)evel, T)ime left, B)oard access, H)ang up, U)UD section,');
  writeln (usr,'Y)Sysop access, S)noop, Z)unsnoop, D)OS, Q)uit');
  write (usr,'---> ');
  readline (scom);
  clearbreak;
  k:=' ';
  if length(scom)>0 then begin
    k:=upcase(scom[1]);
    case k of
      'L':getnewlevel;
      'B':getnewaccess;
      'H':hangupyn;
      'N':getnewname;
      'P':getnewpassword;
      'L':getnewlevel;
      'T':getnewtime;
      'U':getnewud;
      'S':snoopmode;
      'Z':unsnoop;
      'Y':getsysopaccess;
      'D':gotodos;
    end
  end;
  bottomline;
  specialcommand:=k in ['Q','S','Z'];
  unsplit
end;

procedure specialseries;
begin
  repeat until specialcommand
end;

procedure chat (gotospecial:boolean);
var k:char;
    cnt,displaywid:integer;
    quit,carrierloss,fromkbd:boolean;
    linebuffer:lstr;
    l:byte absolute linebuffer;
    curcolor:byte;
    baudst,commst:mstr;

  procedure instruct;
  begin
    splitscreen (3);
    top;
    clrscr;
    write (usr,'Now in chat mode.  Press <F1> to leave or <F2> for commands.');
    bottom
  end;

  procedure wordwrap;
  var cnt,wl:integer;
      ww:lstr;
  begin
    ww:='';
    cnt:=displaywid;
    while (cnt>0) and (linebuffer[cnt]<>' ') do cnt:=cnt-1;
    if cnt=0 then ww:=k else begin
      ww:=copy(linebuffer,cnt+1,255);
      wl:=length(ww)-1;
      if wl>0 then begin
        for cnt:=1 to wl do write (^H);
        for cnt:=1 to wl do write (' ')
      end
    end;
    writeln;
    ansicolor (curcolor);
    write (ww);
    linebuffer:=ww
  end;

  procedure typedchar (k:char);
  var ec:byte;
  begin
    l:=l+1;
    linebuffer[l]:=k;
    if fromkbd then ec:=urec.regularcolor else ec:=urec.inputcolor;
    if curcolor<>ec then begin
      curcolor:=ec;
      ansicolor (curcolor)
    end;
    if l=displaywid then wordwrap else write(k)
  end;

begin
  carrierloss:=false;
  chatmode:=false;
  writeln (^B^M);
  if wanted in urec.config then begin
    specialmsg ('(No longer wanted)');
    urec.config:=urec.config-[wanted];
    writeurec;
  end;
  if eightycols in urec.config then displaywid:=80 else displaywid:=40;
  if length(chatreason)>0 then specialmsg ('(Chat reason: '+chatreason+')');
  chatreason:='';
  if gotospecial then begin
    specialseries;
    exit
  end;
  clearbreak;
  nobreak:=true;
  writeln (^M^M,sysopname,' is here.'^M);
{ added following for Full Screen Chat external program }
{ added by R. Neal - Corporate Headquarters BBS [phone] }
   if exist ('chat.exe') then begin
      if (ansigraphics in urec.config) or (vt52 in urec.config) then begin
         str (baudrate:3,baudst); {convert baud setting to string}
         str (usecom:1,commst);   {convert com port to string}
         exec ('chat.exe ','0 '+commst+' '+baudst);
         setparam(usecom, baudrate, parity);
         clrscr;
         exit;
      end;
    end;
{ end of Full Screen Chat mod }
  instruct;
  quit:=false;
  l:=0;
  curcolor:=urec.regularcolor;
  repeat
    linecount:=0;
    if (not carrierloss) and (not carrier) then begin
      carrierloss:=true;
      writeln (^M'No one''s here to chat with!'^M)
    end;
    repeat until keyhit or (carrier and (numchars>0));
    fromkbd:=keyhit;
    ingetstr:=true;
    read (directin,k);
    if k=#127 then k:=#8;
    if requestchat
      then if requestcom
        then
          begin
            quit:=specialcommand;
            if not quit then instruct;
            clearbreak;
            nobreak:=true;
            l:=0
          end
        else
          begin
            unsplit;
            quit:=true
          end;
    case ord(k) of
      8:if l>0 then begin
          write (k+' '+k);
          l:=l-1
        end;
      0:;
      13:begin
           writeln;
           bottomline;
           l:=0
         end;
      32..126:typedchar (k);
      1..31:if fromkbd and carrier then sendchar(k)
    end
  until quit;
  clearbreak
end;

begin
end.