{$A+,B+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
{$M 32150,0,0}          { Declared here suffices for all Units as well! }

program BatchBackup;

uses
  crt,dos,
  myio;

{$I func.pas}

type
  lbrec=record
          drv:char;
          lb:datetime;
          nacc:integer;
        end;

const
  {rcg11242000 uh...DOSism. uh...}
  {lastspec='c:\lastbak.txt';}
  lastspec='./lastbak.txt';
  cline='tape SBK @D:\/S-\TRAP*.MSG/S-\BBS.OVR/S-\BBS.EXE/S/A/C/C+/-O/R@T/LBAK@D@N';
  lodrv:char='C';
  hidrv:char='E';
  go:boolean=FALSE;
  abort:boolean=FALSE;
  firstq:boolean=TRUE;

var
  lbdrv:array['C'..'G'] of lbrec;
  tagged:array['C'..'G'] of boolean;
  wind,winds:windowrec;
  y,oy:char;
  sx,sy:integer;
  lbf:file of lbrec;

{rcg11172000 had to change this to get it compiling under Free Pascal...}
{function substall(src,old,new:string):string;}
function substall(src,old,_new:string):string;
var p:integer;
begin
  p:=1;
  while p>0 do begin
    p:=pos(old,src);
    if p>0 then begin
      insert(_new,src,p+length(old));
      delete(src,p,length(old));
    end;
  end;
  substall:=src;
end;

function sdat(dt:datetime):string;

  function tch(i:integer):string;
  var s:string;
  begin
    str(i,s);
    if i<10 then s:='0'+s;
    if i<0 then s:='00';
    tch:=s;
  end;

begin
  with dt do
    sdat:=tch(month)+'/'+tch(day)+'/'+tch(year-1900)+' '+tch(hour)+':'+tch(min)+':'+tch(sec);
end;

procedure unsdat(s:string; var dt:datetime);
var x:integer;
begin
  with dt do begin
    val(copy(s,7,2),year,x); inc(year,1900);
    val(copy(s,1,2),month,x);
    val(copy(s,4,2),day,x);
    val(copy(s,10,2),hour,x);
    val(copy(s,13,2),min,x);
    val(copy(s,16,2),sec,x);
  end;
end;

procedure datnow(var dt:datetime);
var r:registers;
begin
  with dt, r do begin
    ax:=$2a00; msdos(dos.registers(r));
    year:=cx;
    month:=dx shr 8;
    day:=dx mod 256;
    ax:=$2c00; msdos(dos.registers(r)); {intr($21,dos.registers(r));}
    hour:=cx shr 8;
    min:=cx mod 256;
    sec:=dx shr 8;
  end;
end;

function dtchk(s:string):boolean;
begin
  dtchk:=FALSE;
  if (s[1] in ['0'..'9']) and (s[2] in ['0'..'9']) and
     (s[4] in ['0'..'9']) and (s[5] in ['0'..'9']) and
     (s[7] in ['0'..'9']) and (s[8] in ['0'..'9']) then dtchk:=TRUE;
end;

function gooddate(s:string):boolean;
begin
  gooddate:=FALSE;
  if (s[3] in ['-','/']) and (s[6] in ['-','/']) and (length(s)=8) then
    if dtchk(s) then gooddate:=TRUE;
end;

procedure inlast;
var c:char;
    dt:datetime;
begin
  datnow(dt);
  assign(lbf,lastspec);
  {$I-} reset(lbf); {$I+}
  if ioresult=0 then
    for c:=lodrv to hidrv do
      read(lbf,lbdrv[c])
  else begin
    rewrite(lbf);
    for c:=lodrv to hidrv do begin
      with lbdrv[c] do begin
        drv:=c;
        lb:=dt;
        nacc:=0;
      end;
      write(lbf,lbdrv[c]);
    end;
  end;
  close(lbf);
end;

procedure tagall;
var c:char;
begin
  for c:=lodrv to hidrv do tagged[c]:=TRUE;
end;

procedure setscreen;
begin
  sx:=wherex; sy:=wherey;
  savescreen(winds,1,1,80,25);
  setwindow(wind,10,3,53,ord(hidrv)-ord(lodrv)+10,9,1,1);
  window(12,4,52,ord(hidrv)-ord(lodrv)+9);
  clrscr;
end;

procedure init;
begin
  inlast;
  tagall;
  setscreen;
end;

procedure closeup;
begin
  removewindow(winds);
  gotoxy(sx,sy);
end;

procedure sc(s:string);
const bcol:boolean=FALSE;
      fcol:boolean=FALSE;
var i:integer;
begin
  for i:=1 to length(s) do
    if not fcol then
      if not bcol then
        case s[i] of
          #3:fcol:=TRUE;
          #4:bcol:=TRUE;
        else
             write(s[i]);
        end
      else begin
        bcol:=FALSE;
        textbackground(ord(s[i]));
      end
    else begin
      fcol:=FALSE;
      textcolor(ord(s[i]));
    end;
end;

procedure scln(s:string);
begin
  sc(s);
  writeln;
end;

procedure showstuff;
var c:char;
    s:string;
begin
  gotoxy(1,3);
  for c:=lodrv to hidrv do begin
    if tagged[c] then sc(#3#15+'+') else sc(#3#9+'-');
    sc(#3#11+' Drive '+c+':'+#3#9+' Since '+#3#14+sdat(lbdrv[c].lb));
    str(lbdrv[c].nacc,s);
    scln(#3#9+' (#'+s+')');
  end;
  writeln;
  scln(#3#11+'  OK');
  sc(#3#11+'  Abort');
end;

procedure lin(i:integer);

  procedure dd(y:char);
  begin
    if y<=hidrv then sc('Drive '+y+':') else
      if y=chr(ord(hidrv)+2) then sc('OK') else
        if y=chr(ord(hidrv)+3) then sc('Abort');
  end;

begin
  case i of
    0:begin
        gotoxy(3,ord(oy)-64);
        sc(#4#1+#3#11);
        dd(oy);
      end;
    1:begin
        gotoxy(3,ord(y)-64);
        sc(#4#3+#3#0);
        dd(y);
      end;
  end;
end;

procedure glin;
begin
  lin(0); lin(1);
  oy:=y;
end;

procedure tell(s:string);
var i:integer;
begin
  CursorOff;
  i:=40-(length(s) div 2)-3;
  setwindow(wind,i,10,i+length(s)+5,14,9,1,1);
  gotoxy(3,2); textcolor(15); writeln(s);
end;


{rcg11172000 added by me.}
procedure CursorOn;
begin
  writeln('STUB: bb.pas; CursorOn()...');
end;
{rcg11172000 adds end.}


procedure makesound;
var i,j,k:integer;
begin
  i:=100;
  repeat
    sound(i);
    delay(i div 100);
    j:=100;
    repeat
      sound(j);
      delay(j div 100);
      k:=100;
      repeat
        sound(k);
        delay(k div 30);
        inc(k,j);
      until (k>=2000) or (keypressed);
      inc(j,i);
    until (j>=500) or (keypressed);
    inc(i,k);
  until (i>=1000) or (keypressed);
  nosound;
end;

var
  c:char;
  s,s1,s2:string;
  changed:boolean;
  dt:datetime;
  bf:text;
  i:integer;

begin
  init;

  infield_out_fgrd:=14; infield_out_bkgd:=1;
  infield_inp_fgrd:=0; infield_inp_bkgd:=7;

  scln(#3#15+'Backup new files');
  writeln;
  showstuff;
  y:=chr(ord(hidrv)+2); oy:=y; glin;

  repeat
    case readkey of
      #0 :case ord(readkey) of
            ARROW_UP   :if y=chr(ord(hidrv)+2) then y:=pred(pred(y)) else y:=pred(y);
            ARROW_DOWN :if y=hidrv then y:=succ(succ(y)) else y:=succ(y);
            ARROW_LEFT,
            ARROW_RIGHT:begin
                          changed:=FALSE;
                          s:=sdat(lbdrv[y].lb);
                          s1:=copy(s,1,8); s2:=copy(s,10,8);
                          infield1(18,ord(y)-64,s1,8);
                          if not gooddate(s1) then s1:=copy(s,1,8);
                          if s1<>copy(s,1,8) then changed:=TRUE;
                          gotoxy(18,ord(y)-64); write(s1);
                          if changed then unsdat(s1+' '+s2,lbdrv[y].lb);
                          changed:=FALSE;
                        end;
          end;
      #13:if y>hidrv then go:=TRUE
          else begin
            tagged[y]:=not tagged[y];
            lin(0); showstuff;
            glin;
          end;
      #27:begin
            y:=chr(ord(hidrv)+3);
            go:=TRUE;
          end;
    end;
    if y>chr(ord(hidrv)+3) then y:=lodrv;
    if y<lodrv then y:=chr(ord(hidrv)+3);
    if y<>oy then glin;
  until (go);
  lin(0);

  abort:=(y=chr(ord(hidrv)+3));

  removewindow(wind);

  if not abort then begin
    for c:=lodrv to hidrv do
      if tagged[c] then begin
        inc(lbdrv[c].nacc);

        assign(bf,'tempbat.bat');
        rewrite(bf);
{        writeln(bf,'@echo off');}
        writeln(bf,'cls');
        s1:=sdat(lbdrv[c].lb); s1:=copy(s1,1,8); str(lbdrv[c].nacc,s2);
        s:=substall(cline,'@D',c);
        s:=substall(s,'@N',s2);
        s:=substall(s,'@T',s1);
        writeln(bf,s);
        close(bf);

        datnow(dt);
        lbdrv[c].lb:=dt;

        removewindow(winds);
        tell('Insert tape for drive '+c+': ...');
        if not firstq then begin
          repeat
            makesound;
            i:=0;
            repeat
              inc(i);
            until (i=0) or (keypressed);
          until keypressed;
        end;

        firstq:=FALSE;
        y:=readkey;
        removewindow(wind);
        CursorOn;

        rewrite(lbf);
        for c:=lodrv to hidrv do
          with lbdrv[c] do
            write(lbf,lbdrv[c]);
        close(lbf);

        exec(getenv('COMSPEC'),'/c tempbat.bat');
        erase(bf);
        abort:=TRUE;
        makesound;
      end;
  end;

  closeup;
end.