Jason Aller Floppy Collection/276.img/FORUM21S.ZIP/CNVT210.SUP

Text File | 1988-03-27 | 20.0 KB | 803 lines

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

{ $define checkmode}  {***** CLOSE THIS TO SEE WHAT CHANGED *****}

program convert;

uses crt,gentypes,configrt,gensubs,statret;

{$I c:\forum20e\gentypes} {***** SPECIFY GENTYPES FROM OLD VERSION HERE *****}

{$ifdef checkmode}

procedure check (s1,s2:integer; t:string; done:boolean);
var x:integer;
const rows:array [1..4] of integer=(3,3,3,3);
      cols:array [1..4] of integer=(1,21,41,61);
begin
  if s1<>s2
    then if done
      then x:=2
      else x:=1
    else if done
      then x:=4
      else x:=3;
  gotoxy (cols[x],rows[x]);
  write (t);
  inc(rows[x])
end;

begin
  clrscr;
  writeln ('Needs fixing        Fixed               Unchanged           Unchanged/converted');
  check (sizeof(udrec),sizeof(gentypes.udrec),'udrec',true);
  check (sizeof(userrec),sizeof(gentypes.userrec),'userrec',true);
  check (sizeof(boardrec),sizeof(gentypes.boardrec),'boardrec',true);
  check (sizeof(bulrec),sizeof(gentypes.bulrec),'bulrec',true);
  check (sizeof(filerec),sizeof(gentypes.filerec),'filerec',true);
  check (sizeof(mailrec),sizeof(gentypes.mailrec),'mailrec/feedback',true);
  check (sizeof(abrec),sizeof(gentypes.abrec),'abrec',false);
{ check (sizeof(catalogrec),sizeof(gentypes.catalogrec),'catalogrec',false); }
  check (sizeof(grouprec),sizeof(gentypes.grouprec),'grouprec',false);
  check (sizeof(topicrec),sizeof(gentypes.topicrec),'topicrec',false);
  check (sizeof(choicerec),sizeof(gentypes.choicerec),'choicerec',false);
  check (sizeof(lastrec),sizeof(gentypes.lastrec),'lastrec',true);
  check (sizeof(baserec),sizeof(gentypes.baserec),'baserec',true);
  check (sizeof(entryrec),sizeof(gentypes.entryrec),'entryrec',true);
  check (sizeof(arearec),sizeof(gentypes.arearec),'arearec',true);
  check (sizeof(doorrec),sizeof(gentypes.doorrec),'doorrec',false);
  check (sizeof(logrec),sizeof(gentypes.logrec),'logrec',true);
  check (sizeof(syslogdatrec),sizeof(gentypes.syslogdatrec),'syslogdatrec',false)

{$else}

var windowx1,windowy1,windowx2,windowy2,scrnwidth,midpoint:integer;
    when,shoulderase:boolean;

procedure killfile (newname:string);
var f2:file;
    x:integer;
begin
  assign (f2,newname);
  {$I-} erase (f2); {$I+}
  x:=ioresult
end;

procedure window (x1,y1,x2,y2:integer);
begin
  windowx1:=x1;
  windowy1:=y1;
  windowx2:=x2;
  windowy2:=y2;
  scrnwidth:=x2-x1+1;
  midpoint:=scrnwidth div 2;
  crt.window (x1,y1,x2,y2)
end;

procedure center (y:integer; l:string);
begin
  gotoxy (1,y);
  clreol;
  gotoxy (midpoint-length(l) div 2,y);
  write (l)
end;

procedure returntodos;
begin
  window (1,1,80,25);
  textcolor (6);
  textbackground (0);
  gotoxy (1,25);
  clreol;
  gotoxy (1,24);
  clreol;
  halt
end;

