Subversion Repositories indexer_suite

unit RedundancyForm;

// TODO: man soll einstellen können, dass er redundanzen nur innerhalb eines datenträgers (= root node) findet

interface

uses

  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,

  System.Classes, Vcl.Graphics, AdoDb,

  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Samples.Gauges;

type

  TfrmRedundancy = class(TForm)

    Button1: TButton;

    Memo1: TMemo;

    Gauge1: TGauge;

    Edit1: TEdit;

    Label1: TLabel;

    Label2: TLabel;

    ComboBox1: TComboBox;

    Label3: TLabel;

    Label4: TLabel;

    procedure Button1Click(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

    procedure FormShow(Sender: TObject);

  private

    procedure Mode2Rec(StartDir: string; const FileMask: string;

      var cntRedundant: integer; var cntUnique: integer);

  protected

    StopRequest: Boolean;

    procedure EnableDisableControls(v: Boolean);

    function TableName: string;

    function conn: TAdoConnection;

  end;

implementation

{$R *.dfm}

uses

  DB, AdoConnHelper, IdHashMessageDigest, idHash, MainForm, IniFiles;

function MD5File(const FileName: string): string;

var

  IdMD5: TIdHashMessageDigest5;

  FS: TFileStream;

begin

  IdMD5 := TIdHashMessageDigest5.Create;

  FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);

  try

{$IFDEF UNICODE} // I actually do not know at which version of Delphi/Indy, this has changed.

    Result := IdMD5.HashStreamAsHex(FS);

{$ELSE}

    Result := IdMD5.AsHex(IdMD5.HashValue(FS));

{$ENDIF}

  finally

    FS.Free;

    IdMD5.Free;

  end;

end;

procedure TfrmRedundancy.Mode2Rec(StartDir: string; const FileMask: string;

  var cntRedundant: integer; var cntUnique: integer);

  procedure CheckFile(aFilename: string);

  var

    md5: string;

  begin

    try

      Label4.Caption := aFilename;

      md5 := MD5File(aFilename);

      if conn.GetScalar('select count(*) from ' + TableName +

        ' where md5hash = ' + conn.SQLStringEscape(md5)) = 0 then

      begin

        Memo1.Lines.Add(aFilename);

        Inc(cntUnique);

      end

      else

      begin

        Inc(cntRedundant);

      end;

    except

      on E: Exception do

      begin

        Memo1.Lines.Add(Format('Error: Cannot process %s : %s',

          [aFilename, E.Message]))

      end;

    end;

  end;

var

  SR: TSearchRec;

  DirList: TStrings;

  IsFound: Boolean;

  i: integer;

begin

  StartDir := IncludeTrailingPathDelimiter(StartDir);

  i := 0;

  IsFound := FindFirst(StartDir + FileMask, faAnyFile - faDirectory, SR) = 0;

  try

    while IsFound do

    begin

      Inc(i);

      Application.ProcessMessages;

      if Application.Terminated or StopRequest then

        Abort;

      CheckFile(StartDir + SR.Name);

      IsFound := FindNext(SR) = 0;

    end;

  finally

    FindClose(SR);

  end;

  // Build a list of subdirectories

  DirList := TStringList.Create;

  try

    IsFound := FindFirst(StartDir + '*', faDirectory, SR) = 0;

    try

      while IsFound do

      begin

        if (SR.Name <> '.') and (SR.Name <> '..') then

        begin

          Application.ProcessMessages;

          if Application.Terminated or StopRequest then

            Abort;

          DirList.Add(StartDir + SR.Name);

        end;

        IsFound := FindNext(SR) = 0;

      end;

    finally

      FindClose(SR);

    end;

    // Scan the list of subdirectories

    for i := 0 to DirList.Count - 1 do

    begin

      try

        Mode2Rec(DirList[i], FileMask, cntRedundant, cntUnique);

      except

        on E: Exception do

        begin

          if E is EAbort then

            Abort;

          Memo1.Lines.Add('Unexpected error at directory ' + DirList[i] + ': ' +

            E.Message);

        end;

      end;

    end;

  finally

    DirList.Free;

  end;

