WebSVN – indexer_suite – Diff – /trunk/IndexCreatorForm.pas


unit IndexCreatorForm;
 
// TODO: vor einem fehler bitte vorher einen löschvorgang durchführen --> geht nicht?
// TODO: berücksichtigen, wenn datei gesperrt. etc, fehler anschauen
// TODO: warum sind in der db mehr einträge als dateien auf der festplatte sind?!
// TODO: Möglichkeit geben, Dateien und Verzeichnisse auszuschließen
// TODO: should we include flags (readonly, invisible, compressed, encrypted)?
// TODO: search+replace tool, wenn man große verschiebungen vorgenommen hat
// update top (100000) files set filename = replace(filename, '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\', 'EHDD:\') where filename like '%\\?\%';
// TODO: anzeige, wie viele stunden der prozess schon läuft
// TODO: multithreading
// TODO: diverse tools schreiben, die die datenbank nutzen, z.b. ein tool, das prüft, ob ein verzeichnis vollständig redundant ist
// TODO: Beim Lauf F:\nas\data wurden 1312 Fehler gefunden, aber nicht geloggt! ?! Eine exception im exception handler?!
// => nochmal durchlaufen lassen
// TODO: "Laufwerk" EHDD: soll man auch eingeben dürfen (das ist z.b. wichtig, wenn man Querverknüpfung vom Explorer verwendet)
// TODO: validate modus auch ohne prüfsummencheck. nur gucken ob die dateien existieren
 
{$DEFINE VIATHINKSOFT}
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, DB, ADODB, Menus;
 
const
  modusUpdate = 0;
  modusRecreate = 1;
  modusValidation = 2;
 
type
  TfrmIndexCreator = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    LabeledEdit2: TLabeledEdit;
    Button2: TButton;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    PopupMenu1: TPopupMenu;
    Copyuniquepathtoclipboard1: TMenuItem;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    Label13: TLabel;
    Memo1: TMemo;
    Button4: TButton;
    Label14: TLabel;
    cbNoDelete: TCheckBox;
    Memo2: TMemo;
    cbVerboseLogs: TCheckBox;
    cbSimulate: TCheckBox;
    rgModus: TRadioGroup;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button2Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Copyuniquepathtoclipboard1Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure rgModusClick(Sender: TObject);
  private
    StopRequest: boolean;
    sumsize: int64;
    sumfiles: int64;
    sumfiles_new: int64;
    sumfiles_updated: int64;
    sumfiles_error: int64;
    sumfiles_deleted: int64;
    sumfiles_integrityfail: int64;
    function TableName: string;
    function conn: TAdoConnection;
    procedure Rec(StartDir: string; const FileMask: string);
    procedure CheckFile(const originalFileName, uniqueFilename: string);
    procedure EnableDisableControls(enabled: boolean);
    procedure IndexDrive(initialdir: string);
    procedure RedrawStats;
    procedure DeleteVanishedFiles(mask: string = '');
    class function DriveGuid(const Letter: char): string; static;
    class function uniqueFilename(const filename: string): string; static;
    class function VtsSpecial(const filename: string): string; static;
    procedure DeleteAllFiles(mask: string = '');
  end;
 
implementation
 
{$R *.dfm}
 
uses
  FileCtrl, DateUtils, inifiles, IdHashMessageDigest, idHash, Math, Clipbrd,
  StrUtils, AdoConnHelper, MainForm;
 
const
  Win32ImportSuffix = {$IFDEF Unicode}'W'{$ELSE}'A'{$ENDIF};
 
function GetVolumeNameForVolumeMountPointA(lpszVolumeMountPoint: PAnsiChar;
  lpszVolumeName: PAnsiChar; cchBufferLength: DWORD): BOOL; stdcall;
  external 'kernel32.dll';
function GetVolumeNameForVolumeMountPointW(lpszVolumeMountPoint: PWideChar;
  lpszVolumeName: PWideChar; cchBufferLength: DWORD): BOOL; stdcall;
  external 'kernel32.dll';
function GetVolumeNameForVolumeMountPoint(lpszVolumeMountPoint: PChar;
  lpszVolumeName: PChar; cchBufferLength: DWORD): BOOL; stdcall;
  external 'kernel32.dll' name 'GetVolumeNameForVolumeMountPoint' +
  Win32ImportSuffix;
 
const
  ERROR_FIELD_SIZE = 200;
{$IFDEF VIATHINKSOFT}
  // Example of multiple drives merging to one Index
  // Find out via "mountvol" command
  GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';
  GUID_EHDD_B = '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\';
  GUID_EHDD_R = '\\?\Volume{9d53ea3c-175c-4a8f-a7b4-7b9e6b765e58}\';
{$ENDIF}
 
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;
 
function FileMTime_UTC(const filename: string): TDateTime;
var
  fad: TWin32FileAttributeData;
  systime: SYSTEMTIME;
begin
  if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
    RaiseLastOSError;
 
  FileTimeToSystemTime(fad.ftLastWriteTime, systime);
 
  Result := SystemTimeToDateTime(systime);
end;
 
function FileCTime_UTC(const filename: string): TDateTime;
var
  fad: TWin32FileAttributeData;
  systime: SYSTEMTIME;
begin
  if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
    RaiseLastOSError;
 
  FileTimeToSystemTime(fad.ftCreationTime, systime);
 
  Result := SystemTimeToDateTime(systime);
end;
 
function GetFileSize(const AFileName: String): int64;
var
  lFindData: TWin32FindData;
  lHandle: Cardinal;
begin
  // https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html
  lHandle := FindFirstFile(PChar(AFileName), lFindData);
  if (lHandle <> INVALID_HANDLE_VALUE) then
  begin
    Result := lFindData.nFileSizeLow;
    PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;
    Windows.FindClose(lHandle);
  end
  else
    Result := 0;
end;
 
function IntToStr2(i: int64): string;
begin
  // https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html
  Result := Format('%.0n', [i / 1]);
end;
 
function ConvertBytes(Bytes: int64): string;
const
  Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',
    'PB', 'EB', 'ZB', 'YB');
var
  i: Integer;
begin
  // https://stackoverflow.com/questions/30548940/correct-way-to-convert-size-in-bytes-to-kb-mb-gb-delphi
  i := 0;
 
  while Bytes > Power(1024, i + 1) do
    Inc(i);
 
  Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +
    Description[i];
end;
 
var
  DriveGuidCache: TStringList = nil;
 
class function TfrmIndexCreator.DriveGuid(const Letter: char): string;
var
  Buffer: array [0 .. 49] of char;
begin
  if not Assigned(DriveGuidCache) then
    DriveGuidCache := TStringList.Create;
 
  Result := DriveGuidCache.Values[Letter];
  if Result = '' then
  begin
    Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,
      Length(Buffer)));
    Result := Buffer;
    DriveGuidCache.Values[Letter] := Result;
  end;
end;
 
class function TfrmIndexCreator.uniqueFilename(const filename: string): string;
var
  guid: string;
begin
  if Length(filename) < 2 then
    exit;
  if filename[2] = ':' then
  begin
    guid := DriveGuid(filename[1]);
 
    Result := guid + Copy(filename, 4, Length(filename) - 3);
 
    // result := LowerCase(result);
  end
  else
    Result := filename; // z.B. UNC-Pfad
end;
 
