program FastCopy;
uses crt, XMS;
const
  BufSize:word=32768;

var
  h,nr,nw:word;
  inp,out:file;
  size,fpos,outsize:longint;
  XMSsize,XMSposr,XMSposw:longint;
  s,sf:string;
  Block:pointer;
  ypos:byte;
  isXMS,done,esc:boolean;
  pars:TMoveParams;

procedure WriteStatus(y:byte; value,total:longint);
var i,n:word;
begin
  value:=value div 1024;
  total:=total div 1024;
  n:=round(100*(value/total));
  gotoxy(7,y);
  write(value,' bytes (',n,'%) ');
  if keypressed then esc:=(readkey=#27);
end;
procedure Quit(s:string);
begin
  gotoxy(1,ypos+2); writeln(s);
  close(out); close(inp);
  freemem(Block,BufSize);
  if isXMS then XMSFree(h);
  halt;
end;
procedure Crush;
begin
  writeln('Usage:   fcopy [path\]file path\[file]');
  writeln('Example: fcopy heroes2.agg d:');
  writeln;
  halt;
end;
begin
  writeln;
  writeln('Files copying utility, using XMS.');
  if not XMSInstalled then begin
    writeln('...but XMS driver (himem.sys) is not installed.');
    isXMS:=false; XMSsize:=0;
  end
  else begin
    XMSInit; isXMS:=true; XMSsize:=XMSGetFreeMem;
    writeln('Free XMS: ',XMSsize,' Kb (All that will be allocated)');
    XMSsize:=XMSsize*1024;
  end;

  if paramcount<>2 then Crush;
  s:=paramstr(1); if s[2]=':' then delete(s,1,2);
  while pos('\',s)>0 do delete(s,1,pos('\',s));
  if s='' then Crush; sf:=paramstr(2);
  if (sf[length(sf)]='\') or (sf[length(sf)]=':') then sf:=sf+s;
  assign(inp,paramstr(1)); assign(out,sf);
  {$I-} reset(inp,1); {$I+}
  if IOResult<>0 then begin
    writeln('Cannot open file ',s);
    halt;
  end;
  size:=filesize(inp);
  {$I-} reset(out,1); {$I+}
  if IOResult=0 then begin
    writeln(sf,' exists. ENTER - overwrite...');
    if readkey<>#13 then halt;
  end;
  fpos:=0;
  rewrite(out,1);
  if MaxAvail<BufSize then
    BufSize:=1024*(MaxAvail div 1024);
  if BufSize=0 then begin
    writeln('There is too low free base memory.');
    halt;
  end;
  getmem(Block,BufSize);
  XMSsize:=BufSize*(XMSsize div BufSize);
  if (Size<BufSize) or (XMSsize<=BufSize) then begin
    writeln('XMS is useless here.');
    isXMS:=false;
  end
  else begin
    XMSsize:=XMSsize div 1024;
    if XMSsize>64512 then XMSsize:=64512;
    if not XMSAllocate(h,XMSsize) then begin
      writeln('XMS allocating error');
      isXMS:=false;
    end;
  end;
  outsize:=0;
  writeln;
  writeln('Read :');
  writeln('Write:');
  ypos:=WhereY-2; esc:=false;
  repeat
    with pars do begin
      SourceHandle:=0;
      SourceOffset:=longint(Block);
      DestHandle:=h;
    end;
    XMSposr:=0; done:=false;
    if not isXMS then done:=true;
    repeat
      blockread(inp,Block^,BufSize,nr);
      pars.DestOffset:=XMSposr;
      pars.Length:=nr;
      if isXMS then XMSMove(@pars);
      inc(XMSposr,nr);
      if isXMS then
        if XMSposr=XMSsize*1024 then done:=true;
      inc(fpos,nr);
      if nr<BufSize then done:=true;
      WriteStatus(ypos,fpos,size);
    until done or esc;
    with pars do begin
      Length:=BufSize;
      SourceHandle:=h;
      DestHandle:=0;
      DestOffset:=longint(Block);
    end; XMSposw:=0;
    repeat
      if XMSposw+nr=XMSposr then pars.Length:=nr;
      pars.SourceOffset:=XMSposw;
      if isXMS then XMSMove(@pars);
      inc(XMSposw,pars.Length);
      blockwrite(out,Block^,pars.Length,nw);
      inc(outsize,nw);
      WriteStatus(ypos+1,outsize,size);
      if nw<pars.Length then quit('File writing error.');
    until (XMSposw=XMSposr) or esc;
    if esc then quit('User break.');
  until nr<BufSize;
  quit('Done.');
end.