Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FORUM25C.ZIP/CONFIGSR.ZIP/CONFIG.PAS

Pascal/Delphi Source File | 1989-02-08 | 19.4 KB | 906 lines

program config;

{$R-,S+,I-,D+,V-,B-,N-,L+ }
{$M 16384,5000,5000 }

uses crt,
     scrnunit,scrninpt,general,prompts,
     gentypes,configrt;

const normalcolor=6;
      boldcolor=2;
      barcolor=$1f;
      inputcolor=3;
      choicecolor=6;
      datacolor=15;

var prompt:promptset;

procedure writeconfig;
var q:file of configsettype;
begin
  assign (q,'Forum.CFG');
  rewrite (q);
  write (q,configset);
  close (q)
end;

procedure formatconfig;
var cnt:integer;
begin
  versioncode:=thisversioncode;
  longname[0]:=chr(0);
  shortname[0]:=chr(0);
  sysopname[0]:=chr(0);
  getdir (0,forumdir);
  if forumdir[length(forumdir)]<>'\' then forumdir:=forumdir+'\';
  textdir:=forumdir+'text\';
  uploaddir:=forumdir+'files\';
  boarddir:=forumdir+'boards\';
  overlaypath[0]:=#0;
  asciidownload[0]:=#0;
  textfiledir:=forumdir+'textfile\';
  doordir:=forumdir+'doors\';
  modemsetupstr:='ATS0=1|';
  modemhangupstr:='+++~~~ATH|';
  modemdialprefix:='ATDT';
  modemdialsuffix:='|';
  defbaudrate:=1200;
  usecom:=1;
  anonymouslevel:=5;
  numwelcomes:=1;
  mintimeout:=5;
  sysoplevel:=10;
  defudlevel:=0;
  defudpoints:=0;
  normbotcolor:=6;
  normtopcolor:=2;
  outlockcolor:=5;
  splitcolor:=4;
  statlinecolor:=3;
  uploadfactor:=5;
  private:=false;
  autologin:=false;
  useconmode:=true;
  escinmsgs:=false;
  bkspinmsgs:=true;
  requireforms:=false;
  dotchar:='.';
  supportedrates:=[b1200];
  downloadrates:=supportedrates;
  availtime:='10:00 am';
  unavailtime:='10:00 pm';
  xmodemopentime:='3:00 am';
  xmodemclosetime:='3:00 am';
  for cnt:=1 to 100 do usertime[cnt]:=60;
  level2nd:=1;
  udlevel2nd:=0;
  udpoints2nd:=0;
  postlevel:=2;
  anonymousstr:='Anonymous';
  systempassword[0]:=#0;
  remotedoors:=false;
  allowdoors:=true;
  eventtime[0]:=#0;
  eventbatch[0]:=#0;
  directvideomode:=true;
  checksnowmode:=true;
  NewUserLevel:=1;
  Overlay_size := 0;
  Keep_top_ten := TRUE;
  User_name_prompt := 'Please enter your name [enter ''NEW'' if newuser]:';
  MaxLoginTries := 4;
  DataBaseLevel := 0;
  VotingLevel := 0;
  FileLevel := 0;
  EmailLevel := 0;
  BulletinLevel := 0;
  AboutLevel := 0;
  writeconfig
end;


type ttypetype=(TInteger,Tsstr,Tmstr,Tlstr,TBoolean,TChar,TBaudset,
                TPath,TTime,TAttrib,Tusertime,Badtype);
     ptrset=record
       case integer of
         0:(i:^integer);
         1:(l:^lstr);
         2:(b:^boolean);
         3:(k:^char);
         4:(baudsetptr:^baudset)
     end;
     thing=record
       text:mstr;
       descrip:lstr;
       ttype:ttypetype;
       p:pointer;
       r1,r2:integer
     end;

const ttypestr:array [ttypetype] of sstr=
  ('Int','sstr','mstr','lstr','Boo','Char','Baud','Path','Time',
   'Attrib','Usertime','!!!!????');
      colorstr:array [0..15] of mstr=
  ('Black','Blue ','Green ','Cyan ','Red ','Magenta ','Brown ','White ',
   'Gray ','BLUE!','GREEN!','CYAN!','RED!','MAGENTA!','Yellow','WHITE!');