class function TfrmIndexCreator.VtsSpecial(const filename: string): string;
begin
  Result := filename;
{$IFDEF VIATHINKSOFT}
  Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);
  Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);
  Result := StringReplace(Result, GUID_EHDD_R, 'EHDD:\', []);
{$ENDIF}
end;
 
function SpecialCompare(a, b: TDateTime): boolean; // true = same timestamp
begin
  if SecondsBetween(a,b) < 2 then exit(true); // equal
 
  if SecondsBetween(a,b) > 7200 then exit(false);
 
  // Minute and Second equal, and difference is < 2h: fair enough, seems to be a DST issue
  if copy(TimeToStr(a),4,5) = copy(TimeToStr(b),4,5) then exit(true);
 
  result := false;
end;
 
procedure TfrmIndexCreator.CheckFile(const originalFileName,
  uniqueFilename: string);
 
  function DateTimeToSQL(dt: TDateTime): string;
  begin
    if dt = -1 then
      Result := 'NULL'
    else
      Result := conn.SQLStringEscape(DateTimetoStr(dt));
  end;
 
type
  TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);
 
var
  lastCheckedMd5: string;
 
  function Exists(const filename: string; size: int64;
    const modified: TDateTime): TExistResult;
  var
    q: TADODataSet;
  begin
    q := conn.GetTable('select error, size, modified, md5hash from ' + TableName
      + ' where filename = ' + conn.SQLStringEscape
      (VtsSpecial(uniqueFilename)));
    try
      if q.RecordCount = 0 then
        Result := erDoesNotExist
      else if not q.Fields[0].IsNull then
        Result := erHadError
      else if (q.Fields[1].AsString <> IntToStr(size)) or // we are combining strings because of int64
        not SpecialCompare(q.Fields[2].AsDateTime, modified) then
      begin
        Result := erChanged
      end
      else
        Result := erUnchanged;
      lastCheckedMd5 := q.Fields[3].AsString;
    finally
      FreeAndNil(q);
    end;
  end;
 
var
  created, modified: TDateTime;
  size: int64;
  md5: string;
begin
  Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);
  Application.ProcessMessages;
 
  try
    if FileExists(uniqueFilename) then
      created := FileCTime_UTC(uniqueFilename)
    else
      created := -1;
 
    if FileExists(uniqueFilename) then
      modified := FileMTime_UTC(uniqueFilename)
    else
      modified := -1;
 
    size := GetFileSize(uniqueFilename);
    Inc(sumsize, size);
    Inc(sumfiles);
 
    if rgModus.ItemIndex = modusRecreate then
    begin
      md5 := MD5File(uniqueFilename);
      if not cbSimulate.Checked then
      begin
        conn.ExecSQL('INSERT INTO ' + TableName +
          ' (filename, size, created, modified, md5hash, error) values (' +
          conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
          IntToStr(size) + ', ' + DateTimeToSQL(created) +
          ', ' + DateTimeToSQL(modified) + ', ' +
          conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
      end;
      if cbVerboseLogs.Checked then
        Memo2.Lines.Add('New: ' + uniqueFilename);
      Inc(sumfiles_new);
    end
    else
    begin
      case Exists(uniqueFilename, size, modified) of
        erDoesNotExist: // File does not exist or has a different hash
          begin
            if rgModus.ItemIndex <> modusValidation then
              md5 := MD5File(uniqueFilename);
            if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
            then
            begin
              conn.ExecSQL('INSERT INTO ' + TableName +
                ' (filename, size, created, modified, md5hash, error) values ('
                + conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
                IntToStr(size) + ', ' +
                DateTimeToSQL(created) + ', ' +
                DateTimeToSQL(modified) + ', ' +
                conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
            end;
            if cbVerboseLogs.Checked then
              Memo2.Lines.Add('New: ' + uniqueFilename);
            Inc(sumfiles_new);
          end;
        erHadError, erChanged:
          begin
            if rgModus.ItemIndex <> modusValidation then
              md5 := MD5File(uniqueFilename);
            if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
            then
            begin
              conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
                IntToStr(size) + ', created = ' +
                DateTimeToSQL(created) + ', modified = ' +
                DateTimeToSQL(modified) + ', md5hash = ' +
                conn.SQLStringEscape(LowerCase(md5)) +
                ', error = NULL WHERE filename = ' + conn.SQLStringEscape
                (VtsSpecial(uniqueFilename)) + ';');
            end;
            if cbVerboseLogs.Checked then
              Memo2.Lines.Add('Updated: ' + uniqueFilename);
            Inc(sumfiles_updated);
          end;
        erUnchanged: // Date/Time+Size has not changed
          begin
            {$REGION 'Update it to correct wrong UTC/DST datasets...'}
            conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
              IntToStr(size) + ', created = ' +
              DateTimeToSQL(created) + ', modified = ' +
              DateTimeToSQL(modified) +
              ', error = NULL WHERE filename = ' + conn.SQLStringEscape
              (VtsSpecial(uniqueFilename)) + ';');
            {$ENDREGION}
 
            if rgModus.ItemIndex = modusValidation then
            begin
              md5 := MD5File(uniqueFilename);
              if not SameText(md5, lastCheckedMd5) then
              begin
                Memo2.Lines.Add
                  ('!!! HASH HAS CHANGED WHILE DATETIME+SIZE IS THE SAME: ' +
                  uniqueFilename + ' (' + lastCheckedMd5 + ' became ' +
                  md5 + ')');
                Memo2.Color := clRed;
                Inc(sumfiles_integrityfail);
              end;
            end;
          end;
      end;
    end;
  except
    on E: Exception do
    begin
      if E is EAbort then
        Abort;
      // if AdoConnection1.InTransaction then AdoConnection1.RollbackTrans;
      // AdoConnection1.BeginTrans;
      try
        if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
        then
        begin
          conn.ExecSQL('DELETE FROM ' + TableName + ' WHERE filename = ' +
            conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ';');
          conn.ExecSQL('INSERT INTO ' + TableName +
            ' (filename, size, created, modified, md5hash, error) values (' +
            conn.SQLStringEscape(VtsSpecial(uniqueFilename)) +
            ', NULL, NULL, NULL, NULL, ' + conn.SQLStringEscape(Copy(E.Message,
            1, ERROR_FIELD_SIZE)) + ');');
          Memo2.Lines.Add('Error (logged): ' + E.Message + ' at file ' +
            VtsSpecial(uniqueFilename));
        end
        else
        begin
          Memo2.Lines.Add('Error: ' + E.Message + ' at file ' +
            VtsSpecial(uniqueFilename));
        end;
        // AdoConnection1.CommitTrans;
      except
        // AdoConnection1.RollbackTrans;
        Memo2.Lines.Add('Cannot write error into file database! ' + E.Message +
          ' at file ' + VtsSpecial(uniqueFilename));
      end;
      Inc(sumfiles_error);
    end;
  end;
 
  RedrawStats;
  Application.ProcessMessages;
end;
 
function TfrmIndexCreator.conn: TAdoConnection;
begin
  Result := frmMain.AdoConnection1;
end;
 
procedure TfrmIndexCreator.RedrawStats;
begin
  Label5.Caption := ConvertBytes(sumsize);
  Label6.Caption := IntToStr2(sumfiles);
  Label7.Caption := IntToStr2(sumfiles_new);
  Label9.Caption := IntToStr2(sumfiles_updated);
  Label11.Caption := IntToStr2(sumfiles_error);
  Label12.Caption := IntToStr2(sumfiles_deleted);
  // LabelXX.Caption := IntToStr2(sumfiles_integrityfail);
end;
 
procedure TfrmIndexCreator.Copyuniquepathtoclipboard1Click(Sender: TObject);
var
  s: string;
