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

Subversion Repositories indexer_suite

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