const maxthings=100;
      dcol=30;

var top,bot,page,numpages,numthings:integer;
    things:array [1..maxthings] of thing;

procedure cb;
begin
  setcolor (boldcolor)
end;

procedure c4;
begin
  setcolor (4)
end;

procedure cn;
begin
  setcolor (normalcolor)
end;

procedure c7;
begin
  setcolor (7)
end;

function match(a1,a2:anystr):boolean;
var cnt:integer;
begin
  match:=false;
  while a1[length(a1)]=' ' do a1[0]:=pred(a1[0]);
  while a2[length(a2)]=' ' do a2[0]:=pred(a2[0]);
  if length(a1)<>length(a2) then exit;
  for cnt:=1 to length(a1) do
    if upcase(a1[cnt])<>upcase(a2[cnt]) then exit;
  match:=true
end;

function yesnostr (var b:boolean):sstr;
begin
  if b and (ord(b)<>ord(true)) then b:=true;
  if b then yesnostr:='Yes' else yesnostr:='No'
end;

function strr (n:integer):mstr;
var q:mstr;
begin
  str (n,q);
  strr:=q
end;

function valu (q:mstr):integer;
var i,s:integer;
begin
  val (q,i,s);
  if s=1
    then valu:=0
    else valu:=i
end;

function whichpage (n:integer):integer;
begin
  whichpage:=((n-1) div 20)+1
end;

function whichline (n:integer):integer;
begin
  whichline:=n-20*(whichpage(n)-1)+2
end;

function getbaudstr (var q:baudset):lstr;
var w:lstr;
    cnt:baudratetype;
begin
  w[0]:=chr(0);
  for cnt:=firstbaud to lastbaud do
    if cnt in q then w:=w+strr(baudarray[cnt])+' ';
  if length(w)=0 then w:='None';
  getbaudstr:=w
end;

function varstr (n:integer):string;
var pu:pointer;
    p:ptrset absolute pu;
begin
  pu:=things[n].p;
  case things[n].ttype of
    tinteger:varstr:=strr(p.i^);
    tlstr,tmstr,tsstr,tpath,ttime:varstr:=p.l^;
    tboolean:varstr:=yesnostr(p.b^);
    tchar:varstr:=p.k^;
    tbaudset:varstr:=getbaudstr (p.baudsetptr^);
    tattrib:varstr:=colorstr[p.i^];
    tusertime:varstr:='(Choose this choice to configure user daily time)';
    else varstr:='??!?!?!'
  end
end;

procedure writevar (n:integer);
begin
  cb;
  write (varstr(n));
  cn; clreol;
  writeln
end;

procedure gotopage (p:integer);
var cnt,cy:integer;
begin
  if p<1 then p:=1;
  if p>numpages then p:=numpages;
  if p<>page then begin
    if page<>0 then freeprompts (prompt);
    page:=p;
    gotoxy (1,1);
    cn; write ('Page ');
    cb; write (page);
    cn; write (' of ');
    cb; write (numpages);
    cn; writeln (':  ');
    writeln;
    top:=(page-1)*20+1;
    bot:=top+19;
    if bot>numthings then bot:=numthings;
    beginprompts (prompt);
    for cnt:=top to top+19 do begin
      cy:=cnt-top+3;
      gotoxy (1,cy);
      cn; clreol;
      if cnt<=bot then begin
        addprompt (prompt,command,prompt,5,cnt-top+3,things[cnt].text+':');
        setinputwid (prompt,0);
        drawprompt (prompt);
        gotoxy (1,cy);
        cn; write (cnt:2,'. ');
        gotoxy (dcol,wherey);
        writevar (cnt)
      end
    end
  end
end;