begin
  s := uniqueFilename(LabeledEdit2.Text);
  Clipboard.AsText := s;
{$IFDEF VIATHINKSOFT}
  if VtsSpecial(s) <> s then
  begin
    s := s + #13#10 + VtsSpecial(s);
  end;
{$ENDIF}
  ShowMessageFmt('Copied to clipboard:' + #13#10#13#10 + '%s', [s]);
end;
 
procedure TfrmIndexCreator.rgModusClick(Sender: TObject);
begin
  cbSimulate.enabled := rgModus.ItemIndex <> modusValidation;
  cbNoDelete.enabled := rgModus.ItemIndex <> modusValidation;
end;
 
function TfrmIndexCreator.TableName: string;
begin
  Result := frmMain.TableName;
end;
 
procedure TfrmIndexCreator.Rec(StartDir: string; const FileMask: string);
var
  SR: TSearchRec;
  DirList: TStrings;
  IsFound: boolean;
  i: Integer;
  UniqueStartDir: string;
begin
  StartDir := IncludeTrailingPathDelimiter(StartDir);
 
  i := 0;
  conn.BeginTrans;
  IsFound := FindFirst(StartDir + FileMask, faAnyFile - faDirectory, SR) = 0;
  try
    while IsFound do
    begin
      Inc(i);
      if i mod 1000 = 0 then // Only for performance
      begin
        conn.CommitTrans;
        conn.BeginTrans;
      end;
      Application.ProcessMessages;
      if Application.Terminated or StopRequest then
        Abort;
 
      if UniqueStartDir = '' then
        UniqueStartDir := uniqueFilename(StartDir);
      CheckFile(StartDir + SR.Name, UniqueStartDir + SR.Name);
      IsFound := FindNext(SR) = 0;
    end;
  finally
    FindClose(SR);
    conn.CommitTrans;
  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
        Rec(DirList[i], FileMask);
      except
        on E: Exception do
        begin
          if E is EAbort then
            Abort;
          Memo2.Lines.Add('Unexpected error at directory ' + DirList[i] + ': ' +
            E.Message);
        end;
      end;
    end;
  finally
    DirList.Free;
  end;
end;
 
procedure TfrmIndexCreator.DeleteAllFiles(mask: string = '');
begin
  sumfiles_deleted := conn.GetScalar('select count(*) as cnt from ' + TableName
    + ' where filename like ' + conn.SQLStringEscape(VtsSpecial(mask)));
  RedrawStats;
 
  if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation) then
  begin
    if (mask = '') or (mask = '%') then
      conn.ExecSQL('delete from ' + TableName)
    else
      conn.ExecSQL('delete from ' + TableName + ' where filename like ' +
        conn.SQLStringEscape(VtsSpecial(mask)));
  end;
end;
 
procedure TfrmIndexCreator.DeleteVanishedFiles(mask: string = '');
 
{$IFDEF VIATHINKSOFT}
var
  cacheAconnected: boolean;
  cacheBconnected: boolean;
  cacheRconnected: boolean;
{$ENDIF}
  function AllowFileCheck(AFileName: string): boolean;
  var
    guid: string;
  begin
    Result := false;
{$IFDEF VIATHINKSOFT}
    if StartsText('EHDD:\', AFileName) then
    begin
      if not cacheAconnected and SysUtils.DirectoryExists(GUID_EHDD_A) then
      begin
        cacheAconnected := true;
      end;
      if not cacheBconnected and SysUtils.DirectoryExists(GUID_EHDD_B) then
      begin
        cacheBconnected := true;
      end;
      if not cacheRconnected and SysUtils.DirectoryExists(GUID_EHDD_R) then
      begin
        cacheRconnected := true;
      end;
      Result := cacheAconnected or cacheBconnected or cacheRconnected;
    end
    else
{$ENDIF}
      if StartsText('\\?\Volume', AFileName) then
      begin
        guid := Copy(AFileName, 1, 49);
        if EndsText('\', guid) then // should always happen
        begin
          // TODO: cache this result somehow, so that DirectoryExists() does not need to be called all the time
          if SysUtils.DirectoryExists(guid) then // is drive connected/existing?
          begin
            Result := true;
          end;
        end;
      end
      else
      begin
        // TODO: Einen Code für Netzlaufwerke machen: Wir dürfen nur Dateien löschen,
        // wenn das Netzlaufwerk wirklich da ist.
      end;
  end;
 
  function FileDoesExist(AFileName: string): boolean;
  begin
{$IFDEF VIATHINKSOFT}
    if StartsText('EHDD:\', AFileName) then
    begin
      // Attention: AllowFileCheck must be called to initialize cacheAconnected and cacheBconnected
 
      if cacheAconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
        GUID_EHDD_A, [])) then
        exit(true);
 
      if cacheBconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
        GUID_EHDD_B, [])) then
        exit(true);
 
      if cacheBconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
        GUID_EHDD_R, [])) then
        exit(true);
 
      exit(false);
    end;
{$ENDIF}
    exit(FileExists(AFileName));
  end;
 
var
  filename: string;
  q: TADODataSet;
  fFileName: TField;
  i: int64;
begin
  if mask <> '' then
    q := conn.GetTable('select filename from ' + TableName +
      ' where filename like ' + conn.SQLStringEscape(VtsSpecial(mask)))
  else
    q := conn.GetTable('select filename from ' + TableName);
  try
    i := 0;
    fFileName := q.FieldByName('filename');
    while not q.Eof do
    begin
      filename := fFileName.AsString;
 
      if AllowFileCheck(filename) and not FileDoesExist(filename) then
      begin
        if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
        then
        begin
          conn.ExecSQL('delete from ' + TableName + ' where filename = ' +
            conn.SQLStringEscape(filename));
        end;
        Inc(sumfiles_deleted);
        if cbVerboseLogs.Checked then
          Memo2.Lines.Add('Deleted: ' + filename);
        RedrawStats;
      end;
 
      Inc(i);
      if i mod 100 = 0 then
      begin
        Label1.Caption := MinimizeName(filename, Label1.Canvas, Label1.Width);
        Application.ProcessMessages;
        if Application.Terminated or StopRequest then
          Abort;
      end;
 
      q.Next;
    end;
  finally
    FreeAndNil(q);
  end;
end;
 
procedure TfrmIndexCreator.IndexDrive(initialdir: string);
begin
  if not cbNoDelete.Checked and not cbSimulate.Checked and
    (rgModus.ItemIndex <> modusValidation) then
  begin
    if rgModus.ItemIndex = modusRecreate then
    begin
      DeleteAllFiles(uniqueFilename(IncludeTrailingPathDelimiter
        (initialdir)) + '%');
    end
    else
    begin
      DeleteVanishedFiles
        (uniqueFilename(IncludeTrailingPathDelimiter(initialdir)) + '%');
    end;
  end;
 
  Rec(IncludeTrailingPathDelimiter(initialdir), '*');
end;
 
procedure TfrmIndexCreator.Button1Click(Sender: TObject);
begin
  sumsize := 0;
  sumfiles := 0;
  sumfiles_new := 0;
  sumfiles_updated := 0;
  sumfiles_error := 0;
  sumfiles_deleted := 0;
  sumfiles_integrityfail := 0;
 
  Label1.Caption := 'Please wait...';
  Label5.Caption := '0';
  Label6.Caption := '0';
  Label7.Caption := '0';
  Label9.Caption := '0';
  Label11.Caption := '0';
  Label12.Caption := '0';
  Application.ProcessMessages;
 
  EnableDisableControls(false);
  try
    if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
    begin
      raise Exception.CreateFmt('Directory %s not found.', [LabeledEdit2.Text]);
    end;
 
    IndexDrive(LabeledEdit2.Text);
 
    (*
      if not Application.Terminated or StopRequest then
      begin
      ShowMessage('Finished');
      end;
    *)
  finally
    if not StopRequest then EnableDisableControls(true);
  end;
 
  if not StopRequest then
  begin
    Beep;
    Label1.Caption := 'Done.';
    Application.ProcessMessages;
  end;
end;
 
procedure TfrmIndexCreator.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  StopRequest := true;
  Action := caFree; // TODO: müssen wir warten bis der prozess angehalten ist?
end;
 
procedure TfrmIndexCreator.FormShow(Sender: TObject);
var
  ini: TMemIniFile;
