unit readonce;
{$O+,F+}
{$N+,E+,V-,B-,R-}

interface

uses dos,rgoods;

const imzadi='IMZADI';
      dorinfo=1;
      pcbsys =2;
      doorsys=3;
      callinfo=4;

procedure readcallinfo;
procedure readdoorsys;
procedure readpcbsys;
function  dorinfonode(n:word):string;
Procedure ReadDorInfo;
function  ulsize:integer;
Function  FindDupe(Name:String):Boolean;
Procedure NewUser;
procedure checkevents(name:namestr);
procedure purgeevent(name:namestr);
procedure recover;
procedure zeromoves;
procedure getlocalname;
function  ansidetect:boolean;
procedure killstat;
procedure makestat;
function  xpath(s:string):string;
function  rand4char:string;

implementation

uses crt,bbskv,bbskern,engine2,toyinfo,rkey,usered,miscpl5,nanocore,
     miscpl3,miscpl2,miscplay,message1,cheri2,ranchlin,sys_msg;

procedure stripnonnum(var s:string);
var i:integer;
begin
  i:=1;
  while i<=length(s) do
    if not(s[i] in ['0'..'9']) then delete(s,i,1) else inc(i);
end;

function xpath(s:string):string;
var p:string;
begin
  p:=rundir;      if exist(p+s) then begin xpath:=addslash(p)+s; exit; end;
  p:='.\';        if exist(p+s) then begin xpath:=p+s; exit; end;
  p:='.\DOORS\RANCHO\'; if exist(p+s) then begin xpath:=p+s; exit; end;
  p:='\RANCHO\';  if exist(p+s) then begin xpath:=p+s; exit; end;
  p:='\DOORS\RANCHO\'; if exist(p+s) then begin xpath:=p+s; exit; end;
  p:='C:\DOORS\';   if exist(p+s) then begin xpath:=p+s; exit; end;
  p:='C:\RANCHO\';  if exist(p+s) then begin xpath:=p+s; exit; end;
  p:='C:\DOORS\RANCHO\'; if exist(p+s) then begin xpath:=p+s; exit; end;
  xpath:=rundir+s;
end;

procedure readcallinfo;
const fname:string[13]='CALLINFO.BBS';
var f:text;
    index:word;
    filename:string[72];