procedure topmessage (x:string; printalso:boolean);
var xx,yy:integer;
begin
  xx:=wherex;
  yy:=wherey;
  window (1,1,80,25);
  gotoxy (1,6);
  textcolor (15);
  textbackground (1);
  clreol;
  window (3,1,78,25);
  textcolor (14);
  textbackground (0);
  center (4,x);
  window (3,8,78,21);
  gotoxy (xx,yy);
  textcolor (6);
  textbackground (0);
  if printalso then writeln (^M^J,x,^M^J);
end;

procedure divider;
begin
  writeln;
  writeln ('────────────────────────────────────────────────────────────────────────────');
end;

procedure init;
var cnt:integer;
begin
  checksnow:=true;
  textmode (bw80);
  textcolor (15);
  textbackground (1);
  window (1,1,80,25);
  for cnt:=1 to 46 do begin
    gotoxy (1,cnt div 2);
    write (' ');
    gotoxy (80,cnt div 2);
    write (' ');
    gotoxy (cnt,1);
    write ('  ');
    gotoxy (79-cnt,1);
    write ('  ');
    gotoxy (cnt,23);
    write ('  ');
    gotoxy (79-cnt,23);
    write ('  ');
    if odd(cnt)
      then gotoxy (39+cnt div 2,12)
      else gotoxy (40-cnt div 2,12);
    delay (10)
  end;
  center (1,'Forum-PC Conversion Program');
  center (2,versionnum+' to '+gentypes.versionnum);
  window (3,4,78,21);
  gotoxy (1,1);
  textcolor (6);
  textbackground (0);
  topmessage ('',false);
  clrscr
end;


procedure ensureconfigexists;
var f:file;
begin
  topmessage ('Searching for CONFIG.BBS',false);
  assign (f,'config.bbs');
  {$I-} reset (f); {$I+}
  if ioresult<>0 then begin
    writeln ('Sorry!  I can''t seem to locate your CONFIG.BBS file.');
    writeln ('This means that either:');
    writeln ('  1. You aren''t running CONVERT from your Forum-PC directory');
    writeln ('  2. You haven''t been using an old version and you don''t need to convert');
    writeln;
    writeln ('If you have been running an old version, please change to your Forum-PC');
    writeln ('directory and run this program again.');
    writeln;
    writeln ('If you haven''t been using an old version, then you don''t need this program!');
    returntodos
  end;
  close (f)
end;

