Tree - bw/copier - Cool Bug Repo

bw / copier

Files

Blob Blame Raw
unit Main;

interface

uses
  SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, LCLType;

type

  { TfrmMain }

  TfrmMain = class(TForm)
    eSrcFile: TEdit;
    eDestFile: TEdit;
    bCopy: TButton;
    iProgress: TImage;
	Label1: TLabel;
	Label2: TLabel;
    bSrc: TButton;
    bDest: TButton;
    Label5: TLabel;
	odSrc: TOpenDialog;
    sdDest: TSaveDialog;
    bCancel: TButton;
    mReport: TMemo;
	procedure bCopyClick(Sender: TObject);
    procedure bSrcClick(Sender: TObject);
	procedure bDestClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure bCancelClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormResize(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure iProgressPaint(Sender: TObject);
  private
	{ Private declarations }
  public
	{ Public declarations }
  end;

  PZone = ^TZone;
  TZone = record
	sStart	: integer;
	sEnd	: integer;
	BlkSize	: integer;
	Error	: boolean;
	Prev	: PZone;
	Next	: PZone;
	Current	: boolean;
	ErrZone	: boolean;
  end;

const
	MaxBlkSize = 4096;
	MinBlkSize = 4096;

var
  frmMain: TfrmMain;

  Cancel: boolean;
  CurZone: PZone;
  ErrZones: PZone;
  fSize: integer;
  InfoFile: string;
  IniFile: string;
  OldTime: double;
  LockCopy: boolean;
  CancelErrors: boolean;

implementation

{$R *.lfm}

function IntToStrEx(Value: integer): string;
var
	str	: string;
	n	: integer;
begin
	str:=IntToStr(Value);
	Result:=''; n:=0;
	while length(str)>0 do begin
		Result := str[length(str)]+Result;
		str := copy(str, 1, length(str)-1);
		Inc(n);
		if (length(str)>0) and (n=3) then begin
			n:=0;
			Result := Chr(39)+Result;
		end;
	end;
end;

function UpInt(Value: Extended): integer;
begin
	Result := trunc(Value);
	if Result<Value then Inc(Result);
end;

procedure SaveIni;
var
	f	: textfile;
begin
	AssignFile(f, IniFile); ReWrite(f);
	WriteLn(f, frmMain.eSrcFile.Text);
	WriteLn(f, frmMain.eDestFile.Text);
	Write(f, frmMain.mReport.Lines.Text);
	CloseFile(f);
end;

procedure LoadIni;
var
	f	: textfile;
	str	: string;
begin
	if FileExists(IniFile) then begin
		AssignFile(f, IniFile); Reset(f);
		ReadLn(f, str);
		frmMain.eSrcFile.Text := str;
		ReadLn(f, str);
		frmMain.eDestFile.Text := str;
		while not eof(f) do begin
			ReadLn(f, str);
			frmMain.mReport.Lines.Add(str);
		end;
		CloseFile(f);
	end;
end;

procedure AddZoneBefore(Zone, ZoneListItem: PZone);
begin
	Zone.Next := ZoneListItem;
	if Zone.Next<>nil then begin
		Zone.Prev := Zone.Next.Prev;
		Zone.Next.Prev := Zone;
		if Zone.Prev<>nil then Zone.Prev.Next:=Zone;
	end else Zone.Prev := nil;
end;

procedure AddZoneAfter(Zone, ZoneListItem: PZone);
begin
	Zone.Prev := ZoneListItem;
	if Zone.Prev<>nil then begin
		Zone.Next := Zone.Prev.Next;
		Zone.Prev.Next := Zone;
		if Zone.Next<>nil then Zone.Next.Prev:=Zone;
	end else Zone.Next := nil;
end;

procedure RemoveZone(Zone: PZone);
begin
	if Zone.Prev<>nil then Zone.Prev.Next:=Zone.Next;
	if Zone.Next<>nil then Zone.Next.Prev:=Zone.Prev;
end;

function FindFirstZone(Zone: PZone): PZone;
begin
	Result := Zone;
	if Result<>nil then while Result.Prev<>nil do Result:=Result.Prev;
end;

procedure DisposeZoneList(var Zone: PZone);
var
	z: PZone;
begin
	Zone := FindFirstZone(Zone);
	while Zone<>nil do begin
		z := Zone.Next;
		Dispose(Zone);
		Zone := z;
	end;
end;

function FindMaxZone(Zone: PZone): PZone;
begin
	Result := FindFirstZone(Zone);
	Zone := Result;
	while Zone<>nil do begin
		if ((not Zone.Error) and Result.Error)
			or ((Zone.Error=Result.Error) and ((Zone.sEnd-Zone.sStart)>(Result.sEnd-Result.sStart))) then
				Result := Zone;
		Zone := Zone.Next;
	end;
end;


procedure MoveToError(Zone: PZone);
var
	z	: PZone;
begin
	RemoveZone(Zone);

	z:=ErrZones;
	while (z<>nil) and (z.next<>nil) and (z.sEnd<Zone.sStart) do z:=z.Next;
	if (z<>nil) and (z.sEnd<=Zone.sStart) then AddZoneAfter(Zone, z) else AddZoneBefore(Zone, z);

	if (Zone.Prev<>nil) and (Zone.Prev.sEnd=Zone.sStart) then begin
		Zone.sStart:=Zone.Prev.sStart;
		z := Zone.Prev;
		RemoveZone(z);
		Dispose(z);
	end;
	if (Zone.Next<>nil) and (Zone.Next.sStart=Zone.sEnd) then begin
		Zone.sEnd:=Zone.Next.sEnd;
		z := Zone.Next;
		RemoveZone(z);
		Dispose(z);
	end;

	ErrZones := FindFirstZone(Zone);
end;

procedure GenerateReport;
var
	z			: PZone;
	str			: string;
	Text, ns	: string;
	ncp, dmg	: integer;
begin
	if fSize=0 then exit;
	z := FindFirstZone(CurZone);
	ncp := 0;
	ns := Chr(13);
	Text := 'Remained Blocks:'+ns;
	while z<>nil do begin
		str := IntToHex(z.sStart, 8)+':'+IntToHex(z.sEnd, 8)+' - ';
		if z.Error then	str:=str+'Read Error' else str:=str+'Copying';
		Text := Text+str+ns;
		ncp := ncp+z.sEnd-z.sStart;
		z:=z.Next;
	end;

	z := ErrZones;
	dmg := 0;
	Text := Text+'Damaged Blocks:'+ns;
	while z<>nil do begin
		str := IntToHex(z.sStart, 8)+':'+IntToHex(z.sEnd, 8);
		Text := Text+str+ns;
		dmg := dmg+z.sEnd-z.sStart;
		z:=z.Next;
	end;

	str := 'Damaged: '+IntToStrEx(dmg)+' ('+FloatToStr(round((dmg)/fSize*10000)*0.01)+'%)';
	Text := str+ns+Text;
	str := 'Remained: '+IntToStrEx(ncp)+' ('+FloatToStr(round((ncp)/fSize*10000)*0.01)+'%)';
	Text := str+ns+Text;
	str := 'Copied: '+IntToStrEx(fSize-ncp-dmg)+' ('+FloatToStr(round((fSize-ncp-dmg)/fSize*10000)*0.01)+'%)';
	Text := str+ns+Text;
	str := 'File Size: '+IntToStrEx(fSize);
	Text := str+ns+Text;

	frmMain.mReport.Lines.Text := Text;
end;

procedure SaveCopyInfo;
var
	f	: file of TZone;
	z	: PZone;
begin
	if InfoFile='' then exit;
	if (CurZone<>nil) or (ErrZones<>nil) then begin
		AssignFile(f, InfoFile);
		ReWrite(f);
		z := FindFirstZone(CurZone);
		while z<>nil do begin
			z.Current := (z=CurZone);
			z.ErrZone := (z=ErrZones);
			write(f, z^);
			z:=z.Next;
		end;
		z := ErrZones;
		while z<>nil do begin
			z.Current := (z=CurZone);
			z.ErrZone := (z=ErrZones);
			write(f, z^);
			z:=z.Next;
		end;
		CloseFile(f);
	end else DeleteFile(InfoFile);
end;

procedure LoadCopyInfo;
var
	f		: file of TZone;
	z, z2	: PZone;
	asked	: boolean;
begin
	DisposeZoneList(CurZone);
	DisposeZoneList(ErrZones);
	asked:=false;
	if FileExists(InfoFile) then begin
		AssignFile(f, InfoFile);
		Reset(f);
		z2 := nil;
		while not eof(f) do begin
			New(z);
			read(f, z^);
			if (not asked) and (z.Error or z.ErrZone or (z.BlkSize<>MaxBlkSize)) then begin
				CancelErrors := mrYes=MessageDlg('Reread error blocks?', mtConfirmation, [mbYes, mbNo], 0);
				asked := true;
			end;
			if CancelErrors then begin
				z.Error := False;
				z.BlkSize := MaxBlkSize;
				z.ErrZone := False;
			end;
			if z.Current then CurZone:=z;
			if z.ErrZone then begin
				ErrZones:=z;
				z2:=nil;
			end;
			AddZoneAfter(z, z2);
			z2:=z;
		end;
		if CancelErrors then CurZone:=FindMaxZone(z2);
		CloseFile(f);
	end else begin
		New(CurZone);
		CurZone.sStart := 0;
		CurZone.sEnd := fSize;
		CurZone.BlkSize := MaxBlkSize;
		CurZone.Error := False;
		CurZone.Prev := nil;
		CurZone.Next := nil;
	end;
end;

procedure DrawZones;
var
	z		: PZone;
	s		: integer;
	r, r2	: TRect;
	str		: string;
	bmp		: TBitmap;
begin
	with frmMain.iProgress do begin
		r.Top:=1; r.Left:=1; r.Right:=Width-1; r.Bottom:=Height-1;
		Canvas.Brush.Color := clBlue;
		if fSize=0 then Canvas.Brush.Color := clWhite;
		Canvas.FillRect(r);
		Canvas.Brush.Color := clWhite;
		z := FindFirstZone(CurZone);
		s := 0;
		while z<>nil do begin
			r.Left := 1+trunc(z.sStart/fSize*(Width-2));
			r.Right := 1+trunc(z.sEnd/fSize*(Width-2));
			s := s+z.sEnd-z.sStart;
			Canvas.FillRect(r);
			z:=z.Next;
		end;
		Canvas.Brush.Color := clRed;
		z := ErrZones;
		while z<>nil do begin
			r.Left := 1+trunc(z.sStart/fSize*(Width-2));
			r.Right := r.Left+UpInt((z.sEnd-z.sStart)/fSize*(Width-2));
			Canvas.FillRect(r);
			z:=z.Next;
		end;
		Canvas.Brush.Color := clRed;
		z := FindFirstZone(CurZone);
		while z<>nil do begin
			if z.Error then begin
				r.Left := 1+trunc(z.sStart/fSize*(Width-2));
				r.Right := r.Left+1;
				Canvas.FillRect(r);
			end;
			z:=z.Next;
		end;
		if fSize<>0 then begin
			bmp := TBitmap.Create;
				str:=FloatToStr(round((1-s/fSize)*1000)*0.1)+'%';
				bmp.Width := bmp.Canvas.TextWidth(str);
				bmp.Height := bmp.Canvas.TextHeight(str);
				bmp.Canvas.Brush.Color := clBlack;
				bmp.Canvas.Font.Color := clWhite;
				bmp.Canvas.TextOut(0, 0, str);
				r.Left:=trunc((Width-bmp.Width)/2);
				r.Top:=trunc((Height-bmp.Height)/2);
				r.Right:=r.Left+bmp.Width;
				r.Bottom:=r.Top+bmp.Height;
				r2.Left:=0; r2.Top:=0; r2.Right:=bmp.Width; r2.Bottom:=bmp.Height;
				Canvas.CopyMode := cmSrcInvert;
				Canvas.CopyRect(r, bmp.Canvas, r2);
			bmp.Free;
		end;
		Canvas.Brush.Style := bsClear;
		Canvas.Pen.Color := clBlack;
		r.Top:=0; r.Left:=0; r.Right:=Width; r.Bottom:=Height;
		Canvas.Rectangle(r);
		Canvas.Brush.Style := bsSolid;
	end;
	SaveCopyInfo;
	GenerateReport;
	LockCopy:=True;
	Application.ProcessMessages;
	LockCopy:=False;
	OldTime:=Time*24*3600;
end;

procedure CopyFile(Src, Dest: string);
var
	SrcFile		: file;
	DestFile	: file;
	e			: integer;
	Res, IORes	: integer;
	z			: PZone;
	Buffer		: array[0..MaxBlkSize] of byte;
	DlgRes		: Word;
	rewr		: boolean;
begin
	InfoFile := Dest+'.copyinfo';
	if not FileExists(Src) then begin
		ShowMessage('Source file not found');
		exit;
	end;
	rewr:=true;
	if FileExists(Dest) then begin
		if FileExists(InfoFile) then begin
			DlgRes := MessageDlg('Do you want to continue last copying of this file?', mtConfirmation, mbYesNoCancel, 0);
			if DlgRes=mrNo then	DeleteFile(InfoFile) else
			if DlgRes=mrYes then rewr:=false else exit;
		end else begin
			DlgRes := MessageDlg('Destination file already exists. Do you want to overwrite it?', mtConfirmation, mbOkCancel, 0);
			if DlgRes<>mrOk then exit;
		end;
	end;
	AssignFile(SrcFile, Src);
	AssignFile(DestFile, Dest);
	FileMode := fmOpenRead;
	Reset(SrcFile, 1);
	fSize:=FileSize(SrcFile);
	FileMode := fmOpenReadWrite;
	if rewr then ReWrite(DestFile, 1) else Reset(DestFile, 1);
	LoadCopyInfo;

	{$IOCHECKS OFF}
	while CurZone<>nil do begin
		if Cancel then break;
		if CurZone.Error then CurZone:=FindMaxZone(CurZone);
		if CurZone.Error then begin
			e := (trunc((CurZone.sStart+CurZone.sEnd)/2) div MinBlkSize)*MinBlkSize;
			if e<=CurZone.sStart then e:=e+MinBlkSize;
			if e>=CurZone.sEnd then begin
				if CurZone.Prev<>nil then z:=CurZone.Prev else z:=CurZone.Next;
				MoveToError(CurZone);
				CurZone:=FindMaxZone(z);
			end else begin
				New(z);
				z.BlkSize := MaxBlkSize;
				z.sStart := e;
				z.sEnd := CurZone.sEnd;
				z.Error := False;
				CurZone.sEnd := e;
				AddZoneAfter(z, CurZone);
				if CurZone.sEnd-CurZone.sStart<=MinBlkSize then	MoveToError(CurZone);
				CurZone := FindMaxZone(z);
			end;
			DrawZones;
		end else begin
			if CurZone.sEnd-CurZone.sStart>0 then begin
				Seek(SrcFile, CurZone.sStart);
				if CurZone.sEnd-CurZone.sStart<CurZone.BlkSize then CurZone.BlkSize:=CurZone.sEnd-CurZone.sStart;
				BlockRead(SrcFile, Buffer, CurZone.BlkSize, Res);
				IORes := IOResult;
				if IORes<>0 then Res:=0;
				if Res=0 then begin
					if CurZone.BlkSize<=MinBlkSize then CurZone.Error:=True else CurZone.BlkSize:=MinBlkSize;
				end else begin
					Seek(DestFile, CurZone.sStart);
					BlockWrite(DestFile, Buffer, Res);
				end;
				CurZone.sStart:=CurZone.sStart+Res;
				if Time*24*3600-OldTime>=0.05 then DrawZones;
			end;
			if CurZone.sEnd-CurZone.sStart<=0 then begin
				if CurZone.Prev<>nil then z:=CurZone.Prev else z:=CurZone.Next;
				RemoveZone(CurZone);
				Dispose(CurZone);
				CurZone := FindMaxZone(z);
				DrawZones;
			end;
		end;
	end;
	{$IOCHECKS ON}
	CloseFile(SrcFile);
	CloseFile(DestFile);
	DrawZones;
	DisposeZoneList(CurZone);
	DisposeZoneList(ErrZones);
	if not Cancel then beep;
end;

procedure ClearVars;
begin
	Cancel:=False;
	CurZone:=nil;
	ErrZones:=nil;
	LockCopy:=False;
	CancelErrors:=False;
	InfoFile:='';
	fSize:=0;
end;

procedure TfrmMain.bCopyClick(Sender: TObject);
begin
	if not LockCopy then begin
		ClearVars;
		SaveIni;
		CopyFile(eSrcFile.Text, eDestFile.Text);
		ClearVars;
		DrawZones;
		SaveIni;
	end;
end;

procedure TfrmMain.bSrcClick(Sender: TObject);
begin
	odSrc.FileName:=eSrcFile.Text;
	if odSrc.Execute then eSrcFile.Text:=odSrc.FileName;
end;

procedure TfrmMain.bDestClick(Sender: TObject);
var
	n: integer;
	path, fname: string;
begin
	n:=Length(eSrcFile.Text);
	while n>0 do
		if eSrcFile.Text[n]='\' then break else Dec(n);
	fname:=copy(eSrcFile.Text, n+1, Length(eSrcFile.Text)-n);
	n:=Length(eDestFile.Text);
	while n>0 do
		if eDestFile.Text[n]='\' then break else Dec(n);
	path:=copy(eDestFile.Text, 1, n);
	sdDest.FileName:=path+fname;
	if sdDest.Execute then eDestFile.Text:=sdDest.FileName;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
	ClearVars;
	DrawZones;
	IniFile := copy(Application.ExeName, 1, length(Application.ExeName)-3)+'ini';
	LoadIni;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
	SaveIni;
end;

procedure TfrmMain.bCancelClick(Sender: TObject);
begin
	Cancel:=true;
end;

procedure TfrmMain.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
//	if (Key=VK_F2) and (CurZone<>nil) then CurZone.Error:=true;
	if Key=VK_ESCAPE then Cancel:=true;
end;

procedure TfrmMain.FormResize(Sender: TObject);
begin
	DrawZones;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
	Cancel := true;
end;

procedure TfrmMain.iProgressPaint(Sender: TObject);
begin
  DrawZones;
end;

end.
bw / copier

Source Code

Files
