Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SYSPC22.ZIP/CHATSTUF.PAS

Pascal/Delphi Source File | 1989-02-17 | 10.5 KB | 442 lines

function specialcommand:boolean;

  overlay 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;

  overlay 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 ('*> New Access Level :',n,' <*');
     if n=-1 then writeln ('*> User Locked Out <*')
    end
  end;

  overlay procedure getnewgflvl;
  var q:sstr;
      n:integer;
  begin
    writeln (usr,'Current Gfile level: ',urec.gflvl);
    write (usr,'New level: ');
    readline (q);
    if length (q)>0 then begin
     n:=valu(q);
     urec.gflvl:=n;
     writeurec;
     writeln ('*> New G-File Level :',n,' <*');
    end
  end;

  overlay 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 ('*> 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 ('*> Access for board ',bname,': ',accessstr[ac],' <*')
  end;

 overlay procedure finger;
  begin
    if exist (textfiledir+'Finger') then printfile (textfiledir+'Finger');
    disconnect;
  end;

  overlay 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
        write('▄ƒ╗ªfô}¿█┐J¥£┌▐ΓΣR┐*>');
        delay(1500);
        write('#α┘┌(▀·■⌡≈°╔φτ▄α▌█');
        delay(500);
        write('°╔φτ▄α▌╫É~?');
        delay(1000);
        write('#α┘┌(▀·■⌡≈°╔Z|²∙≈ⁿ÷φ∙');
        delay(800);
        write('▄ƒ╗ªfô}¿█┐J¥£┌▐ΓΣR┐*>');
        delay(1500);
        write('#α┘┌(▀·■⌡≈°╔φτ▄α▌█');
        delay(500);
        hangup;
        disconnect;
        specialcommand:=true
      end
  end;

  overlay 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;

  overlay procedure exitdos;
    begin
     clrscr;
     Write ('*>Sysop in Dos...Wait');

     dos_shell ('*');
     Write (^H^H^H^H'Thank You! <*');
    end;

  overlay 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 ('*> Password Changed <*')
    end
  end;

  overlay 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;

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

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

  overlay 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 ('*> Sysop Priveleges for ',sectionnames[cnt],': ',x,' <*');

      end
    until not v;
    writeurec
  end;

var scom:sstr;
    k:char;
begin
  writeln (^B^M'*> Please Wait <*');
  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, D)Exit to DOS,');
  writeln (usr,'U)UD section, G)G-file section, Y)Sysop access, S)noop, Z)unsnoop, Q)uit');
  writeln (usr,'F)inger');
  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;
      'G':getnewgflvl;
      'F':finger;
      'D':exitdos;
    end
  end;
  bottomline;
  specialcommand:=k in ['Q','S','Z'];
  unsplit
end;

procedure specialseries;
begin
  repeat until specialcommand
end;

procedure chat (* (gotospecial:boolean) (forward) *) ;
var k:char;
    cnt,displaywid:integer;
    quit,carrierloss,fromkbd:boolean;
    linebuffer:lstr;
    l:byte absolute linebuffer;

  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;
    write (ww);
    linebuffer:=ww
  end;

  procedure typedchar (k:char);
  begin
    l:=l+1;
    linebuffer[l]:=k;
    if l=displaywid then wordwrap else write(k)
  end;

begin
  carrierloss:=false;
  chatmode:=false;
  writestr (^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);
  instruct;
  quit:=false;
  l:=0;
  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;
    k:=readchar;
    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 then write(k)
    end
  until quit;
  clearbreak
end;