begin
  filename:=dipath+fname; if not exist(filename) then filename:=fexpand(xpath(filename));
  consoleonly:=false;
  ignorecarrier:=false;
  nodoorinfo:=false;
  if
    not exist(filename)
  then
    begin
      nodoorinfo:=true;
      exit;
    end;
  writeln(' þþþ Reading ',upcasestr(filename),' ...');
  assign(f,filename);
  reset(f);
  readln(f,tstr);
  username:=tstr;
  readln(f,tstr);
  baudrate:=str2int(tstr);
  if baudrate=0 then begin consoleonly:=true; ignorecarrier:=true; localmode:=true; end;
  if baudrate=5 then begin consoleonly:=true; ignorecarrier:=true; localmode:=true; end;
  readln(f,tstr);
  readln(f,tstr); {Read 2 lines of unused data}
  readln(f,tstr);
  dorinfotime:=str2int(tstr);
  parity:='N'; bits:=8; stop:=1;
  if registree then bbsname:=key.bbsname else BBSName:='The BBS';
  ansi:=true;
  readln(f,tstr); if upcasestr(tstr)='MONO' then ansi:=false;
  for index:=1 to 21 do readln(f,tstr);
  readln(f,tstr);
  if upcasestr(tstr)='LOCAL' then begin consoleonly:=true; ignorecarrier:=true; end;
  readln(f,tstr);

  if
    not(isnum(tstr[1]))
  then
    repeat
      tstr:=copy(tstr,2,length(tstr)-1)
    until isnum(tstr[1]) or (tstr[0]=#00);
  if
    not(isnum(tstr[length(tstr)]))
  then
    repeat
      tstr[0]:=chr(ord(tstr[0])-1)
    until tstr[length(tstr)]<>#32;
  comport:=str2int(tstr);
  if comport=0 then begin consoleonly:=true; ignorecarrier:=true; localmode:=true; end;
  if tstr[0]=#00 then writeln('Callinfo.BBS Comport Line Parse Error');
  close(f);
end;

procedure readdoorsys;
const fname:string[13]='DOOR.SYS';
var f:text;
    index:word;
    filename:string[72];
begin
  filename:=dipath+fname; if not exist(filename) then filename:=fexpand(xpath(filename));
  consoleonly:=false;
  ignorecarrier:=false;
  localmode:=false;
  nodoorinfo:=false;
  if
    not exist(filename)
  then
    begin
      nodoorinfo:=true;
      exit;
    end;
  writeln(' þþþ Reading ',upcasestr(filename),' ...');
  assign(f,filename);
  reset(f);

  readln(f,tstr); {Com port - line 1}
  if
    not(isnum(tstr[1]))
  then
    repeat
      tstr:=copy(tstr,2,length(tstr)-1)
    until isnum(tstr[1]) or (tstr[0]=#00);
  if
    not(isnum(tstr[length(tstr)]))
  then
    repeat
      tstr[0]:=chr(ord(tstr[0])-1)
    until tstr[length(tstr)]<>#32;
  comport:=str2int(tstr);
  writeln(tstr,':',comport);
  if tstr[0]=#00 then writeln('Door.Sys Comport Line Parse Error');
  if comport=0 then begin consoleonly:=true; ignorecarrier:=true; localmode:=true; end;

  readln(f,tstr);          {Baud Rate - line 2}
  baudrate:=str2int(tstr);
  if baudrate=0 then begin consoleonly:=true; ignorecarrier:=true; localmode:=true; end;
  writeln(baudrate);

  bits:=8;
  parity:='N';
  stop:=1;
  if registree then bbsname:=key.bbsname else BBSName:='The BBS';

  for index:=1 to 7 do readln(f,tstr);

  readln(f,tstr); {User Name}
  username:=tstr;

  for index:=1 to 8 do readln(f,tstr);

  readln(f,tstr);
  dorinfotime:=str2int(tstr);

  readln(f,tstr);
  ansi:=true; if upcasestr(tstr)='NG' then ansi:=false;

  close(f);
end;

procedure readpcbsys;
const fname:string[13]='PCBOARD.SYS';
type pcbsys=array[0..127] of byte;
     pcbsysc=array[0..127] of char;
var pcb:pcbsys;
    pcbc:pcbsysc absolute pcb;
    f:file of pcbsys;
    index:word;
    tch:char;
    wtmp:word;
    filename:string[72];
begin
  filename:=dipath+fname; if not exist(filename) then filename:=fexpand(xpath(filename));
  consoleonly:=false;
  ignorecarrier:=false;
  localmode:=false;
  nodoorinfo:=false;
  if
    not exist(filename)
  then
    begin
      nodoorinfo:=true;
      exit;
    end;
  writeln(' þþþ Reading ',upcasestr(filename),' ...');
  assign(f,filename);
  reset(f);
  read(f,pcb);
  close(f);

  { Set BBS Name -- hardcoded now but we'll add a BBSNAME config option later }

  if registree then bbsname:=key.bbsname else bbsname:='PC-Board';

  { Set User's name - remove any trailing spaces!}

  index:=0; username:='';
  repeat
    tch:=pcbc[84+index];
    username:=username+tch;
    inc(index);
  until (tch=#00) or (index>24);
  if
    username[length(username)]=#32
  then
    repeat
      username[0]:=chr(ord(username[0])-1)
    until username[length(username)]<>#32;

  { Get the Com Port number }

  tch:=pcbc[125]; tstr:=''+tch; comport:=str2int(tstr);
  if comport=0 then begin consoleonly:=true; ignorecarrier:=true; localmode:=true; end;

  { Get the Baud Rate }

  tstr:=''; index:=0; baudrate:=38400;
  repeat
    tch:=pcbc[18+index];
    tstr:=tstr+tch;
    inc(index);
  until (tch=#00) or (index>4);
  if
    tstr[length(tstr)]=#32
  then
    repeat
      tstr[0]:=chr(ord(tstr[0])-1)
    until tstr[length(tstr)]<>#32;
  if
    upcasestr(tstr)='LOCAL'
  then
    begin
      consoleonly:=true;
      ignorecarrier:=true;
    end
  else
    baudrate:=str2int(tstr);
  if baudrate=0 then begin consoleonly:=true; ignorecarrier:=true; localmode:=true; end;

  { Get the Parity,Bits & Stops; Get ANSi }

  tch:=pcbc[11];
  ansi:=true;
  parity:='N'; bits:=8; stops:=1;
  case tch of
    'N': ansi:=false;
    'Y': ansi:=true;
    '7': begin
           parity:='E';
           bits:=7;
           stops:=1;
         end;
  end; {case}

  { Get the Time Left (not yet supported by RN but might be if users demand it)}

  wtmp:=0;
  wtmp:=pcb[109]*256;
  wtmp:=wtmp+pcb[110];

  dorinfotime:=wtmp;

end;

function dorinfonode(n:word):string;
var z,y:string[12];
begin
  y:='DORINFO1';
  z:=int2str(n);
  index:=0;
  repeat
    y[8-index]:=z[length(z)-index];
    inc(index);
  until index>=length(z);
  dorinfonode:=y+'.DEF';
end;

Procedure ReadDorInfo;
Var F : Text;
    I,J : integer;
    k:longint;
    sss:string[40];
    P2 : String[1];
    filename:string[72];
begin
  localmode:=false;
  filename:=dipath+(dorinfonode(dinode));
  if not exist(filename) then filename:=fexpand(xpath(dorinfonode(dinode)));
  nodoorinfo:=false;
  If
    Not(Exist(filename))
  then
    Begin
      nodoorinfo:=true;
      exit;
    End;
  writeln(' þþþ Reading ',upcasestr(filename),' ...');
  Assign(F,filename);
  Reset(F);
  Readln(F,BBSName);
  bbsname:=mixedcase(bbsname);
  Readln(F,STmp); Readln(F,STmp);   { Sysop Name... Not needed}
  Readln(F,STmp);
  stmp:=upcasestr(stmp);
  ComPort := 99;
  consoleonly:=false;
  ignorecarrier:=false;
  localmode:=false;
  If STmp = 'COM0' then begin ConsoleOnly := True; localmode:=true; ignorecarrier:=true; comport:=0; end;
  If STmp = 'COM1' then Comport := 1;
  If STmp = 'COM2' then Comport := 2;
  If STmp = 'COM3' then Comport := 3;
  If STmp = 'COM4' then Comport := 4;
  baudrate:=38400;
  Readln(F,STmp);     {'19200 baud,n,8,1' Baud Rate: Don't forget to parse!}
  I := Pos(' ',STmp);
  sss:=copy(stmp,1,i-1);
  Val(sss,Baudrate,J);
  Parity := Upcase(STmp[I+5]);
  Val((Copy(STmp,I+7,1)),Bits,J);
  Val((Copy(STmp,I+9,1)),Stops,J);

  Readln(F,I);            {Network Flag}
  Readln(F,STmp);  Readln(F,UserName);
  If UserName = 'NLN' then UserName := STmp
    else UserName := STmp + ' ' + UserName;
  if
    username[length(username)]=#32
  then
    repeat
      username[0]:=chr(ord(username[0])-1)
    until username[length(username)]<>#32;
  Readln(F,STmp);                                   {Where From}
  Readln(F,I);
  Case I of
    0 : ansi := False;
    1 : ansi := True;
  end;
  ansi:=ansi;
  Readln(F,k);              {Access level}
  Readln(F,dorinfotime);
  Close(F);
end;

function ulsize:integer;
begin
  ulsize:=maxuser;
end;

Function FindDupe(Name:String):Boolean;
{Find User "GameName" and return with 'User' = his data & 'I' his #}
var tmpf:boolean;
    idx:integer;
begin
  If
    maxuser=0
  then
    Begin
      finddupe:=false;
      Exit;
    End;
  tmpf:=false;
  idx:=1;
  repeat
    begin
      TmpUser:=userlog^[idx];
      If
        (TmpUser.Name = Name)
      then
        tmpf := True;
      inc(idx);
    end;
  until tmpf or (idx>maxuser);
  finddupe:=tmpf;
end;

Procedure NewUser;
{ Get UserName, check for duplication, make newuser}
Var S:namestr;
    got:boolean;
begin
  if username[0]>#24 then username[0]:=#24; {Truncate user name at 24 chars}
  editmode:=true;
  default(user);
  default(tmpuser);
  default(user2);
  if
    ansi
  then
    SendText('NEWUSER.ANS')
  else
    sendtext('NEWUSER.ASC');
  sysmsg(660);
  ctmp:=yn;
  If quitnow then shutdown; If (CTmp = 'N') then
  begin
    parameter[1]:=bbsname;
    sysmsg(661);
    Window(1,24,80,25); ClrScr; Window(1,1,80,25); GotoXY(1,22);
    shutdown;
  end;
  repeat
    parameter[1]:=username;
    sysmsg(662);

    S := getlnz(24);
    If
      (S = '')
    then
      begin
        S := UserName;
        sendln(s);
      end
    else
      sendln('');
    if s[1] in ['a'..'z'] then s[1]:=upcase(s[1]); {Mixcase if all lower}
    send('`P`a`1');
    if quitnow then shutdown;
    If
      findDupe(S)
    then
      sysmsg(663);
  Until not(FindDupe(S)) or quitnow or lostcarrier;
  if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
  If quitnow then Exit;
  If
    firstfree=-2
  then
    begin
      sysmsg(664);
      shutdown;
      quitnow:=true;
    End;
  sendln('');

  {Sex determination code}

  user2.gender:=female;
  got:=false;
  repeat
    begin
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
      sysmsg(610);
      get('mf?');
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
      if quitnow then shutdown;
      case upcase(ctmp) of
        'M' : begin user2.gender:=male; sysmsg(611); got:=true; end;
        'F' : begin user2.gender:=female; got:=true; sysmsg(612); end;
        '?' : if ansi then sendtext('birdbees.ans') else sendtext('birdbees.asc');
      end;
    end;
  until got or quitnow or lostcarrier;
  if lostcarrier then begin nocarrier; quitnow:=true; exit; end;

  {Orientation determination code}

  sendln(crlf);
  user2.orientation:=straight;
  got:=false;
  repeat
    begin
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
      sysmsg(613);
      get('sbg?');
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
      if quitnow then shutdown;
      case upcase(ctmp) of
        'S' : begin user2.orientation:=straight; got:=true; sysmsg(614); end;
        'B' : begin user2.orientation:=bi; got:=true; sysmsg(615); end;
        'G' : begin user2.orientation:=gay; got:=true; sysmsg(616); end;
        '?' : if ansi then sendtext('birdbee2.ans') else sendtext('birdbee2.asc');
      end;
    end;
  until got or quitnow or lostcarrier;
  if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
  user2.tori:=false;

  U:=I;

  user2.BBSName := UserName;
  user2.Name := S;

  user:=user2;
  username:=user2.bbsname;
  editmode:=false;
  writeuser(user.name,user);

  sendln('');
end;

procedure checkevents(name:namestr);
var gotit:boolean;
begin
  if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
  sysmsg(665);
  gotit:=false;
  if
    exist(evtname)
  then
    begin
      assign(eventfile,evtname);
      reset(eventfile);
      if
        filesize(eventfile)>0
      then
        repeat
          if lostcarrier then begin close(eventfile); nocarrier; quitnow:=true; exit; end;
          read(eventfile,tempevent);
          if
            ((upcasestr(user.name))=(upcasestr(tempevent.name)))
          then
            begin
              sendln('`L'+tempevent.txt);
              gotit:=true;
            end;
        until eof(eventfile) or quitnow or lostcarrier;
      close(eventfile);
    end;
  if
    not(gotit)
  then
    sysmsg(666);
  awardxp(user,0);
end;

procedure purgeevent(name:namestr);
var f1,f2:file of eventrec;
    te:eventrec;
    tl:longint;
begin
  nukefile('$TMPEVT$.$$$');
  if
    not(exist(evtname))
  then
    exit;
  if
    fsize(evtname)=0
  then
    exit;
  assign(f1,evtname);
  rename(f1,'$TMPEVT$.$$$');
  assign(f1,'$TMPEVT$.$$$');
  assign(f2,evtname);
  reset(f1);
  rewrite(f2);
  repeat
    read(f1,te);
    if
      (not(upcasestr(te.name)=upcasestr(user.name)))
    and
      (not(te.datewritten+604800<sec70))
    then
      write(f2,te);
  until eof(f1);
  close(f1);
  close(f2);
  erase(f1);
end;

procedure recover;
var topuser:word;
    unum:word;
    done:boolean;
begin
  sysmsg(667);
  if
    maxuser>0
  then
    for
      unum:=1 to maxuser
    do
      userlog^[unum].recovering:=false;
  sysmsg(668);
end;

procedure zeromoves;
var topuser:word;
    unum:word;
    done:boolean;
begin
  sysmsg(669);
  if
    maxuser>0
  then
    for
      unum:=1 to maxuser
    do
      userlog^[unum].playstoday:=0;
  sysmsg(668);
  writeuserlog;
end;

procedure getlocalname;
begin
  if quitnow then exit;
  sysmsg(670);
  username:=mixedcase(getln(24));
  if length(username)<1 then halt;
end;

function ansidetect:boolean;
var echotemp:boolean;
    tch,tch1:char;
    gyes:boolean;
    junk:char;
    start:longint;
begin
  IF
    consoleonly
  THEN
    ANSIDETECT:=TRUE
  ELSE
    BEGIN
      while (dcd and charinbuffer) do junk:=com_rx;
      gyes:=FALSE;
      echotemp:=noecho;
      noecho:=TRUE;
      send(ansidsr);  {Send a DSR}
      delay(300);
      tch:=#0;
      repeat
        begin
          nothing;
          if charinbuffer then tch:=com_rx;
          if
            (tch=esc)
          then
            gyes:=TRUE;
        end
      until lostcarrier or quitnow or not charinbuffer;
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
      noecho:=echotemp;
      ansidetect:=gyes;
      delay(300);
      swallowbuffer;
  END;
  if not gyes
  then begin
         sysmsg(671);
         yndefault:=false;
         junk:=upcase(yn);
         ansidetect:=(junk='Y');
       end;
end;

function rand4char:string;
const megnumbase:string[36]='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var s1:string; t:integer;
begin
  s1:='';
  t:=random(36)+1; s1:=s1+megnumbase[t];
  t:=random(36)+1; s1:=s1+megnumbase[t];
  t:=random(36)+1; s1:=s1+megnumbase[t];
  t:=random(36)+1; s1:=s1+megnumbase[t];
  rand4char:=s1;
end;

procedure makestat;
var z:text;
    s1:string;
begin
  killemall('????-'+int2str(thisusernumber)+'.*');
  s1:='0000'+int2str(thisusernumber); s1:=copy(s1,length(s1)-3,4);
  statname:=rand4char+s1+'.RNS';
  assign(z,statname);
  rewrite(z);
  writeln(z,user.name);
  close(z);
end;

procedure killstat;
begin
  if not(statname[1]='@') then nukefile(statname);
  if not(useronname='') then nukefile(useronname);
  killemall('????-'+int2str(thisusernumber)+'.*');
  textattr:=lightgray;
  window(1,1,80,25);
  gotoxy(1,24);
  exitproc:=exitsave;
end;

begin
  randomize;
end.