begin
  ini := frmMain.ini;
  rgModus.ItemIndex := ini.ReadInteger('IndexCreator', 'DefaultMode', modusUpdate);
  cbNoDelete.Checked := ini.ReadBool('IndexCreator', 'DefaultCheckVanished', false);
  cbVerboseLogs.Checked := ini.ReadBool('IndexCreator', 'DefaultVerboseLogs', false);
  cbSimulate.Checked := ini.ReadBool('IndexCreator', 'DefaultSimulate', false);
  LabeledEdit2.Text := ini.ReadString('IndexCreator', 'DefaultDir', 'C:\');
end;
 
procedure TfrmIndexCreator.Button2Click(Sender: TObject);
begin
  StopRequest := true;
  Close;
end;
 
procedure TfrmIndexCreator.Button4Click(Sender: TObject);
var
  i: Integer;
  s: string;
begin
  sumsize := 0;
  sumfiles := 0;
  sumfiles_new := 0;
  sumfiles_updated := 0;
  sumfiles_error := 0;
  sumfiles_deleted := 0;
 
  Label1.Caption := 'Please wait...';
  Label5.Caption := '0';
  Label6.Caption := '0';
  Label7.Caption := '0';
  Label9.Caption := '0';
  Label11.Caption := '0';
  Label12.Caption := '0';
  Application.ProcessMessages;
 
  EnableDisableControls(false);
  try
    // if fileexists('tmp') then memo1.lines.LoadFromFile('tmp');
    for i := Memo1.Lines.Count - 1 downto 0 do
    begin
      s := Memo1.Lines.strings[i];
      if Trim(s) <> '' then
      begin
        LabeledEdit2.Text := s;
 
        if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
        begin
          raise Exception.CreateFmt('Directory %s not found.',
            [LabeledEdit2.Text]);
        end;
 
        IndexDrive(LabeledEdit2.Text);
      end;
      Memo1.Lines.Delete(i);
      // memo1.lines.SaveToFile('tmp');
    end;
 
    (*
      if not Application.Terminated or StopRequest then
      begin
      ShowMessage('Finished');
      end;
    *)
  finally
    EnableDisableControls(true);
  end;
 
  Beep;
  Label1.Caption := 'Done.';
  Application.ProcessMessages;
end;
 
procedure TfrmIndexCreator.EnableDisableControls(enabled: boolean);
begin
  rgModus.enabled := enabled;
  cbNoDelete.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
  cbVerboseLogs.enabled := enabled;
  cbSimulate.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
  Button1.enabled := enabled;
  LabeledEdit2.enabled := enabled;
  Memo1.enabled := enabled;
  Button4.enabled := enabled;
end;
 
end.
 

Rev 6	Rev 8
1	unit IndexCreatorForm;	1	unit IndexCreatorForm;
2		2
3	// TODO: vor einem fehler bitte vorher einen löschvorgang durchführen --> geht nicht?	3	// TODO: vor einem fehler bitte vorher einen löschvorgang durchführen --> geht nicht?
4	// TODO: berücksichtigen, wenn datei gesperrt. etc, fehler anschauen	4	// TODO: berücksichtigen, wenn datei gesperrt. etc, fehler anschauen
5	// TODO: warum sind in der db mehr einträge als dateien auf der festplatte sind?!	5	// TODO: warum sind in der db mehr einträge als dateien auf der festplatte sind?!
6	// TODO: Möglichkeit geben, Dateien und Verzeichnisse auszuschließen	6	// TODO: Möglichkeit geben, Dateien und Verzeichnisse auszuschließen
7	// TODO: should we include flags (readonly, invisible, compressed, encrypted)?	7	// TODO: should we include flags (readonly, invisible, compressed, encrypted)?
8	// TODO: search+replace tool, wenn man große verschiebungen vorgenommen hat	8	// TODO: search+replace tool, wenn man große verschiebungen vorgenommen hat
9	// update top (100000) files set filename = replace(filename, '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\', 'EHDD:\') where filename like '%\\?\%';	9	// update top (100000) files set filename = replace(filename, '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\', 'EHDD:\') where filename like '%\\?\%';
10	// TODO: anzeige, wie viele stunden der prozess schon läuft	10	// TODO: anzeige, wie viele stunden der prozess schon läuft
11	// TODO: multithreading	11	// TODO: multithreading
12	// TODO: diverse tools schreiben, die die datenbank nutzen, z.b. ein tool, das prüft, ob ein verzeichnis vollständig redundant ist	12	// TODO: diverse tools schreiben, die die datenbank nutzen, z.b. ein tool, das prüft, ob ein verzeichnis vollständig redundant ist
13	// TODO: Beim Lauf F:\nas\data wurden 1312 Fehler gefunden, aber nicht geloggt! ?! Eine exception im exception handler?!	13	// TODO: Beim Lauf F:\nas\data wurden 1312 Fehler gefunden, aber nicht geloggt! ?! Eine exception im exception handler?!
14	// => nochmal durchlaufen lassen	14	// => nochmal durchlaufen lassen
15	// TODO: "Laufwerk" EHDD: soll man auch eingeben dürfen (das ist z.b. wichtig, wenn man Querverknüpfung vom Explorer verwendet)	15	// TODO: "Laufwerk" EHDD: soll man auch eingeben dürfen (das ist z.b. wichtig, wenn man Querverknüpfung vom Explorer verwendet)
16	// TODO: validate modus auch ohne prüfsummencheck. nur gucken ob die dateien existieren	16	// TODO: validate modus auch ohne prüfsummencheck. nur gucken ob die dateien existieren
17		17
18	{$DEFINE VIATHINKSOFT}	18	{$DEFINE VIATHINKSOFT}
19		19
20	interface	20	interface
21		21
22	uses	22	uses
23	Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,	23	Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
24	Dialogs, StdCtrls, ComCtrls, ExtCtrls, DB, ADODB, Menus;	24	Dialogs, StdCtrls, ComCtrls, ExtCtrls, DB, ADODB, Menus;
25		25
26	const	26	const
27	modusUpdate = 0;	27	modusUpdate = 0;
28	modusRecreate = 1;	28	modusRecreate = 1;
29	modusValidation = 2;	29	modusValidation = 2;
30		30
31	type	31	type
32	TfrmIndexCreator = class(TForm)	32	TfrmIndexCreator = class(TForm)
33	Button1: TButton;	33	Button1: TButton;
34	Label1: TLabel;	34	Label1: TLabel;
35	LabeledEdit2: TLabeledEdit;	35	LabeledEdit2: TLabeledEdit;
36	Button2: TButton;	36	Button2: TButton;
37	Label2: TLabel;	37	Label2: TLabel;
38	Label3: TLabel;	38	Label3: TLabel;
39	Label4: TLabel;	39	Label4: TLabel;
40	Label5: TLabel;	40	Label5: TLabel;
41	Label6: TLabel;	41	Label6: TLabel;
42	Label7: TLabel;	42	Label7: TLabel;
43	PopupMenu1: TPopupMenu;	43	PopupMenu1: TPopupMenu;
44	Copyuniquepathtoclipboard1: TMenuItem;	44	Copyuniquepathtoclipboard1: TMenuItem;
45	Label8: TLabel;	45	Label8: TLabel;
46	Label9: TLabel;	46	Label9: TLabel;
47	Label10: TLabel;	47	Label10: TLabel;
48	Label11: TLabel;	48	Label11: TLabel;
49	Label12: TLabel;	49	Label12: TLabel;
50	Label13: TLabel;	50	Label13: TLabel;
51	Memo1: TMemo;	51	Memo1: TMemo;
52	Button4: TButton;	52	Button4: TButton;
53	Label14: TLabel;	53	Label14: TLabel;
54	cbNoDelete: TCheckBox;	54	cbNoDelete: TCheckBox;
55	Memo2: TMemo;	55	Memo2: TMemo;
56	cbVerboseLogs: TCheckBox;	56	cbVerboseLogs: TCheckBox;
57	cbSimulate: TCheckBox;	57	cbSimulate: TCheckBox;
58	rgModus: TRadioGroup;	58	rgModus: TRadioGroup;
59	procedure Button1Click(Sender: TObject);	59	procedure Button1Click(Sender: TObject);
60	procedure FormClose(Sender: TObject; var Action: TCloseAction);	60	procedure FormClose(Sender: TObject; var Action: TCloseAction);
61	procedure Button2Click(Sender: TObject);	61	procedure Button2Click(Sender: TObject);
62	procedure FormShow(Sender: TObject);	62	procedure FormShow(Sender: TObject);
63	procedure Copyuniquepathtoclipboard1Click(Sender: TObject);	63	procedure Copyuniquepathtoclipboard1Click(Sender: TObject);
64	procedure Button4Click(Sender: TObject);	64	procedure Button4Click(Sender: TObject);
65	procedure rgModusClick(Sender: TObject);	65	procedure rgModusClick(Sender: TObject);
66	private	66	private
67	StopRequest: boolean;	67	StopRequest: boolean;
68	sumsize: int64;	68	sumsize: int64;
69	sumfiles: int64;	69	sumfiles: int64;
70	sumfiles_new: int64;	70	sumfiles_new: int64;
71	sumfiles_updated: int64;	71	sumfiles_updated: int64;
72	sumfiles_error: int64;	72	sumfiles_error: int64;
73	sumfiles_deleted: int64;	73	sumfiles_deleted: int64;
74	sumfiles_integrityfail: int64;	74	sumfiles_integrityfail: int64;
75	function TableName: string;	75	function TableName: string;
76	function conn: TAdoConnection;	76	function conn: TAdoConnection;
77	procedure Rec(StartDir: string; const FileMask: string);	77	procedure Rec(StartDir: string; const FileMask: string);
78	procedure CheckFile(const originalFileName, uniqueFilename: string);	78	procedure CheckFile(const originalFileName, uniqueFilename: string);
79	procedure EnableDisableControls(enabled: boolean);	79	procedure EnableDisableControls(enabled: boolean);
80	procedure IndexDrive(initialdir: string);	80	procedure IndexDrive(initialdir: string);
81	procedure RedrawStats;	81	procedure RedrawStats;
82	procedure DeleteVanishedFiles(mask: string = '');	82	procedure DeleteVanishedFiles(mask: string = '');
83	class function DriveGuid(const Letter: char): string; static;	83	class function DriveGuid(const Letter: char): string; static;
84	class function uniqueFilename(const filename: string): string; static;	84	class function uniqueFilename(const filename: string): string; static;
85	class function VtsSpecial(const filename: string): string; static;	85	class function VtsSpecial(const filename: string): string; static;
86	procedure DeleteAllFiles(mask: string = '');	86	procedure DeleteAllFiles(mask: string = '');
87	end;	87	end;
88		88
89	implementation	89	implementation
90		90
91	{$R *.dfm}	91	{$R *.dfm}
92		92
93	uses	93	uses
94	FileCtrl, DateUtils, inifiles, IdHashMessageDigest, idHash, Math, Clipbrd,	94	FileCtrl, DateUtils, inifiles, IdHashMessageDigest, idHash, Math, Clipbrd,
95	StrUtils, AdoConnHelper, MainForm;	95	StrUtils, AdoConnHelper, MainForm;
96		96
97	const	97	const
98	Win32ImportSuffix = {$IFDEF Unicode}'W'{$ELSE}'A'{$ENDIF};	98	Win32ImportSuffix = {$IFDEF Unicode}'W'{$ELSE}'A'{$ENDIF};
99		99
100	function GetVolumeNameForVolumeMountPointA(lpszVolumeMountPoint: PAnsiChar;	100	function GetVolumeNameForVolumeMountPointA(lpszVolumeMountPoint: PAnsiChar;
101	lpszVolumeName: PAnsiChar; cchBufferLength: DWORD): BOOL; stdcall;	101	lpszVolumeName: PAnsiChar; cchBufferLength: DWORD): BOOL; stdcall;
102	external 'kernel32.dll';	102	external 'kernel32.dll';
103	function GetVolumeNameForVolumeMountPointW(lpszVolumeMountPoint: PWideChar;	103	function GetVolumeNameForVolumeMountPointW(lpszVolumeMountPoint: PWideChar;
104	lpszVolumeName: PWideChar; cchBufferLength: DWORD): BOOL; stdcall;	104	lpszVolumeName: PWideChar; cchBufferLength: DWORD): BOOL; stdcall;
105	external 'kernel32.dll';	105	external 'kernel32.dll';
106	function GetVolumeNameForVolumeMountPoint(lpszVolumeMountPoint: PChar;	106	function GetVolumeNameForVolumeMountPoint(lpszVolumeMountPoint: PChar;
107	lpszVolumeName: PChar; cchBufferLength: DWORD): BOOL; stdcall;	107	lpszVolumeName: PChar; cchBufferLength: DWORD): BOOL; stdcall;
108	external 'kernel32.dll' name 'GetVolumeNameForVolumeMountPoint' +	108	external 'kernel32.dll' name 'GetVolumeNameForVolumeMountPoint' +
109	Win32ImportSuffix;	109	Win32ImportSuffix;
110		110
111	const	111	const
112	ERROR_FIELD_SIZE = 200;	112	ERROR_FIELD_SIZE = 200;
113	{$IFDEF VIATHINKSOFT}	113	{$IFDEF VIATHINKSOFT}
-		114	// Example of multiple drives merging to one Index
-		115	// Find out via "mountvol" command
114	GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';	116	GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';
115	GUID_EHDD_B = '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\';	117	GUID_EHDD_B = '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\';
-		118	GUID_EHDD_R = '\\?\Volume{9d53ea3c-175c-4a8f-a7b4-7b9e6b765e58}\';
116	{$ENDIF}	119	{$ENDIF}
117		120
118	function MD5File(const filename: string): string;	121	function MD5File(const filename: string): string;
119	var	122	var
120	IdMD5: TIdHashMessageDigest5;	123	IdMD5: TIdHashMessageDigest5;
121	FS: TFileStream;	124	FS: TFileStream;
122	begin	125	begin
123	IdMD5 := TIdHashMessageDigest5.Create;	126	IdMD5 := TIdHashMessageDigest5.Create;
124	FS := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);	127	FS := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
125	try	128	try
126	{$IFDEF UNICODE} // I actually do not know at which version of Delphi/Indy, this has changed.	129	{$IFDEF UNICODE} // I actually do not know at which version of Delphi/Indy, this has changed.
127	Result := IdMD5.HashStreamAsHex(FS);	130	Result := IdMD5.HashStreamAsHex(FS);
128	{$ELSE}	131	{$ELSE}
129	Result := IdMD5.AsHex(IdMD5.HashValue(FS));	132	Result := IdMD5.AsHex(IdMD5.HashValue(FS));
130	{$ENDIF}	133	{$ENDIF}
131	finally	134	finally
132	FS.Free;	135	FS.Free;
133	IdMD5.Free;	136	IdMD5.Free;
134	end;	137	end;
135	end;	138	end;
136		139
137	function FileMTime_UTC(const filename: string): TDateTime;	140	function FileMTime_UTC(const filename: string): TDateTime;
138	var	141	var
139	fad: TWin32FileAttributeData;	142	fad: TWin32FileAttributeData;
140	systime: SYSTEMTIME;	143	systime: SYSTEMTIME;
141	begin	144	begin
142	if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then	145	if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
143	RaiseLastOSError;	146	RaiseLastOSError;
144		147
145	FileTimeToSystemTime(fad.ftLastWriteTime, systime);	148	FileTimeToSystemTime(fad.ftLastWriteTime, systime);
146		149
147	Result := SystemTimeToDateTime(systime);	150	Result := SystemTimeToDateTime(systime);
148	end;	151	end;
149		152
150	function FileCTime_UTC(const filename: string): TDateTime;	153	function FileCTime_UTC(const filename: string): TDateTime;
151	var	154	var
152	fad: TWin32FileAttributeData;	155	fad: TWin32FileAttributeData;
153	systime: SYSTEMTIME;	156	systime: SYSTEMTIME;
154	begin	157	begin
155	if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then	158	if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
156	RaiseLastOSError;	159	RaiseLastOSError;
157		160
158	FileTimeToSystemTime(fad.ftCreationTime, systime);	161	FileTimeToSystemTime(fad.ftCreationTime, systime);
159		162
160	Result := SystemTimeToDateTime(systime);	163	Result := SystemTimeToDateTime(systime);
161	end;	164	end;
162		165
163	function GetFileSize(const AFileName: String): int64;	166	function GetFileSize(const AFileName: String): int64;
164	var	167	var
165	lFindData: TWin32FindData;	168	lFindData: TWin32FindData;
166	lHandle: Cardinal;	169	lHandle: Cardinal;
167	begin	170	begin
168	// https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html	171	// https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html
169	lHandle := FindFirstFile(PChar(AFileName), lFindData);	172	lHandle := FindFirstFile(PChar(AFileName), lFindData);
170	if (lHandle <> INVALID_HANDLE_VALUE) then	173	if (lHandle <> INVALID_HANDLE_VALUE) then
171	begin	174	begin
172	Result := lFindData.nFileSizeLow;	175	Result := lFindData.nFileSizeLow;
173	PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;	176	PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;
174	Windows.FindClose(lHandle);	177	Windows.FindClose(lHandle);
175	end	178	end
176	else	179	else
177	Result := 0;	180	Result := 0;
178	end;	181	end;
179		182
180	function IntToStr2(i: int64): string;	183	function IntToStr2(i: int64): string;
181	begin	184	begin
182	// https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html	185	// https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html
183	Result := Format('%.0n', [i / 1]);	186	Result := Format('%.0n', [i / 1]);
184	end;	187	end;
185		188
186	function ConvertBytes(Bytes: int64): string;	189	function ConvertBytes(Bytes: int64): string;
187	const	190	const
188	Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',	191	Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',
189	'PB', 'EB', 'ZB', 'YB');	192	'PB', 'EB', 'ZB', 'YB');
190	var	193	var
191	i: Integer;	194	i: Integer;
192	begin	195	begin
193	// https://stackoverflow.com/questions/30548940/correct-way-to-convert-size-in-bytes-to-kb-mb-gb-delphi	196	// https://stackoverflow.com/questions/30548940/correct-way-to-convert-size-in-bytes-to-kb-mb-gb-delphi
194	i := 0;	197	i := 0;
195		198
196	while Bytes > Power(1024, i + 1) do	199	while Bytes > Power(1024, i + 1) do
197	Inc(i);	200	Inc(i);
198		201
199	Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +	202	Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +
200	Description[i];	203	Description[i];
201	end;	204	end;
202		205
203	var	206	var
204	DriveGuidCache: TStringList = nil;	207	DriveGuidCache: TStringList = nil;
205		208
206	class function TfrmIndexCreator.DriveGuid(const Letter: char): string;	209	class function TfrmIndexCreator.DriveGuid(const Letter: char): string;
207	var	210	var
208	Buffer: array [0 .. 49] of char;	211	Buffer: array [0 .. 49] of char;
209	begin	212	begin
210	if not Assigned(DriveGuidCache) then	213	if not Assigned(DriveGuidCache) then
211	DriveGuidCache := TStringList.Create;	214	DriveGuidCache := TStringList.Create;
212		215
213	Result := DriveGuidCache.Values[Letter];	216	Result := DriveGuidCache.Values[Letter];
214	if Result = '' then	217	if Result = '' then
215	begin	218	begin
216	Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,	219	Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,
217	Length(Buffer)));	220	Length(Buffer)));
218	Result := Buffer;	221	Result := Buffer;
219	DriveGuidCache.Values[Letter] := Result;	222	DriveGuidCache.Values[Letter] := Result;
220	end;	223	end;
221	end;	224	end;
222		225
223	class function TfrmIndexCreator.uniqueFilename(const filename: string): string;	226	class function TfrmIndexCreator.uniqueFilename(const filename: string): string;
224	var	227	var
225	guid: string;	228	guid: string;
226	begin	229	begin
227	if Length(filename) < 2 then	230	if Length(filename) < 2 then
228	exit;	231	exit;
229	if filename[2] = ':' then	232	if filename[2] = ':' then
230	begin	233	begin
231	guid := DriveGuid(filename[1]);	234	guid := DriveGuid(filename[1]);
232		235
233	Result := guid + Copy(filename, 4, Length(filename) - 3);	236	Result := guid + Copy(filename, 4, Length(filename) - 3);
234		237
235	// result := LowerCase(result);	238	// result := LowerCase(result);
236	end	239	end
237	else	240	else
238	Result := filename; // z.B. UNC-Pfad	241	Result := filename; // z.B. UNC-Pfad
239	end;	242	end;
240		243
241	class function TfrmIndexCreator.VtsSpecial(const filename: string): string;	244	class function TfrmIndexCreator.VtsSpecial(const filename: string): string;
242	begin	245	begin
243	Result := filename;	246	Result := filename;
244	{$IFDEF VIATHINKSOFT}	247	{$IFDEF VIATHINKSOFT}
245	Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);	248	Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);
246	Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);	249	Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);
-		250	Result := StringReplace(Result, GUID_EHDD_R, 'EHDD:\', []);
247	{$ENDIF}	251	{$ENDIF}
248	end;	252	end;
249		253
250	function SpecialCompare(a, b: TDateTime): boolean; // true = same timestamp	254	function SpecialCompare(a, b: TDateTime): boolean; // true = same timestamp
251	begin	255	begin
252	if SecondsBetween(a,b) < 2 then exit(true); // equal	256	if SecondsBetween(a,b) < 2 then exit(true); // equal
253		257
254	if SecondsBetween(a,b) > 7200 then exit(false);	258	if SecondsBetween(a,b) > 7200 then exit(false);
255		259
256	// Minute and Second equal, and difference is < 2h: fair enough, seems to be a DST issue	260	// Minute and Second equal, and difference is < 2h: fair enough, seems to be a DST issue
257	if copy(TimeToStr(a),4,5) = copy(TimeToStr(b),4,5) then exit(true);	261	if copy(TimeToStr(a),4,5) = copy(TimeToStr(b),4,5) then exit(true);
258		262
259	result := false;	263	result := false;
260	end;	264	end;
261		265
262	procedure TfrmIndexCreator.CheckFile(const originalFileName,	266	procedure TfrmIndexCreator.CheckFile(const originalFileName,
263	uniqueFilename: string);	267	uniqueFilename: string);
264		268
265	function DateTimeToSQL(dt: TDateTime): string;	269	function DateTimeToSQL(dt: TDateTime): string;
266	begin	270	begin
267	if dt = -1 then	271	if dt = -1 then
268	Result := 'NULL'	272	Result := 'NULL'
269	else	273	else
270	Result := conn.SQLStringEscape(DateTimetoStr(dt));	274	Result := conn.SQLStringEscape(DateTimetoStr(dt));
271	end;	275	end;
272		276
273	type	277	type
274	TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);	278	TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);
275		279
276	var	280	var
277	lastCheckedMd5: string;	281	lastCheckedMd5: string;
278		282
279	function Exists(const filename: string; size: int64;	283	function Exists(const filename: string; size: int64;
280	const modified: TDateTime): TExistResult;	284	const modified: TDateTime): TExistResult;
281	var	285	var
282	q: TADODataSet;	286	q: TADODataSet;
283	begin	287	begin
284	q := conn.GetTable('select error, size, modified, md5hash from ' + TableName	288	q := conn.GetTable('select error, size, modified, md5hash from ' + TableName
285	+ ' where filename = ' + conn.SQLStringEscape	289	+ ' where filename = ' + conn.SQLStringEscape
286	(VtsSpecial(uniqueFilename)));	290	(VtsSpecial(uniqueFilename)));
287	try	291	try
288	if q.RecordCount = 0 then	292	if q.RecordCount = 0 then
289	Result := erDoesNotExist	293	Result := erDoesNotExist
290	else if not q.Fields[0].IsNull then	294	else if not q.Fields[0].IsNull then
291	Result := erHadError	295	Result := erHadError
292	else if (q.Fields[1].AsString <> IntToStr(size)) or // we are combining strings because of int64	296	else if (q.Fields[1].AsString <> IntToStr(size)) or // we are combining strings because of int64
293	not SpecialCompare(q.Fields[2].AsDateTime, modified) then	297	not SpecialCompare(q.Fields[2].AsDateTime, modified) then
294	begin	298	begin
295	Result := erChanged	299	Result := erChanged
296	end	300	end
297	else	301	else
298	Result := erUnchanged;	302	Result := erUnchanged;
299	lastCheckedMd5 := q.Fields[3].AsString;	303	lastCheckedMd5 := q.Fields[3].AsString;
300	finally	304	finally
301	FreeAndNil(q);	305	FreeAndNil(q);
302	end;	306	end;
303	end;	307	end;
304		308
305	var	309	var
306	created, modified: TDateTime;	310	created, modified: TDateTime;
307	size: int64;	311	size: int64;
308	md5: string;	312	md5: string;
309	begin	313	begin
310	Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);	314	Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);
311	Application.ProcessMessages;	315	Application.ProcessMessages;
312		316
313	try	317	try
314	if FileExists(uniqueFilename) then	318	if FileExists(uniqueFilename) then
315	created := FileCTime_UTC(uniqueFilename)	319	created := FileCTime_UTC(uniqueFilename)
316	else	320	else
317	created := -1;	321	created := -1;
318		322
319	if FileExists(uniqueFilename) then	323	if FileExists(uniqueFilename) then
320	modified := FileMTime_UTC(uniqueFilename)	324	modified := FileMTime_UTC(uniqueFilename)
321	else	325	else
322	modified := -1;	326	modified := -1;
323		327
324	size := GetFileSize(uniqueFilename);	328	size := GetFileSize(uniqueFilename);
325	Inc(sumsize, size);	329	Inc(sumsize, size);
326	Inc(sumfiles);	330	Inc(sumfiles);
327		331
328	if rgModus.ItemIndex = modusRecreate then	332	if rgModus.ItemIndex = modusRecreate then
329	begin	333	begin
330	md5 := MD5File(uniqueFilename);	334	md5 := MD5File(uniqueFilename);
331	if not cbSimulate.Checked then	335	if not cbSimulate.Checked then
332	begin	336	begin
333	conn.ExecSQL('INSERT INTO ' + TableName +	337	conn.ExecSQL('INSERT INTO ' + TableName +
334	' (filename, size, created, modified, md5hash, error) values (' +	338	' (filename, size, created, modified, md5hash, error) values (' +
335	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +	339	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
336	IntToStr(size) + ', ' + DateTimeToSQL(created) +	340	IntToStr(size) + ', ' + DateTimeToSQL(created) +
337	', ' + DateTimeToSQL(modified) + ', ' +	341	', ' + DateTimeToSQL(modified) + ', ' +
338	conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');	342	conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
339	end;	343	end;
340	if cbVerboseLogs.Checked then	344	if cbVerboseLogs.Checked then
341	Memo2.Lines.Add('New: ' + uniqueFilename);	345	Memo2.Lines.Add('New: ' + uniqueFilename);
342	Inc(sumfiles_new);	346	Inc(sumfiles_new);
343	end	347	end
344	else	348	else
345	begin	349	begin
346	case Exists(uniqueFilename, size, modified) of	350	case Exists(uniqueFilename, size, modified) of
347	erDoesNotExist: // File does not exist or has a different hash	351	erDoesNotExist: // File does not exist or has a different hash
348	begin	352	begin
349	if rgModus.ItemIndex <> modusValidation then	353	if rgModus.ItemIndex <> modusValidation then
350	md5 := MD5File(uniqueFilename);	354	md5 := MD5File(uniqueFilename);
351	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)	355	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
352	then	356	then
353	begin	357	begin
354	conn.ExecSQL('INSERT INTO ' + TableName +	358	conn.ExecSQL('INSERT INTO ' + TableName +
355	' (filename, size, created, modified, md5hash, error) values ('	359	' (filename, size, created, modified, md5hash, error) values ('
356	+ conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +	360	+ conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
357	IntToStr(size) + ', ' +	361	IntToStr(size) + ', ' +
358	DateTimeToSQL(created) + ', ' +	362	DateTimeToSQL(created) + ', ' +
359	DateTimeToSQL(modified) + ', ' +	363	DateTimeToSQL(modified) + ', ' +
360	conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');	364	conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
361	end;	365	end;
362	if cbVerboseLogs.Checked then	366	if cbVerboseLogs.Checked then
363	Memo2.Lines.Add('New: ' + uniqueFilename);	367	Memo2.Lines.Add('New: ' + uniqueFilename);
364	Inc(sumfiles_new);	368	Inc(sumfiles_new);
365	end;	369	end;
366	erHadError, erChanged:	370	erHadError, erChanged:
367	begin	371	begin
368	if rgModus.ItemIndex <> modusValidation then	372	if rgModus.ItemIndex <> modusValidation then
369	md5 := MD5File(uniqueFilename);	373	md5 := MD5File(uniqueFilename);
370	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)	374	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
371	then	375	then
372	begin	376	begin
373	conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +	377	conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
374	IntToStr(size) + ', created = ' +	378	IntToStr(size) + ', created = ' +
375	DateTimeToSQL(created) + ', modified = ' +	379	DateTimeToSQL(created) + ', modified = ' +
376	DateTimeToSQL(modified) + ', md5hash = ' +	380	DateTimeToSQL(modified) + ', md5hash = ' +
377	conn.SQLStringEscape(LowerCase(md5)) +	381	conn.SQLStringEscape(LowerCase(md5)) +
378	', error = NULL WHERE filename = ' + conn.SQLStringEscape	382	', error = NULL WHERE filename = ' + conn.SQLStringEscape
379	(VtsSpecial(uniqueFilename)) + ';');	383	(VtsSpecial(uniqueFilename)) + ';');
380	end;	384	end;
381	if cbVerboseLogs.Checked then	385	if cbVerboseLogs.Checked then
382	Memo2.Lines.Add('Updated: ' + uniqueFilename);	386	Memo2.Lines.Add('Updated: ' + uniqueFilename);
383	Inc(sumfiles_updated);	387	Inc(sumfiles_updated);
384	end;	388	end;
385	erUnchanged: // Date/Time+Size has not changed	389	erUnchanged: // Date/Time+Size has not changed
386	begin	390	begin
387	{$REGION 'Update it to correct wrong UTC/DST datasets...'}	391	{$REGION 'Update it to correct wrong UTC/DST datasets...'}
388	conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +	392	conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
389	IntToStr(size) + ', created = ' +	393	IntToStr(size) + ', created = ' +
390	DateTimeToSQL(created) + ', modified = ' +	394	DateTimeToSQL(created) + ', modified = ' +
391	DateTimeToSQL(modified) +	395	DateTimeToSQL(modified) +
392	', error = NULL WHERE filename = ' + conn.SQLStringEscape	396	', error = NULL WHERE filename = ' + conn.SQLStringEscape
393	(VtsSpecial(uniqueFilename)) + ';');	397	(VtsSpecial(uniqueFilename)) + ';');
394	{$ENDREGION}	398	{$ENDREGION}
395		399
396	if rgModus.ItemIndex = modusValidation then	400	if rgModus.ItemIndex = modusValidation then
397	begin	401	begin
398	md5 := MD5File(uniqueFilename);	402	md5 := MD5File(uniqueFilename);
399	if not SameText(md5, lastCheckedMd5) then	403	if not SameText(md5, lastCheckedMd5) then
400	begin	404	begin
401	Memo2.Lines.Add	405	Memo2.Lines.Add
402	('!!! HASH HAS CHANGED WHILE DATETIME+SIZE IS THE SAME: ' +	406	('!!! HASH HAS CHANGED WHILE DATETIME+SIZE IS THE SAME: ' +
403	uniqueFilename + ' (' + lastCheckedMd5 + ' became ' +	407	uniqueFilename + ' (' + lastCheckedMd5 + ' became ' +
404	md5 + ')');	408	md5 + ')');
405	Memo2.Color := clRed;	409	Memo2.Color := clRed;
406	Inc(sumfiles_integrityfail);	410	Inc(sumfiles_integrityfail);
407	end;	411	end;
408	end;	412	end;
409	end;	413	end;
410	end;	414	end;
411	end;	415	end;
412	except	416	except
413	on E: Exception do	417	on E: Exception do
414	begin	418	begin
415	if E is EAbort then	419	if E is EAbort then
416	Abort;	420	Abort;
417	// if AdoConnection1.InTransaction then AdoConnection1.RollbackTrans;	421	// if AdoConnection1.InTransaction then AdoConnection1.RollbackTrans;
418	// AdoConnection1.BeginTrans;	422	// AdoConnection1.BeginTrans;
419	try	423	try
420	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)	424	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
421	then	425	then
422	begin	426	begin
423	conn.ExecSQL('DELETE FROM ' + TableName + ' WHERE filename = ' +	427	conn.ExecSQL('DELETE FROM ' + TableName + ' WHERE filename = ' +
424	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ';');	428	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ';');
425	conn.ExecSQL('INSERT INTO ' + TableName +	429	conn.ExecSQL('INSERT INTO ' + TableName +
426	' (filename, size, created, modified, md5hash, error) values (' +	430	' (filename, size, created, modified, md5hash, error) values (' +
427	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) +	431	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) +
428	', NULL, NULL, NULL, NULL, ' + conn.SQLStringEscape(Copy(E.Message,	432	', NULL, NULL, NULL, NULL, ' + conn.SQLStringEscape(Copy(E.Message,
429	1, ERROR_FIELD_SIZE)) + ');');	433	1, ERROR_FIELD_SIZE)) + ');');
430	Memo2.Lines.Add('Error (logged): ' + E.Message + ' at file ' +	434	Memo2.Lines.Add('Error (logged): ' + E.Message + ' at file ' +
431	VtsSpecial(uniqueFilename));	435	VtsSpecial(uniqueFilename));
432	end	436	end
433	else	437	else
434	begin	438	begin
435	Memo2.Lines.Add('Error: ' + E.Message + ' at file ' +	439	Memo2.Lines.Add('Error: ' + E.Message + ' at file ' +
436	VtsSpecial(uniqueFilename));	440	VtsSpecial(uniqueFilename));
437	end;	441	end;
438	// AdoConnection1.CommitTrans;	442	// AdoConnection1.CommitTrans;
439	except	443	except
440	// AdoConnection1.RollbackTrans;	444	// AdoConnection1.RollbackTrans;
441	Memo2.Lines.Add('Cannot write error into file database! ' + E.Message +	445	Memo2.Lines.Add('Cannot write error into file database! ' + E.Message +
442	' at file ' + VtsSpecial(uniqueFilename));	446	' at file ' + VtsSpecial(uniqueFilename));
443	end;	447	end;
444	Inc(sumfiles_error);	448	Inc(sumfiles_error);
445	end;	449	end;
446	end;	450	end;
447		451
448	RedrawStats;	452	RedrawStats;
449	Application.ProcessMessages;	453	Application.ProcessMessages;
450	end;	454	end;
451		455
452	function TfrmIndexCreator.conn: TAdoConnection;	456	function TfrmIndexCreator.conn: TAdoConnection;
453	begin	457	begin
454	Result := frmMain.AdoConnection1;	458	Result := frmMain.AdoConnection1;
455	end;	459	end;
456		460
457	procedure TfrmIndexCreator.RedrawStats;	461	procedure TfrmIndexCreator.RedrawStats;
458	begin	462	begin
459	Label5.Caption := ConvertBytes(sumsize);	463	Label5.Caption := ConvertBytes(sumsize);
460	Label6.Caption := IntToStr2(sumfiles);	464	Label6.Caption := IntToStr2(sumfiles);
461	Label7.Caption := IntToStr2(sumfiles_new);	465	Label7.Caption := IntToStr2(sumfiles_new);
462	Label9.Caption := IntToStr2(sumfiles_updated);	466	Label9.Caption := IntToStr2(sumfiles_updated);
463	Label11.Caption := IntToStr2(sumfiles_error);	467	Label11.Caption := IntToStr2(sumfiles_error);
464	Label12.Caption := IntToStr2(sumfiles_deleted);	468	Label12.Caption := IntToStr2(sumfiles_deleted);
465	// LabelXX.Caption := IntToStr2(sumfiles_integrityfail);	469	// LabelXX.Caption := IntToStr2(sumfiles_integrityfail);
466	end;	470	end;
467		471
468	procedure TfrmIndexCreator.Copyuniquepathtoclipboard1Click(Sender: TObject);	472	procedure TfrmIndexCreator.Copyuniquepathtoclipboard1Click(Sender: TObject);
469	var	473	var
470	s: string;	474	s: string;
471	begin	475	begin
472	s := uniqueFilename(LabeledEdit2.Text);	476	s := uniqueFilename(LabeledEdit2.Text);
473	Clipboard.AsText := s;	477	Clipboard.AsText := s;
474	{$IFDEF VIATHINKSOFT}	478	{$IFDEF VIATHINKSOFT}
475	if VtsSpecial(s) <> s then	479	if VtsSpecial(s) <> s then
476	begin	480	begin
477	s := s + #13#10 + VtsSpecial(s);	481	s := s + #13#10 + VtsSpecial(s);
478	end;	482	end;
479	{$ENDIF}	483	{$ENDIF}
480	ShowMessageFmt('Copied to clipboard:' + #13#10#13#10 + '%s', [s]);	484	ShowMessageFmt('Copied to clipboard:' + #13#10#13#10 + '%s', [s]);
481	end;	485	end;
482		486
483	procedure TfrmIndexCreator.rgModusClick(Sender: TObject);	487	procedure TfrmIndexCreator.rgModusClick(Sender: TObject);
484	begin	488	begin
485	cbSimulate.enabled := rgModus.ItemIndex <> modusValidation;	489	cbSimulate.enabled := rgModus.ItemIndex <> modusValidation;
486	cbNoDelete.enabled := rgModus.ItemIndex <> modusValidation;	490	cbNoDelete.enabled := rgModus.ItemIndex <> modusValidation;
487	end;	491	end;
488		492
489	function TfrmIndexCreator.TableName: string;	493	function TfrmIndexCreator.TableName: string;
490	begin	494	begin
491	Result := frmMain.TableName;	495	Result := frmMain.TableName;
492	end;	496	end;
493		497
494	procedure TfrmIndexCreator.Rec(StartDir: string; const FileMask: string);	498	procedure TfrmIndexCreator.Rec(StartDir: string; const FileMask: string);
495	var	499	var
496	SR: TSearchRec;	500	SR: TSearchRec;

Subversion Repositories indexer_suite

indexer_suite/trunk/IndexCreatorForm.pas – Rev 6 → 8