end;

function TfrmRedundancy.TableName: string;

begin

  result := frmMain.TableName;

end;

procedure TfrmRedundancy.Button1Click(Sender: TObject);

var

  q: TADODataSet;

  fMD5: TField;

  fFilename: TField;

  dirMask: string;

  cntRedundant: integer;

  cntUnique: integer;

begin

  EnableDisableControls(False);

  if ComboBox1.ItemIndex = 1 then

    Gauge1.Visible := False;

  Memo1.Lines.Clear;

  try

{$REGION 'Mode 1'}

    if ComboBox1.ItemIndex = 0 then

    begin

      dirMask := IncludeTrailingPathDelimiter(Edit1.Text) + '%';

      q := conn.GetTable

        ('select filename, md5hash from '+TableName+' where filename like ' +

        conn.SQLStringEscape(dirMask) + ' order by filename');

      try

        Gauge1.MinValue := 0;

        Gauge1.MaxValue := q.RecordCount;

        Gauge1.Progress := 0;

        cntRedundant := 0;

        cntUnique := 0;

        fMD5 := q.FieldByName('md5hash');

        fFilename := q.FieldByName('filename');

        while not q.Eof do

        begin

          if conn.GetScalar('select count(*) from '+TableName+' where md5hash = ' +

            conn.SQLStringEscape(fMD5.AsString) + ' and filename not like ' +

            conn.SQLStringEscape(dirMask)) = 0 then

          begin

            Memo1.Lines.Add(fFilename.AsString);

            Inc(cntUnique);

          end

          else

          begin

            Inc(cntRedundant);

          end;

          Gauge1.Progress := Gauge1.Progress + 1;

          Application.ProcessMessages;

          if Application.Terminated then

            Abort;

          q.Next;

        end;

      finally

        q.Free;

      end;

    end;

{$ENDREGION}

{$REGION 'Mode 2'}

    if ComboBox1.ItemIndex = 1 then

    begin

      cntRedundant := 0;

      cntUnique := 0;

      Mode2Rec(Edit1.Text, '*', cntRedundant, cntUnique);

    end;

{$ENDREGION}

    if (cntRedundant = 0) and (cntUnique = 0) then

      raise Exception.Create('No files found. Is the string correct?')

    else

      ShowMessageFmt('Done. %d files are redundant. %d are unique.',

        [cntRedundant, cntUnique]);

    if ComboBox1.ItemIndex = 0 then

    begin

      ShowMessage

        ('Attention: Only check 1 directory at a time, then delete redundant files, then re-index and only then continue with checking the redundancy of the any other directory.');

    end;

  finally

    EnableDisableControls(True);

    Gauge1.Progress := 0;

    Gauge1.Visible := True;

    Label4.Caption := '';

  end;

end;

function TfrmRedundancy.conn: TAdoConnection;

begin

  Result := frmMain.AdoConnection1;

end;

procedure TfrmRedundancy.EnableDisableControls(v: Boolean);

begin

  Edit1.Enabled := v;

  Button1.Enabled := v;

  ComboBox1.Enabled := v;

end;

procedure TfrmRedundancy.FormClose(Sender: TObject; var Action: TCloseAction);

begin

  Action := caFree;

end;

procedure TfrmRedundancy.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

  StopRequest := True;

end;

procedure TfrmRedundancy.FormShow(Sender: TObject);

var

  ini: TMemIniFile;

begin

  ini := frmMain.ini;

  Edit1.Text := ini.ReadString('RedundancyFinder', 'DefaultDir', '');

  ComboBox1.ItemIndex := ini.ReadInteger('RedundancyFinder', 'DefaultMode', 1)-1;

end;

end.