procedure readdata;
var q:text;
    t:mstr;

  procedure dataerror (n:lstr);
  begin
    writeln ('Record ',numthings,': '+n);
    halt
  end;

  procedure illtype;
  begin
    dataerror ('Invalid type: '+t)
  end;

  procedure getrange (t:mstr; var r1,r2:integer);
  var sp,da,n1,n2:integer;
  begin
    sp:=pos(' ',t);
    r1:=-32767;
    r2:=32767;
    if sp=0 then exit;
    t:=copy(t,sp+1,255);
    if length(t)<1 then exit;
    da:=pos('-',t);
    if (da=1) and (length(t)=1) then exit;
    if da=0 then begin
      r1:=valu(t);
      r2:=r1;
      exit
    end;
    n1:=valu(copy(t,1,da-1));
    n2:=valu(copy(t,da+1,255));
    if da=1 then begin
      r2:=n2;
      exit
    end;
    r1:=n1;
    if da=length(t) then exit;
    r2:=n2
  end;

  procedure gettype (t:mstr; var tt:ttypetype);
  var sp:integer;
      fw:mstr;
  begin
    tt:=ttypetype(0);
    sp:=pos(' ',t);
    if sp=0
      then fw:=t
      else fw:=copy(t,1,sp-1);
    while tt<>badtype do
      begin
        if match(fw,ttypestr[tt]) then exit;
        tt:=succ(tt)
      end;
    tt:=badtype;
    illtype
  end;

begin
  assign (q,'Config.Dat');
  reset (q);
  numthings:=0;
  if ioresult<>0 then dataerror ('File CONFIG.DAT not found!');
  while not eof(q) do begin
    numthings:=numthings+1;
    with things[numthings] do begin
      readln (q,text);
      readln (q,descrip);
      readln (q,t);
      gettype (t,ttype);
      if ttype=tinteger then getrange (t,r1,r2)
    end
  end;
  close (q)
end;

procedure assignptrs;
var cnt:integer;

  procedure s (var q);
  begin
    cnt:=cnt+1;
    things[cnt].p:=@q
  end;

begin
  cnt:=0;
  s (longname);
  s (shortname);
  s (sysopname);
  s (autologin);
  s (textdir);
  s (boarddir);
  s (uploaddir);
  s (textfiledir);
  s (doordir);
  s (overlaypath);
  s (Overlay_size);
  s (supportedrates);
  s (downloadrates);
  s (defbaudrate);
  s (usecom);
  s (modemsetupstr);
  s (modemhangupstr);
  s (modemdialprefix);
  s (modemdialsuffix);
  s (sysoplevel);
  s (anonymouslevel);
  s (numwelcomes);
  s (private);
  s (directvideomode);
  s (checksnowmode);
  s (useconmode);
  s (escinmsgs);
  s (bkspinmsgs);
  s (normbotcolor);
  s (normtopcolor);
  s (outlockcolor);
  s (splitcolor);
  s (statlinecolor);
  s (usertime);
  s (mintimeout);
  s (dotchar);
  s (asciidownload);
  s (defudlevel);
  s (defudpoints);
  s (NewUserLevel);
  s (level2nd);
  s (udlevel2nd);
  s (udpoints2nd);
  s (postlevel);
  s (uploadfactor);
  s (availtime);
  s (unavailtime);
  s (xmodemopentime);
  s (xmodemclosetime);
  s (systempassword);
  s (anonymousstr);
  s (requireforms);
  s (remotedoors);
  s (allowdoors);
  s (eventtime);
  s (eventbatch);
  s (Keep_top_ten);
  s (User_name_prompt);
  s (MaxLoginTries);
  s (DataBaseLevel);
  s (VotingLevel);
  s (FileLevel);
  s (EmailLevel);
  s (BulletinLevel);
  s (AboutLevel);
  if cnt<>numthings then begin
    writeln ('Error in number of items of CONFIG.DAT');
    writeln ('Expected: ',numthings);
    writeln ('Actual:   ',cnt);
    halt
  end
end;

procedure byebye;
begin
  clearwindow (normalcolor);
  gotoxy (38,24);
  cb; writeln ('Bye!');
  halt
end;

