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 and cacheRconnected
 
      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 cacheRconnected 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 8	Rev 9
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	114	// Example of multiple drives merging to one Index
115	// Find out via "mountvol" command	115	// Find out via "mountvol" command
116	GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';	116	GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';
117	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}\';	118	GUID_EHDD_R = '\\?\Volume{9d53ea3c-175c-4a8f-a7b4-7b9e6b765e58}\';
119	{$ENDIF}	119	{$ENDIF}
120		120
121	function MD5File(const filename: string): string;	121	function MD5File(const filename: string): string;
122	var	122	var
123	IdMD5: TIdHashMessageDigest5;	123	IdMD5: TIdHashMessageDigest5;
124	FS: TFileStream;	124	FS: TFileStream;
125	begin	125	begin
126	IdMD5 := TIdHashMessageDigest5.Create;	126	IdMD5 := TIdHashMessageDigest5.Create;
127	FS := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);	127	FS := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
128	try	128	try
129	{$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.
130	Result := IdMD5.HashStreamAsHex(FS);	130	Result := IdMD5.HashStreamAsHex(FS);
131	{$ELSE}	131	{$ELSE}
132	Result := IdMD5.AsHex(IdMD5.HashValue(FS));	132	Result := IdMD5.AsHex(IdMD5.HashValue(FS));
133	{$ENDIF}	133	{$ENDIF}
134	finally	134	finally
135	FS.Free;	135	FS.Free;
136	IdMD5.Free;	136	IdMD5.Free;
137	end;	137	end;
138	end;	138	end;
139		139
140	function FileMTime_UTC(const filename: string): TDateTime;	140	function FileMTime_UTC(const filename: string): TDateTime;
141	var	141	var
142	fad: TWin32FileAttributeData;	142	fad: TWin32FileAttributeData;
143	systime: SYSTEMTIME;	143	systime: SYSTEMTIME;
144	begin	144	begin
145	if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then	145	if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
146	RaiseLastOSError;	146	RaiseLastOSError;
147		147
148	FileTimeToSystemTime(fad.ftLastWriteTime, systime);	148	FileTimeToSystemTime(fad.ftLastWriteTime, systime);
149		149
150	Result := SystemTimeToDateTime(systime);	150	Result := SystemTimeToDateTime(systime);
151	end;	151	end;
152		152
153	function FileCTime_UTC(const filename: string): TDateTime;	153	function FileCTime_UTC(const filename: string): TDateTime;
154	var	154	var
155	fad: TWin32FileAttributeData;	155	fad: TWin32FileAttributeData;
156	systime: SYSTEMTIME;	156	systime: SYSTEMTIME;
157	begin	157	begin
158	if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then	158	if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
159	RaiseLastOSError;	159	RaiseLastOSError;
160		160
161	FileTimeToSystemTime(fad.ftCreationTime, systime);	161	FileTimeToSystemTime(fad.ftCreationTime, systime);
162		162
163	Result := SystemTimeToDateTime(systime);	163	Result := SystemTimeToDateTime(systime);
164	end;	164	end;
165		165
166	function GetFileSize(const AFileName: String): int64;	166	function GetFileSize(const AFileName: String): int64;
167	var	167	var
168	lFindData: TWin32FindData;	168	lFindData: TWin32FindData;
169	lHandle: Cardinal;	169	lHandle: Cardinal;
170	begin	170	begin
171	// https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html	171	// https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html
172	lHandle := FindFirstFile(PChar(AFileName), lFindData);	172	lHandle := FindFirstFile(PChar(AFileName), lFindData);
173	if (lHandle <> INVALID_HANDLE_VALUE) then	173	if (lHandle <> INVALID_HANDLE_VALUE) then
174	begin	174	begin
175	Result := lFindData.nFileSizeLow;	175	Result := lFindData.nFileSizeLow;
176	PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;	176	PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;
177	Windows.FindClose(lHandle);	177	Windows.FindClose(lHandle);
178	end	178	end
179	else	179	else
180	Result := 0;	180	Result := 0;
181	end;	181	end;
182		182
183	function IntToStr2(i: int64): string;	183	function IntToStr2(i: int64): string;
184	begin	184	begin
185	// https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html	185	// https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html
186	Result := Format('%.0n', [i / 1]);	186	Result := Format('%.0n', [i / 1]);
187	end;	187	end;
188		188
189	function ConvertBytes(Bytes: int64): string;	189	function ConvertBytes(Bytes: int64): string;
190	const	190	const
191	Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',	191	Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',
192	'PB', 'EB', 'ZB', 'YB');	192	'PB', 'EB', 'ZB', 'YB');
193	var	193	var
194	i: Integer;	194	i: Integer;
195	begin	195	begin
196	// 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
197	i := 0;	197	i := 0;
198		198
199	while Bytes > Power(1024, i + 1) do	199	while Bytes > Power(1024, i + 1) do
200	Inc(i);	200	Inc(i);
201		201
202	Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +	202	Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +
203	Description[i];	203	Description[i];
204	end;	204	end;
205		205
206	var	206	var
207	DriveGuidCache: TStringList = nil;	207	DriveGuidCache: TStringList = nil;
208		208
209	class function TfrmIndexCreator.DriveGuid(const Letter: char): string;	209	class function TfrmIndexCreator.DriveGuid(const Letter: char): string;
210	var	210	var
211	Buffer: array [0 .. 49] of char;	211	Buffer: array [0 .. 49] of char;
212	begin	212	begin
213	if not Assigned(DriveGuidCache) then	213	if not Assigned(DriveGuidCache) then
214	DriveGuidCache := TStringList.Create;	214	DriveGuidCache := TStringList.Create;
215		215
216	Result := DriveGuidCache.Values[Letter];	216	Result := DriveGuidCache.Values[Letter];
217	if Result = '' then	217	if Result = '' then
218	begin	218	begin
219	Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,	219	Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,
220	Length(Buffer)));	220	Length(Buffer)));
221	Result := Buffer;	221	Result := Buffer;
222	DriveGuidCache.Values[Letter] := Result;	222	DriveGuidCache.Values[Letter] := Result;
223	end;	223	end;
224	end;	224	end;
225		225
226	class function TfrmIndexCreator.uniqueFilename(const filename: string): string;	226	class function TfrmIndexCreator.uniqueFilename(const filename: string): string;
227	var	227	var
228	guid: string;	228	guid: string;
229	begin	229	begin
230	if Length(filename) < 2 then	230	if Length(filename) < 2 then
231	exit;	231	exit;
232	if filename[2] = ':' then	232	if filename[2] = ':' then
233	begin	233	begin
234	guid := DriveGuid(filename[1]);	234	guid := DriveGuid(filename[1]);
235		235
236	Result := guid + Copy(filename, 4, Length(filename) - 3);	236	Result := guid + Copy(filename, 4, Length(filename) - 3);
237		237
238	// result := LowerCase(result);	238	// result := LowerCase(result);
239	end	239	end
240	else	240	else
241	Result := filename; // z.B. UNC-Pfad	241	Result := filename; // z.B. UNC-Pfad
242	end;	242	end;
243		243
244	class function TfrmIndexCreator.VtsSpecial(const filename: string): string;	244	class function TfrmIndexCreator.VtsSpecial(const filename: string): string;
245	begin	245	begin
246	Result := filename;	246	Result := filename;
247	{$IFDEF VIATHINKSOFT}	247	{$IFDEF VIATHINKSOFT}
248	Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);	248	Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);
249	Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);	249	Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);
250	Result := StringReplace(Result, GUID_EHDD_R, 'EHDD:\', []);	250	Result := StringReplace(Result, GUID_EHDD_R, 'EHDD:\', []);
251	{$ENDIF}	251	{$ENDIF}
252	end;	252	end;
253		253
254	function SpecialCompare(a, b: TDateTime): boolean; // true = same timestamp	254	function SpecialCompare(a, b: TDateTime): boolean; // true = same timestamp
255	begin	255	begin
256	if SecondsBetween(a,b) < 2 then exit(true); // equal	256	if SecondsBetween(a,b) < 2 then exit(true); // equal
257		257
258	if SecondsBetween(a,b) > 7200 then exit(false);	258	if SecondsBetween(a,b) > 7200 then exit(false);
259		259
260	// 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
261	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);
262		262
263	result := false;	263	result := false;
264	end;	264	end;
265		265
266	procedure TfrmIndexCreator.CheckFile(const originalFileName,	266	procedure TfrmIndexCreator.CheckFile(const originalFileName,
267	uniqueFilename: string);	267	uniqueFilename: string);
268		268
269	function DateTimeToSQL(dt: TDateTime): string;	269	function DateTimeToSQL(dt: TDateTime): string;
270	begin	270	begin
271	if dt = -1 then	271	if dt = -1 then
272	Result := 'NULL'	272	Result := 'NULL'
273	else	273	else
274	Result := conn.SQLStringEscape(DateTimetoStr(dt));	274	Result := conn.SQLStringEscape(DateTimetoStr(dt));
275	end;	275	end;
276		276
277	type	277	type
278	TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);	278	TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);
279		279
280	var	280	var
281	lastCheckedMd5: string;	281	lastCheckedMd5: string;
282		282
283	function Exists(const filename: string; size: int64;	283	function Exists(const filename: string; size: int64;
284	const modified: TDateTime): TExistResult;	284	const modified: TDateTime): TExistResult;
285	var	285	var
286	q: TADODataSet;	286	q: TADODataSet;
287	begin	287	begin
288	q := conn.GetTable('select error, size, modified, md5hash from ' + TableName	288	q := conn.GetTable('select error, size, modified, md5hash from ' + TableName
289	+ ' where filename = ' + conn.SQLStringEscape	289	+ ' where filename = ' + conn.SQLStringEscape
290	(VtsSpecial(uniqueFilename)));	290	(VtsSpecial(uniqueFilename)));
291	try	291	try
292	if q.RecordCount = 0 then	292	if q.RecordCount = 0 then
293	Result := erDoesNotExist	293	Result := erDoesNotExist
294	else if not q.Fields[0].IsNull then	294	else if not q.Fields[0].IsNull then
295	Result := erHadError	295	Result := erHadError
296	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
297	not SpecialCompare(q.Fields[2].AsDateTime, modified) then	297	not SpecialCompare(q.Fields[2].AsDateTime, modified) then
298	begin	298	begin
299	Result := erChanged	299	Result := erChanged
300	end	300	end
301	else	301	else
302	Result := erUnchanged;	302	Result := erUnchanged;
303	lastCheckedMd5 := q.Fields[3].AsString;	303	lastCheckedMd5 := q.Fields[3].AsString;
304	finally	304	finally
305	FreeAndNil(q);	305	FreeAndNil(q);
306	end;	306	end;
307	end;	307	end;
308		308
309	var	309	var
310	created, modified: TDateTime;	310	created, modified: TDateTime;
311	size: int64;	311	size: int64;
312	md5: string;	312	md5: string;
313	begin	313	begin
314	Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);	314	Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);
315	Application.ProcessMessages;	315	Application.ProcessMessages;
316		316
317	try	317	try
318	if FileExists(uniqueFilename) then	318	if FileExists(uniqueFilename) then
319	created := FileCTime_UTC(uniqueFilename)	319	created := FileCTime_UTC(uniqueFilename)
320	else	320	else
321	created := -1;	321	created := -1;
322		322
323	if FileExists(uniqueFilename) then	323	if FileExists(uniqueFilename) then
324	modified := FileMTime_UTC(uniqueFilename)	324	modified := FileMTime_UTC(uniqueFilename)
325	else	325	else
326	modified := -1;	326	modified := -1;
327		327
328	size := GetFileSize(uniqueFilename);	328	size := GetFileSize(uniqueFilename);
329	Inc(sumsize, size);	329	Inc(sumsize, size);
330	Inc(sumfiles);	330	Inc(sumfiles);
331		331
332	if rgModus.ItemIndex = modusRecreate then	332	if rgModus.ItemIndex = modusRecreate then
333	begin	333	begin
334	md5 := MD5File(uniqueFilename);	334	md5 := MD5File(uniqueFilename);
335	if not cbSimulate.Checked then	335	if not cbSimulate.Checked then
336	begin	336	begin
337	conn.ExecSQL('INSERT INTO ' + TableName +	337	conn.ExecSQL('INSERT INTO ' + TableName +
338	' (filename, size, created, modified, md5hash, error) values (' +	338	' (filename, size, created, modified, md5hash, error) values (' +
339	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +	339	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
340	IntToStr(size) + ', ' + DateTimeToSQL(created) +	340	IntToStr(size) + ', ' + DateTimeToSQL(created) +
341	', ' + DateTimeToSQL(modified) + ', ' +	341	', ' + DateTimeToSQL(modified) + ', ' +
342	conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');	342	conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
343	end;	343	end;
344	if cbVerboseLogs.Checked then	344	if cbVerboseLogs.Checked then
345	Memo2.Lines.Add('New: ' + uniqueFilename);	345	Memo2.Lines.Add('New: ' + uniqueFilename);
346	Inc(sumfiles_new);	346	Inc(sumfiles_new);
347	end	347	end
348	else	348	else
349	begin	349	begin
350	case Exists(uniqueFilename, size, modified) of	350	case Exists(uniqueFilename, size, modified) of
351	erDoesNotExist: // File does not exist or has a different hash	351	erDoesNotExist: // File does not exist or has a different hash
352	begin	352	begin
353	if rgModus.ItemIndex <> modusValidation then	353	if rgModus.ItemIndex <> modusValidation then
354	md5 := MD5File(uniqueFilename);	354	md5 := MD5File(uniqueFilename);
355	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)	355	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
356	then	356	then
357	begin	357	begin
358	conn.ExecSQL('INSERT INTO ' + TableName +	358	conn.ExecSQL('INSERT INTO ' + TableName +
359	' (filename, size, created, modified, md5hash, error) values ('	359	' (filename, size, created, modified, md5hash, error) values ('
360	+ conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +	360	+ conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
361	IntToStr(size) + ', ' +	361	IntToStr(size) + ', ' +
362	DateTimeToSQL(created) + ', ' +	362	DateTimeToSQL(created) + ', ' +
363	DateTimeToSQL(modified) + ', ' +	363	DateTimeToSQL(modified) + ', ' +
364	conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');	364	conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
365	end;	365	end;
366	if cbVerboseLogs.Checked then	366	if cbVerboseLogs.Checked then
367	Memo2.Lines.Add('New: ' + uniqueFilename);	367	Memo2.Lines.Add('New: ' + uniqueFilename);
368	Inc(sumfiles_new);	368	Inc(sumfiles_new);
369	end;	369	end;
370	erHadError, erChanged:	370	erHadError, erChanged:
371	begin	371	begin
372	if rgModus.ItemIndex <> modusValidation then	372	if rgModus.ItemIndex <> modusValidation then
373	md5 := MD5File(uniqueFilename);	373	md5 := MD5File(uniqueFilename);
374	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)	374	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
375	then	375	then
376	begin	376	begin
377	conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +	377	conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
378	IntToStr(size) + ', created = ' +	378	IntToStr(size) + ', created = ' +
379	DateTimeToSQL(created) + ', modified = ' +	379	DateTimeToSQL(created) + ', modified = ' +
380	DateTimeToSQL(modified) + ', md5hash = ' +	380	DateTimeToSQL(modified) + ', md5hash = ' +
381	conn.SQLStringEscape(LowerCase(md5)) +	381	conn.SQLStringEscape(LowerCase(md5)) +
382	', error = NULL WHERE filename = ' + conn.SQLStringEscape	382	', error = NULL WHERE filename = ' + conn.SQLStringEscape
383	(VtsSpecial(uniqueFilename)) + ';');	383	(VtsSpecial(uniqueFilename)) + ';');
384	end;	384	end;
385	if cbVerboseLogs.Checked then	385	if cbVerboseLogs.Checked then
386	Memo2.Lines.Add('Updated: ' + uniqueFilename);	386	Memo2.Lines.Add('Updated: ' + uniqueFilename);
387	Inc(sumfiles_updated);	387	Inc(sumfiles_updated);
388	end;	388	end;
389	erUnchanged: // Date/Time+Size has not changed	389	erUnchanged: // Date/Time+Size has not changed
390	begin	390	begin
391	{$REGION 'Update it to correct wrong UTC/DST datasets...'}	391	{$REGION 'Update it to correct wrong UTC/DST datasets...'}
392	conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +	392	conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
393	IntToStr(size) + ', created = ' +	393	IntToStr(size) + ', created = ' +
394	DateTimeToSQL(created) + ', modified = ' +	394	DateTimeToSQL(created) + ', modified = ' +
395	DateTimeToSQL(modified) +	395	DateTimeToSQL(modified) +
396	', error = NULL WHERE filename = ' + conn.SQLStringEscape	396	', error = NULL WHERE filename = ' + conn.SQLStringEscape
397	(VtsSpecial(uniqueFilename)) + ';');	397	(VtsSpecial(uniqueFilename)) + ';');
398	{$ENDREGION}	398	{$ENDREGION}
399		399
400	if rgModus.ItemIndex = modusValidation then	400	if rgModus.ItemIndex = modusValidation then
401	begin	401	begin
402	md5 := MD5File(uniqueFilename);	402	md5 := MD5File(uniqueFilename);
403	if not SameText(md5, lastCheckedMd5) then	403	if not SameText(md5, lastCheckedMd5) then
404	begin	404	begin
405	Memo2.Lines.Add	405	Memo2.Lines.Add
406	('!!! HASH HAS CHANGED WHILE DATETIME+SIZE IS THE SAME: ' +	406	('!!! HASH HAS CHANGED WHILE DATETIME+SIZE IS THE SAME: ' +
407	uniqueFilename + ' (' + lastCheckedMd5 + ' became ' +	407	uniqueFilename + ' (' + lastCheckedMd5 + ' became ' +
408	md5 + ')');	408	md5 + ')');
409	Memo2.Color := clRed;	409	Memo2.Color := clRed;
410	Inc(sumfiles_integrityfail);	410	Inc(sumfiles_integrityfail);
411	end;	411	end;
412	end;	412	end;
413	end;	413	end;
414	end;	414	end;
415	end;	415	end;
416	except	416	except
417	on E: Exception do	417	on E: Exception do
418	begin	418	begin
419	if E is EAbort then	419	if E is EAbort then
420	Abort;	420	Abort;
421	// if AdoConnection1.InTransaction then AdoConnection1.RollbackTrans;	421	// if AdoConnection1.InTransaction then AdoConnection1.RollbackTrans;
422	// AdoConnection1.BeginTrans;	422	// AdoConnection1.BeginTrans;
423	try	423	try
424	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)	424	if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
425	then	425	then
426	begin	426	begin
427	conn.ExecSQL('DELETE FROM ' + TableName + ' WHERE filename = ' +	427	conn.ExecSQL('DELETE FROM ' + TableName + ' WHERE filename = ' +
428	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ';');	428	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ';');
429	conn.ExecSQL('INSERT INTO ' + TableName +	429	conn.ExecSQL('INSERT INTO ' + TableName +
430	' (filename, size, created, modified, md5hash, error) values (' +	430	' (filename, size, created, modified, md5hash, error) values (' +
431	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) +	431	conn.SQLStringEscape(VtsSpecial(uniqueFilename)) +
432	', NULL, NULL, NULL, NULL, ' + conn.SQLStringEscape(Copy(E.Message,	432	', NULL, NULL, NULL, NULL, ' + conn.SQLStringEscape(Copy(E.Message,
433	1, ERROR_FIELD_SIZE)) + ');');	433	1, ERROR_FIELD_SIZE)) + ');');
434	Memo2.Lines.Add('Error (logged): ' + E.Message + ' at file ' +	434	Memo2.Lines.Add('Error (logged): ' + E.Message + ' at file ' +
435	VtsSpecial(uniqueFilename));	435	VtsSpecial(uniqueFilename));
436	end	436	end
437	else	437	else
438	begin	438	begin
439	Memo2.Lines.Add('Error: ' + E.Message + ' at file ' +	439	Memo2.Lines.Add('Error: ' + E.Message + ' at file ' +
440	VtsSpecial(uniqueFilename));	440	VtsSpecial(uniqueFilename));
441	end;	441	end;
442	// AdoConnection1.CommitTrans;	442	// AdoConnection1.CommitTrans;
443	except	443	except
444	// AdoConnection1.RollbackTrans;	444	// AdoConnection1.RollbackTrans;
445	Memo2.Lines.Add('Cannot write error into file database! ' + E.Message +	445	Memo2.Lines.Add('Cannot write error into file database! ' + E.Message +
446	' at file ' + VtsSpecial(uniqueFilename));	446	' at file ' + VtsSpecial(uniqueFilename));
447	end;	447	end;
448	Inc(sumfiles_error);	448	Inc(sumfiles_error);
449	end;	449	end;
450	end;	450	end;
451		451
452	RedrawStats;	452	RedrawStats;
453	Application.ProcessMessages;	453	Application.ProcessMessages;
454	end;	454	end;
455		455
456	function TfrmIndexCreator.conn: TAdoConnection;	456	function TfrmIndexCreator.conn: TAdoConnection;
457	begin	457	begin
458	Result := frmMain.AdoConnection1;	458	Result := frmMain.AdoConnection1;
459	end;	459	end;
460		460
461	procedure TfrmIndexCreator.RedrawStats;	461	procedure TfrmIndexCreator.RedrawStats;
462	begin	462	begin
463	Label5.Caption := ConvertBytes(sumsize);	463	Label5.Caption := ConvertBytes(sumsize);
464	Label6.Caption := IntToStr2(sumfiles);	464	Label6.Caption := IntToStr2(sumfiles);
465	Label7.Caption := IntToStr2(sumfiles_new);	465	Label7.Caption := IntToStr2(sumfiles_new);
466	Label9.Caption := IntToStr2(sumfiles_updated);	466	Label9.Caption := IntToStr2(sumfiles_updated);
467	Label11.Caption := IntToStr2(sumfiles_error);	467	Label11.Caption := IntToStr2(sumfiles_error);
468	Label12.Caption := IntToStr2(sumfiles_deleted);	468	Label12.Caption := IntToStr2(sumfiles_deleted);
469	// LabelXX.Caption := IntToStr2(sumfiles_integrityfail);	469	// LabelXX.Caption := IntToStr2(sumfiles_integrityfail);
470	end;	470	end;
471		471
472	procedure TfrmIndexCreator.Copyuniquepathtoclipboard1Click(Sender: TObject);	472	procedure TfrmIndexCreator.Copyuniquepathtoclipboard1Click(Sender: TObject);
473	var	473	var
474	s: string;	474	s: string;
475	begin	475	begin
476	s := uniqueFilename(LabeledEdit2.Text);	476	s := uniqueFilename(LabeledEdit2.Text);
477	Clipboard.AsText := s;	477	Clipboard.AsText := s;
478	{$IFDEF VIATHINKSOFT}	478	{$IFDEF VIATHINKSOFT}
479	if VtsSpecial(s) <> s then	479	if VtsSpecial(s) <> s then
480	begin	480	begin
481	s := s + #13#10 + VtsSpecial(s);	481	s := s + #13#10 + VtsSpecial(s);
482	end;	482	end;
483	{$ENDIF}	483	{$ENDIF}
484	ShowMessageFmt('Copied to clipboard:' + #13#10#13#10 + '%s', [s]);	484	ShowMessageFmt('Copied to clipboard:' + #13#10#13#10 + '%s', [s]);
485	end;	485	end;
486		486
487	procedure TfrmIndexCreator.rgModusClick(Sender: TObject);	487	procedure TfrmIndexCreator.rgModusClick(Sender: TObject);
488	begin	488	begin
489	cbSimulate.enabled := rgModus.ItemIndex <> modusValidation;	489	cbSimulate.enabled := rgModus.ItemIndex <> modusValidation;
490	cbNoDelete.enabled := rgModus.ItemIndex <> modusValidation;	490	cbNoDelete.enabled := rgModus.ItemIndex <> modusValidation;
491	end;	491	end;
492		492
493	function TfrmIndexCreator.TableName: string;	493	function TfrmIndexCreator.TableName: string;
494	begin	494	begin
495	Result := frmMain.TableName;	495	Result := frmMain.TableName;
496	end;	496	end;
497		497
498	procedure TfrmIndexCreator.Rec(StartDir: string; const FileMask: string);	498	procedure TfrmIndexCreator.Rec(StartDir: string; const FileMask: string);
499	var	499	var
500	SR: TSearchRec;	500	SR: TSearchRec;

Subversion Repositories indexer_suite

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