procedure readconfig;        { Shouldn't check version code }
var q:file of configrt.configsettype;
begin
  topmessage ('Reading CONFIG.BBS',false);
  assign (q,'Config.BBS');
  reset (q);
  read (q,configset);
  close (q)
end;

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

procedure ensurenotsecondtime;
begin
  if versioncode=gentypes.thisversioncode then begin
    topmessage ('WARNING!  You may have already converted',false);
    writeln ('It appears that you may have already converted.');
    writeln ('It is important that you do not try to convert twice!');
    writeln;
    write ('Are you sure you wish to convert [y/n]: ');
    if upcase(readkey)='Y'
      then writeln ('Yes')
      else returntodos
  end;
  divider
end;

procedure shouldierase;
var k:char;
begin
  topmessage ('Keep old disk files?',false);
  writeln ('In the conversion process, I ordinarily simply remove the old versions');
  writeln ('of Forum''s various data files.  However, if you wish, I will keep the old');
  writeln ('data files, with an extension of ".OLD".');
  writeln;
  write ('Should I KEEP the old data files [y/n]: ');
  repeat
    k:=upcase(readkey)
  until k in ['Y','N'];
  shoulderase:=k='N';
  if shoulderase
    then write ('No, erase')
    else write ('Yes, keep');
  writeln (' old disk files');
  divider
end;

function convertdati (da,ti:sstr):longint;
begin
  convertdati:=dateval(da)+timeval(ti)
end;

procedure convertfilexfer;

  procedure convertarearec (var oa:arearec; var a:gentypes.arearec);
  begin
    with a do begin
      name:=oa.name;
      xmodemdir:=oa.xmodemdir;
      sponsor:=oa.sponsor;
      level:=oa.level
    end
  end;

  procedure convertudrec (var o:udrec; var u:gentypes.udrec);
  begin
    u.sentby:=o.sentby;
    u.when:=convertdati(o.sentda,o.sentti);
    u.whenrated:=u.when;
    u.sentby:=o.sentby;
    u.filename:=o.filename;
    u.path:=o.path;
    u.points:=o.points;
    if (o.filesize<maxlongint) and (o.filesize>0)
      then u.filesize:=round(o.filesize)
      else u.filesize:=-1;
    u.descrip:=o.descrip;
    u.downloaded:=o.downloaded;
    u.newfile:=ord(o.newfile)<>0;
    u.specialfile:=ord(o.specialfile)<>0
  end;

var oa:arearec;
    ou:udrec;
    a:gentypes.arearec;
    u:gentypes.udrec;
    oaf:file of arearec;
    ouf:file of udrec;
    af:file of gentypes.arearec;
    uf:file of gentypes.udrec;
    k:char;
    anum:integer;
begin
  writeln ('NO! I REFUSE to do this.');
  halt;
  topmessage ('Converting file transfer section',true);
  assign (oaf,'areadir');
  killfile ('areadir.old');
  {$I-} rename (oaf,'areadir.old'); {$I+}
  if ioresult<>0 then begin
    writeln ('I can''t locate a file transfer section!');
    writeln ('Press any key to continue...');
    k:=readkey;
    divider;
    exit
  end;
  reset (oaf);
  assign (af,'areadir');
  rewrite (af);
  writeln ('Filesize = ',filesize(oaf));
  for anum:=1 to filesize(oaf) do begin
    seek (oaf,anum-1);
    read (oaf,oa);
    convertarearec (oa,a);
    write (af,a);
    writeln ('        Converting area ',anum,': ',a.name);
    assign (ouf,'area'+strr(anum));
    killfile ('area'+strr(anum)+'.old');
    {$I-} rename (ouf,'area'+strr(anum)+'.old'); {$I+}
    if ioresult<>0
      then writeln ('  ****  Unable to access file AREA',anum)
      else begin
        assign (uf,'area'+strr(anum));
        rewrite (uf);
        reset (ouf);
        while not eof(ouf) do begin
          read (ouf,ou);
          convertudrec (ou,u);
          write (uf,u)
        end;
        close (uf);
        close (ouf);
        if shoulderase then erase (ouf)
      end
  end;
  close (af);
  close (oaf);
  if shoulderase then erase(oaf);
  divider
end;

procedure convertuserfile;

  procedure convertuserrec (var ou:userrec; var u:gentypes.userrec);
  begin
    with u do begin
      handle:=ou.handle;
      password:=ou.password;
      phonenum:=ou.phonenum;
      laston:=convertdati(ou.londa,ou.lonti);
      numon:=ou.numon;
      timetoday:=ou.timetoday;
      nup:=ou.nup;
      ndn:=ou.ndn;
      nbu:=ou.nbu;
      uploads:=ou.uploads;
      downloads:=ou.downloads;
      totaltime:=ou.totaltime;
      voted:=gentypes.voteset(ou.voted);
      udlevel:=ou.udlevel;
      udpoints:=ou.udpoints;
      level:=ou.level;
      emailannounce:=ou.emailannounce;
      beepedpwd:=ou.beepedpwd;
      infoform:=ou.infoform;
      regularcolor:=ou.regularcolor;
      promptcolor:=ou.promptcolor;
      statcolor:=ou.statcolor;
      inputcolor:=ou.inputcolor;
      displaylen:=ou.displaylen;
      config:=ou.config;
      newscanconfig:=ou.newscanconfig;
      access1:=ou.access1;
      access2:=ou.access2;
      fillchar (lastread,sizeof(lastread),0)
    end
  end;

var uf:file of gentypes.userrec;
    ouf:file of userrec;
    ou:userrec;
    u:gentypes.userrec;
    k:char;
    cnt:integer;
begin
  topmessage ('Converting user list',true);
  assign (ouf,'users');
  killfile ('users.old');
  {$I-} rename (ouf,'users.old'); {$I+}
  if ioresult<>0 then begin
    writeln ('I can''t find the user list!');
    writeln ('Press any key to continue...');
    k:=readkey;
    divider;
    exit
  end;
  reset (ouf);
  assign (uf,'users');
  rewrite (uf);
  cnt:=0;
  while not eof(ouf) do begin
    read (ouf,ou);
    convertuserrec (ou,u);
    write (uf,u);
    cnt:=cnt+1;
    if (cnt mod 10)=0 then write (cnt,'... ')
  end;
  writeln ('Done!');
  close (uf);
  close (ouf);
  if shoulderase then erase (ouf);
  divider
end;

procedure convertconfig;
var f:file;
    k:char;
begin
  topmessage ('Converting configuration',true);
  assign (f,'config.bbs');
  killfile ('config.old');
  {$I-} rename (f,'config.old'); {$I+}
  if ioresult<>0 then begin
    writeln ('This can''t happen!  I can''t find the configuration file!');
    writeln ('Press any key to continue...');
    k:=readkey;
    divider;
    exit
  end;
  versioncode:=gentypes.thisversioncode;
  directvideo:=true;
  checksnowmode:=true;
  hashayes:=false;
  writeconfig;
  if shoulderase then erase(f);
  divider
end;

procedure convertbulletins;
var counter:word;

  procedure convertboardrec (var obd:boardrec; var bd:gentypes.boardrec);
  begin
    with bd do begin
      boardname:=obd.boardname;
      sponsor:=obd.sponsor;
      level:=obd.level;
      autodel:=obd.autodel;
      shortname:=obd.shortname
    end
  end;

  procedure convertbulrec (var ob:bulrec; var b:gentypes.bulrec);
  begin
    counter:=counter+1;
    with b do begin
      title:=ob.title;
      leftby:=ob.leftby;
      when:=convertdati(ob.leftda,ob.leftti);
      anon:=ob.anon;
      line:=ob.line;
      plevel:=ob.plevel;
      id:=counter
    end
  end;

  procedure convertfilerec (var oof:filerec; var f:gentypes.filerec);
  begin
    with f do begin
      descrip:=oof.descrip;
      fname:=oof.fname;
      sentby:=oof.sentby;
      when:=convertdati(oof.sentda,oof.sentti);
      downloaded:=oof.downloaded;
    end
  end;

var bf:file of gentypes.bulrec;
    obf:file of bulrec;
    ff:file of gentypes.filerec;
    off:file of filerec;
    bdf:file of gentypes.boardrec;
    obdf:file of boardrec;
    b:gentypes.bulrec;
    ob:bulrec;
    f:gentypes.filerec;
    oof:filerec;
    bd:gentypes.boardrec;
    obd:boardrec;
    k:char;
    cbprefix:lstr;
begin
  topmessage ('Converting bulletin section',true);
  assign (obdf,boarddir+'boarddir');
  killfile (boarddir+'boarddir.old');
  {$I-} rename (obdf,boarddir+'boarddir.old'); {$I+}
  if ioresult<>0 then begin
    writeln ('I can''t find the bulletin section! (',boarddir,'BOARDDIR)');
    writeln ('Press any key to continue...');
    k:=readkey;
    divider;
    exit
  end;
  reset (obdf);
  assign (bdf,boarddir+'boarddir');
  rewrite (bdf);
  while not eof(obdf) do begin
    read (obdf,obd);
    convertboardrec (obd,bd);
    write (bdf,bd);
    writeln ('        Converting ',bd.boardname,' [',bd.shortname,']');
    writeln ('                   bulletins');
    cbprefix:=boarddir+bd.shortname+'.';
    assign (obf,cbprefix+'bul');
    killfile (cbprefix+'obu');
    {$I-} rename (obf,cbprefix+'obu'); {$I+}
    if ioresult<>0
      then writeln ('  ****  Unable to access file ',cbprefix,'BUL')
      else begin
        reset (obf);
        assign (bf,cbprefix+'bul');
        rewrite (bf);
        counter:=0;
        while not eof(obf) do begin
          read (obf,ob);
          convertbulrec (ob,b);
          write (bf,b)
        end;
        close (bf);
        close (obf);
        if shoulderase then erase (obf)
      end;
    writeln ('                   text files');
    assign (off,cbprefix+'fil');
    killfile (cbprefix+'ofi');
    {$I-} rename (off,cbprefix+'ofi'); {$I+}
    if ioresult<>0
      then writeln ('  ****  Unable to access file ',cbprefix,'FIL')
      else begin
        reset (off);
        assign (ff,cbprefix+'fil');
        rewrite (ff);
        while not eof(off) do begin
          read (off,oof);
          convertfilerec (oof,f);
          write (ff,f)
        end;
        close (ff);
        close (off);
        if shoulderase then erase (off)
      end
  end;
  close (bdf);
  close (obdf);
  if shoulderase then erase (obdf);
  divider
end;

procedure convertmailgeneral (secname,fname:string);

  procedure convertmailrec (var om:mailrec; var m:gentypes.mailrec);
  begin
    with m do begin
      title:=om.title;
      sentby:=om.sentby;
      when:=convertdati(om.sentda,om.sentti);
      anon:=om.anon;
      read:=om.read;
      sentto:=om.sentto;
      line:=om.line;
      fileindex:=om.fileindex
    end
  end;

var omf:file of mailrec;
    mf:file of gentypes.mailrec;
    om:mailrec;
    m:gentypes.mailrec;
    k:char;
    cnt:integer;
begin
  topmessage ('Converting '+secname,true);
  assign (omf,fname);
  killfile (fname+'.old');
  {$I-} rename (omf,fname+'.old'); {$I+}
  if ioresult<>0 then begin
    writeln ('I can''t find the '+secname+' file!');
    writeln ('Press any key to continue...');
    k:=readkey;
    divider;
    exit
  end;
  reset (omf);
  assign (mf,fname);
  rewrite (mf);
  cnt:=0;
  while not eof(omf) do begin
    {$I-} read (omf,om); {$I+}
    if ioresult=0 then begin
      convertmailrec (om,m);
      write (mf,m);
      cnt:=cnt+1;
      if (cnt mod 10)=0 then write (cnt,'... ')
    end
  end;
  close (mf);
  close (omf);
  if shoulderase then erase (omf);
  divider
end;

procedure convertemail;
begin
  convertmailgeneral ('electronic mail','mail')
end;

procedure convertfeedback;
begin
  convertmailgeneral ('feedback','feedback')
end;

procedure convertdatabase;

  procedure convertbaserec (var ob:baserec; var b:gentypes.baserec);
  begin
    if sizeof(ob)=sizeof(b)
      then move(ob,b,sizeof(ob))
      else begin
        writeln ('ARGH, gentypes.baserec has changed size!');
        halt
      end
  end;

  procedure convertentryrec (var oe:entryrec; var e:gentypes.entryrec);
  begin
    e.data:=oe.data;
    e.when:=convertdati(oe.eda,oe.eti);
    e.addedby:=oe.addedby
  end;

var ob:baserec;
    oe:entryrec;
    b:gentypes.baserec;
    e:gentypes.entryrec;
    obf:file of baserec;
    oef:file of entryrec;
    bf:file of gentypes.baserec;
    ef:file of gentypes.entryrec;
    k:char;
    bnum:integer;
begin
  topmessage ('Converting database section',true);
  assign (obf,'datadir');
  killfile ('datadir.old');
  {$I-} rename (obf,'datadir.old'); {$I+}
  if ioresult<>0 then begin
    writeln ('I can''t locate the database section!');
    writeln ('Press any key to continue...');
    k:=readkey;
    divider;
    exit
  end;
  reset (obf);
  assign (bf,'datadir');
  rewrite (bf);
  for bnum:=1 to filesize(obf) do begin
    seek (obf,bnum-1);
    read (obf,ob);
    convertbaserec (ob,b);
    write (bf,b);
    writeln ('        Converting database ',bnum,': ',b.basename);
    assign (oef,'database.'+strr(bnum));
    killfile ('data'+strr(bnum)+'.old');
    {$I-} rename (oef,'data'+strr(bnum)+'.old'); {$I+}
    if ioresult<>0
      then writeln ('  ****  Unable to access file DATABASE.',bnum)
      else begin
        assign (ef,'database.'+strr(bnum));
        rewrite (ef);
        reset (oef);
        while not eof(oef) do begin
          read (oef,oe);
          convertentryrec (oe,e);
          write (ef,e)
        end;
        close (ef);
        close (oef);
        if shoulderase then erase (oef)
      end
  end;
  close (bf);
  close (obf);
  if shoulderase then erase(obf);
  divider
end;

procedure convertlastcallers;
var cnum:integer;

  procedure convertlastrec (var ol:lastrec; var l:gentypes.lastrec);
  begin
    l.name:=ol.name;
    l.when:=convertdati(ol.da,ol.ti);
    l.callnum:=round(numcallers)-maxlastcallers+cnum
  end;

var ol:lastrec;
    l:gentypes.lastrec;
    olf:file of lastrec;
    lf:file of gentypes.lastrec;
    k:char;
begin
  topmessage ('Converting list of recent callers',true);
  assign (olf,'callers');
  killfile ('callers.old');
  {$I-} rename (olf,'callers.old'); {$I+}
  if ioresult<>0 then begin
    writeln ('I can''t find the recent caller file!');
    writeln ('Press any key to continue...');
    k:=readkey;
    divider;
    exit
  end;
  reset (olf);
  assign (lf,'callers');
  rewrite (lf);
  cnum:=0;
  while not eof(olf) do begin
    cnum:=cnum+1;
    read (olf,ol);
    convertlastrec (ol,l);
    write (lf,l)
  end;
  close (lf);
  close (olf);
  if shoulderase then erase (olf);
  divider
end;

procedure convertsystemlog;

  procedure convertlogrec (var ol:logrec; var l:gentypes.logrec);
  begin
    l.menu:=ol.menu;
    l.subcommand:=ol.subcommand;
    l.param:=ol.param;
    l.when:=convertdati(ol.date,ol.time)
  end;

var ol:logrec;
    l:gentypes.logrec;
    olf:file of logrec;
    lf:file of gentypes.logrec;
    k:char;
    lnum:integer;
begin
  topmessage ('Converting system log',true);
  assign (olf,'syslog');
  killfile ('syslog.old');
  {$I-} rename (olf,'syslog.old'); {$I+}
  if ioresult<>0 then begin
    writeln ('I can''t find the system log!');
    writeln ('Press any key to continue...');
    k:=readkey;
    divider;
    exit
  end;
  reset (olf);
  assign (lf,'syslog');
  rewrite (lf);
  lnum:=0;
  while not eof(olf) do begin
    read (olf,ol);
    convertlogrec (ol,l);
    write (lf,l);
    lnum:=lnum+1;
    if (lnum mod 10)=0 then write (lnum,'... ')
  end;
  writeln ('Done!');
  close (lf);
  close (olf);
  if shoulderase then erase (olf);
  divider
end;

procedure alldone;
begin
  topmessage ('Conversion is complete!',true);
  writeln ('You should now be able to run ',gentypes.versionnum,'.');
  returntodos
end;

begin
  init;
  ensureconfigexists;
  readconfig;
  readstatus;
  ensurenotsecondtime;
  shouldierase;
  convertfeedback;
  convertconfig;
  convertbulletins;
  convertdatabase;
  convertemail;
  convertfilexfer;
  convertlastcallers;
  convertsystemlog;
  convertuserfile;
  alldone

{$endif}

end.