procedure abortyn;
var q:sstr;
begin
  gotoxy (1,24);
  c4;
  write ('Confirm abort [Y/N]: ');
  cn;
  clreol;
  buflen:=1;
  readln (q);
  if length(q)>0 then if upcase(q[1])='Y' then byebye
end;

procedure getinput (n:integer; editit:boolean);
var y:integer;
    inp:lstr;
    t:thing;
    pu:pointer;
    p:ptrset absolute pu;

  procedure reshow;
  begin
    gotoxy (dcol,y);
    writevar (n)
  end;

  procedure showintrange;
  begin
    c7;
    with t do
      if r1=-32767
        then if r2=32767
          then write ('No range limitation.')
          else write ('Maximum value: ',r2)
        else if r2=32767
          then write ('Minimum value: ',r1)
          else write ('Valid values range from ',r1,' to ',r2);
    cn
  end;

  procedure doint;
  var n,s:integer;
      k:char;
  begin
    val (inp,n,s);
    gotoxy (1,24);
    if s<>0
      then
        begin
          c4;
          writeln ('Invalid number!  A number must be from -32767 to 32767.');
          cn;
          write ('Press any key...');
          clreol;
          k:=bioskey
        end
      else if (n>=t.r1) and (n<=t.r2)
        then p.i^:=n
        else
          begin
            c4;
            writeln ('Range error!  Must be within the above limits!  ');
            cn;
            write ('Press any key...');
            clreol;
            k:=bioskey
          end
  end;

  procedure dostr;
  begin
    if (inp='N') or (inp='n') then inp:='';
    p.l^:=inp
  end;

  procedure doboolean;
  begin
    case upcase(inp[1]) of
      'Y':p.b^:=true;
      'N':p.b^:=false
    end
  end;

  procedure dochar;
  begin
    p.k^:=inp[1]
  end;

  procedure dopath;
  var lc:char;
      cur:lstr;
      n:integer;
  begin
    lc:=inp[length(inp)];
    if (length(inp)<>1) or (upcase(lc)<>'N')
      then if (lc<>':') and (lc<>'\') then inp:=inp+'\';
    dostr;
    if inp[length(inp)]='\' then inp[0]:=pred(inp[0]);
    getdir (0,cur);
    chdir (inp);
    n:=ioresult;
    chdir (cur);
    if n=0 then exit;
    c4; gotoxy (1,24);
    write ('Path doesn''t exist!  ');
    cn; write ('Create it now? '); clreol;
    readln (cur);
    if length(cur)=0 then exit;
    if upcase(cur[1])<>'Y' then exit;
    mkdir (inp);
    if ioresult=0 then exit;
    gotoxy (1,24);
    c4; write ('Error creating directory!  ');
    cn; write ('Press any key...');
    clreol;
    lc:=bioskey
  end;

  procedure dotime;
  var c,s,l:integer;
      d1,d2,d3,d4:char;
      ap,m:char;

    function digit (k:char):boolean;
    begin
      digit:=ord(k) in [48..57]
    end;

  begin
    l:=length(inp);
    if l=1 then begin
      if upcase(inp[1])='N' then dostr;
      exit
    end;
    if (l<7) or (l>8) then exit;
    c:=pos(':',inp);
    if c<>l-5 then exit;
    s:=pos(' ',inp);
    if s<>l-2 then exit;
    d2:=inp[c-1];
    if l=7
      then d1:='0'
      else d1:=inp[1];
    d3:=inp[c+1];
    d4:=inp[c+2];
    ap:=upcase(inp[s+1]);
    m:=upcase(inp[s+2]);
    if d1='1' then if d2>'2' then d2:='!';
    if (d1>='0') and (d1<='1') and digit(d2) and (d3>='0') and (d3<='5')
       and digit(d4) and ((ap='A') or (ap='P')) and (m='M') then dostr
  end;

  procedure dobaud;
  var inp:lstr;
      n:integer;
      cnt:baudratetype;
  label bfound,again;
  begin
    gotoxy (1,24);
    repeat
      gotoxy (wherex,24);
      write ('Baud rate to toggle [CR to quit]: ');
      clreol;
      buflen:=4;
      readln (inp);
      gotoxy (1,24);
      if length(inp)=0 then exit;
      n:=valu(inp);
      for cnt:=b110 to b9600 do if n=baudarray[cnt] then goto bfound;
      cb; write ('Not supported!  '); cn;
      goto again;
      bfound:
      if cnt in p.baudsetptr^
        then p.baudsetptr^:=p.baudsetptr^-[cnt]
        else p.baudsetptr^:=p.baudsetptr^+[cnt];
      reshow;
      again:
    until 0=1
  end;

  procedure dousertime;
  var input:lstr;
      n:integer;
      buffer:array [1..4096] of byte;
      b:block;

    procedure refresh;
    var cnt:integer;
    begin
      clearwindow (normalcolor);
      gotoxy (1,1);
      cn;
      writeln('Level Time | Level Time | Level Time | Level Time | Level Time');
      writeln('-----------|------------|------------|------------|-----------');
      gotoxy (1,3);
      for cnt:=1 to 100 do begin
        write (cnt:4,': ',usertime[cnt]:4);
        if (cnt mod 5)=0 then writeln else write (' | ')
      end
    end;

    procedure setone (n,v:integer);
    var x,y:integer;
    begin
      x:=((n-1) mod 5)*13+7;
      y:=((n-1) div 5)+3;
      gotoxy (x,y);
      write (v:4);
      usertime[n]:=v
    end;

    procedure getone (n:integer);
    var x,y,v:integer;
    begin
      x:=((n-1) mod 5)*13+7;
      y:=((n-1) div 5)+3;
      gotoxy (x,y);
      write ('    ');
      gotoxy (x,y);
      buflen:=4;
      readln (input);
      v:=valu(input);
      if (v<1) or (v>1000) then v:=usertime[n];
      setone (n,v)
    end;

    function getn (txt:lstr):integer;
    var input:lstr;
    begin
      gotoxy (1,23);
      write (txt,': ');
      clreol;
      buflen:=4;
      readln (input);
      getn:=valu(input)
    end;

    function getlvl (txt:lstr):integer;
    var n:integer;
    begin
      n:=getn (txt);
      if (n<1) or (n>100) then n:=0;
      getlvl:=n
    end;

    procedure pattern;
    var st,en,ba,se,cn:integer;
    begin
      st:=getlvl ('Starting level of pattern');
      if st=0 then exit;
      en:=getlvl ('Ending level of pattern');
      if en<st then exit;
      ba:=getn ('Time for level '+strr(st));
      if (ba<1) or (ba>1000) then exit;
      se:=getn ('Additional time per level');
      if (se<0) or (se>1000) then exit;
      cn:=st;
      repeat
        setone (cn,ba);
        if ba+se<1000
          then ba:=ba+se
          else ba:=1000;
        cn:=cn+1
      until cn>en
    end;

  var k:char;
  begin
    setblock (b,1,1,80,25);
    readblock (b,buffer);
    refresh;
    repeat
      repeat
        gotoxy (1,24);
        write ('Number to change, [P] for a pattern, or [Q] to quit: ');
        clreol;
        readln (input)
      until length(input)>0;
      k:=upcase(input[1]);
      n:=valu(input);
      if (n>=1) and (n<=100) then getone(n) else
        case k of
          'P':pattern
        end
    until k='Q';
    writeblock (b,buffer)
  end;

  procedure showattribhelp;
  var cnt:integer;

    procedure demo;
    begin
      setcolor (cnt);
      write (cnt:2,')',colorstr[cnt],' ')
    end;

  begin
    gotoxy (1,23);
    for cnt:=0 to 7 do demo;
    gotoxy (1,24);
    for cnt:=8 to 15 do demo;
    cn
  end;

  procedure doattrib;
  var cnt,v:integer;
      k:char;
  begin
    v:=valu(inp);
    if ((v=0) and (inp[1]<>'0')) or (v<0) or (v>15) then begin
      v:=-1;
      for cnt:=0 to 15 do if match (inp,colorstr[cnt]) then v:=cnt;
      if v=-1 then exit
    end;
    p.i^:=v
  end;

begin
  t:=things[n];
  pu:=t.p;
  gotopage (whichpage(n));
  y:=whichline(n);
  if not (t.ttype in [tbaudset,tusertime]) then begin
    gotoxy (1,23);
    clreol;
    writeln;
    clreol;
    writeln;
    write (t.descrip);
    clreol;
    gotoxy (1,24);
    case t.ttype of
      tinteger:
        begin
          buflen:=6;
          showintrange
        end;
      tsstr,ttime:buflen:=15;
      tmstr:buflen:=30;
      tlstr,tpath:buflen:=80;
      tboolean,tchar:buflen:=1;
      tattrib:showattribhelp
    end;
    if buflen+dcol>79 then buflen:=79-dcol;
    gotoxy (dcol,y);
    clreol;
    if editit then setdefaultinput (varstr(n));
    readln (inp)
  end else inp[0]:=^A;
  if length(inp)<>0 then
    case t.ttype of
      tinteger:doint;
      tsstr,tmstr,tlstr:dostr;
      tboolean:doboolean;
      tchar:dochar;
      tbaudset:dobaud;
      tpath:dopath;
      ttime:dotime;
      tattrib:doattrib;
      tusertime:dousertime
    end;
  reshow;
  gotoxy (1,23);
  clreol;
  writeln;
  clreol;
  writeln;
  clreol;
  t.p:=pu;
  things[n]:=t
end;

procedure changenum (ns:integer; editit:boolean);
var n:integer;
begin
  n:=ns+top-1;
  if (n<1) or (n>numthings) then exit;
  getinput (n,editit)
end;

procedure maybemakeconfig;
var f:file of configsettype;
    s,w:integer;
begin
  s:=ofs(filler)-ofs(versioncode);
  w:=sizeof(configsettype);
  if s>w then begin
    writeln;
    writeln ('****** ERROR: CONFIGSETTYPE is too short!');
    writeln ('              Size of configuration is: ',s);
    writeln ('                   Bytes being written: ',w);
    writeln;
    halt
  end;
  assign (f,'Forum.CFG');
  reset (f);
  if ioresult=0 then begin
    close (f);
    exit
  end;
  fillchar (configset,sizeof(configset),0);
  formatconfig
end;

var command:sstr;
    i:integer;
begin
  textmode (BW80);
  initscrnunit;
  curwindowptr^.normalcolor:=normalcolor;
  curwindowptr^.boldcolor:=boldcolor;
  curwindowptr^.barcolor:=barcolor;
  curwindowptr^.inputcolor:=inputcolor;
  curwindowptr^.choicecolor:=choicecolor;
  curwindowptr^.datacolor:=datacolor;
  gotoxy (1,1);
  writeln ('One moment...');
  readdata;
  assignptrs;
  maybemakeconfig;
  readconfig;
  i:=ioresult;
  numpages:=whichpage(numthings);
  page:=0;
  gotopage (1);
  repeat
    setfilter (checksnowmode);
    gotoxy (1,24);
    write ('F1: Edit entry  F10: Save/exit  PgUp: Last page  PgDn: Next page  Esc: Abort');
    i:=useprompts(prompt);
    if bioslook in [#32..#126]
      then changenum (i,false)
      else case bioskey of
        #187:begin          gotoxy (1,1);
            write (i);
            changenum (i,true);
        end;
        #196:begin
               writeconfig;
               byebye
             end;
        #27:abortyn;
        #13:changenum (i,false);
        #201:gotopage (page-1);
        #209:gotopage (page+1)
      end
  until 0=1
end.



(* Types are:
     Int #-#           Integer in the range specified
     Lstr              80 char string
     Mstr              30 char string
     Sstr              15 char string
     Char              Single character
     Boo               Boolean (y/n)
     Path              Directory path
     Baud              Set of baud rates
     Time              Time of day
     Attrib            Attribute, Black, Blue, etc.
     Usertime          Special usertime per day type, doesn't print
*)