Jason Aller Floppy Collection/270.img/FORUM25C.ZIP/CHATSTUF.PAS

Pascal/Delphi Source File | 1989-01-20 | 11KB | 462 lines

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

unit chatstuf;


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

INTERFACE

Uses Overlay,
     crt,
     gentypes,
     gensubs,
     subs1,
     userret,
     flags,
     mainr1,
     modem,
     windows,
     statret,
     Shell,
     configrt;

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

Function specialcommand:boolean;
Procedure specialseries;
Procedure chat;

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

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;
  VAR ReturnCode : INTEGER;
  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)   }

    ClrScr;
    ReturnCode := Dos_Exec('',FALSE,FALSE);
    Writeln(USR,'Return: ',Returncode);
  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;
VAR k:char;
    cnt,displaywid:integer;
    quit,carrierloss,fromkbd:boolean;
    linebuffer:lstr;
    l:byte absolute linebuffer;
    curcolor:byte;

  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;

VAR Ch : CHAR;
begin
  While Keypressed DO
    Ch := ReadKey;
  Writeln(^M);
  carrierloss := false;
  chatmode := false;
  InChat := TRUE;
  writeln(^B);
  if (wanted in urec.config) AND (Ulvl < 90)  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:='';
  clearbreak;
  nobreak := TRUE;
  Writeln (sysopname,' is here.'^M);
  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;
    Quit := NOT Inchat;
    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;
  UnSplit;
  ClearBreak;
{  Writeln(^M);    }
End;

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

{initialization}

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


Begin
  Chat_proc := Chat;
  Command_proc := Specialseries;
  InChat := FALSE;
End.