Subversion Repositories indexer_suite

Rev

Rev 8 | Blame | Compare with Previous | Last modification | View Log | RSS feed

  1. unit IndexCreatorForm;
  2.  
  3. // TODO: vor einem fehler bitte vorher einen löschvorgang durchführen --> geht nicht?
  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?!
  6. // TODO: Möglichkeit geben, Dateien und Verzeichnisse auszuschließen
  7. // TODO: should we include flags (readonly, invisible, compressed, encrypted)?
  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 '%\\?\%';
  10. // TODO: anzeige, wie viele stunden der prozess schon läuft
  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
  13. // TODO: Beim Lauf F:\nas\data wurden 1312 Fehler gefunden, aber nicht geloggt! ?! Eine exception im exception handler?!
  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)
  16. // TODO: validate modus auch ohne prüfsummencheck. nur gucken ob die dateien existieren
  17.  
  18. {$DEFINE VIATHINKSOFT}
  19.  
  20. interface
  21.  
  22. uses
  23.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  24.   Dialogs, StdCtrls, ComCtrls, ExtCtrls, DB, ADODB, Menus;
  25.  
  26. const
  27.   modusUpdate = 0;
  28.   modusRecreate = 1;
  29.   modusValidation = 2;
  30.  
  31. type
  32.   TfrmIndexCreator = class(TForm)
  33.     Button1: TButton;
  34.     Label1: TLabel;
  35.     LabeledEdit2: TLabeledEdit;
  36.     Button2: TButton;
  37.     Label2: TLabel;
  38.     Label3: TLabel;
  39.     Label4: TLabel;
  40.     Label5: TLabel;
  41.     Label6: TLabel;
  42.     Label7: TLabel;
  43.     PopupMenu1: TPopupMenu;
  44.     Copyuniquepathtoclipboard1: TMenuItem;
  45.     Label8: TLabel;
  46.     Label9: TLabel;
  47.     Label10: TLabel;
  48.     Label11: TLabel;
  49.     Label12: TLabel;
  50.     Label13: TLabel;
  51.     Memo1: TMemo;
  52.     Button4: TButton;
  53.     Label14: TLabel;
  54.     cbNoDelete: TCheckBox;
  55.     Memo2: TMemo;
  56.     cbVerboseLogs: TCheckBox;
  57.     cbSimulate: TCheckBox;
  58.     rgModus: TRadioGroup;
  59.     procedure Button1Click(Sender: TObject);
  60.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  61.     procedure Button2Click(Sender: TObject);
  62.     procedure FormShow(Sender: TObject);
  63.     procedure Copyuniquepathtoclipboard1Click(Sender: TObject);
  64.     procedure Button4Click(Sender: TObject);
  65.     procedure rgModusClick(Sender: TObject);
  66.   private
  67.     StopRequest: boolean;
  68.     sumsize: int64;
  69.     sumfiles: int64;
  70.     sumfiles_new: int64;
  71.     sumfiles_updated: int64;
  72.     sumfiles_error: int64;
  73.     sumfiles_deleted: int64;
  74.     sumfiles_integrityfail: int64;
  75.     function TableName: string;
  76.     function conn: TAdoConnection;
  77.     procedure Rec(StartDir: string; const FileMask: string);
  78.     procedure CheckFile(const originalFileName, uniqueFilename: string);
  79.     procedure EnableDisableControls(enabled: boolean);
  80.     procedure IndexDrive(initialdir: string);
  81.     procedure RedrawStats;
  82.     procedure DeleteVanishedFiles(mask: string = '');
  83.     class function DriveGuid(const Letter: char): string; static;
  84.     class function uniqueFilename(const filename: string): string; static;
  85.     class function VtsSpecial(const filename: string): string; static;
  86.     procedure DeleteAllFiles(mask: string = '');
  87.   end;
  88.  
  89. implementation
  90.  
  91. {$R *.dfm}
  92.  
  93. uses
  94.   FileCtrl, DateUtils, inifiles, IdHashMessageDigest, idHash, Math, Clipbrd,
  95.   StrUtils, AdoConnHelper, MainForm;
  96.  
  97. const
  98.   Win32ImportSuffix = {$IFDEF Unicode}'W'{$ELSE}'A'{$ENDIF};
  99.  
  100. function GetVolumeNameForVolumeMountPointA(lpszVolumeMountPoint: PAnsiChar;
  101.   lpszVolumeName: PAnsiChar; cchBufferLength: DWORD): BOOL; stdcall;
  102.   external 'kernel32.dll';
  103. function GetVolumeNameForVolumeMountPointW(lpszVolumeMountPoint: PWideChar;
  104.   lpszVolumeName: PWideChar; cchBufferLength: DWORD): BOOL; stdcall;
  105.   external 'kernel32.dll';
  106. function GetVolumeNameForVolumeMountPoint(lpszVolumeMountPoint: PChar;
  107.   lpszVolumeName: PChar; cchBufferLength: DWORD): BOOL; stdcall;
  108.   external 'kernel32.dll' name 'GetVolumeNameForVolumeMountPoint' +
  109.   Win32ImportSuffix;
  110.  
  111. const
  112.   ERROR_FIELD_SIZE = 200;
  113. {$IFDEF VIATHINKSOFT}
  114.   // Example of multiple drives merging to one Index
  115.   // Find out via "mountvol" command
  116.   GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';
  117.   GUID_EHDD_B = '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\';
  118.   GUID_EHDD_R = '\\?\Volume{9d53ea3c-175c-4a8f-a7b4-7b9e6b765e58}\';
  119. {$ENDIF}
  120.  
  121. function MD5File(const filename: string): string;
  122. var
  123.   IdMD5: TIdHashMessageDigest5;
  124.   FS: TFileStream;
  125. begin
  126.   IdMD5 := TIdHashMessageDigest5.Create;
  127.   FS := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
  128.   try
  129. {$IFDEF UNICODE} // I actually do not know at which version of Delphi/Indy, this has changed.
  130.     Result := IdMD5.HashStreamAsHex(FS);
  131. {$ELSE}
  132.     Result := IdMD5.AsHex(IdMD5.HashValue(FS));
  133. {$ENDIF}
  134.   finally
  135.     FS.Free;
  136.     IdMD5.Free;
  137.   end;
  138. end;
  139.  
  140. function FileMTime_UTC(const filename: string): TDateTime;
  141. var
  142.   fad: TWin32FileAttributeData;
  143.   systime: SYSTEMTIME;
  144. begin
  145.   if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
  146.     RaiseLastOSError;
  147.  
  148.   FileTimeToSystemTime(fad.ftLastWriteTime, systime);
  149.  
  150.   Result := SystemTimeToDateTime(systime);
  151. end;
  152.  
  153. function FileCTime_UTC(const filename: string): TDateTime;
  154. var
  155.   fad: TWin32FileAttributeData;
  156.   systime: SYSTEMTIME;
  157. begin
  158.   if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
  159.     RaiseLastOSError;
  160.  
  161.   FileTimeToSystemTime(fad.ftCreationTime, systime);
  162.  
  163.   Result := SystemTimeToDateTime(systime);
  164. end;
  165.  
  166. function GetFileSize(const AFileName: String): int64;
  167. var
  168.   lFindData: TWin32FindData;
  169.   lHandle: Cardinal;
  170. begin
  171.   // https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html
  172.   lHandle := FindFirstFile(PChar(AFileName), lFindData);
  173.   if (lHandle <> INVALID_HANDLE_VALUE) then
  174.   begin
  175.     Result := lFindData.nFileSizeLow;
  176.     PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;
  177.     Windows.FindClose(lHandle);
  178.   end
  179.   else
  180.     Result := 0;
  181. end;
  182.  
  183. function IntToStr2(i: int64): string;
  184. begin
  185.   // https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html
  186.   Result := Format('%.0n', [i / 1]);
  187. end;
  188.  
  189. function ConvertBytes(Bytes: int64): string;
  190. const
  191.   Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',
  192.     'PB', 'EB', 'ZB', 'YB');
  193. var
  194.   i: Integer;
  195. begin
  196.   // https://stackoverflow.com/questions/30548940/correct-way-to-convert-size-in-bytes-to-kb-mb-gb-delphi
  197.   i := 0;
  198.  
  199.   while Bytes > Power(1024, i + 1) do
  200.     Inc(i);
  201.  
  202.   Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +
  203.     Description[i];
  204. end;
  205.  
  206. var
  207.   DriveGuidCache: TStringList = nil;
  208.  
  209. class function TfrmIndexCreator.DriveGuid(const Letter: char): string;
  210. var
  211.   Buffer: array [0 .. 49] of char;
  212. begin
  213.   if not Assigned(DriveGuidCache) then
  214.     DriveGuidCache := TStringList.Create;
  215.  
  216.   Result := DriveGuidCache.Values[Letter];
  217.   if Result = '' then
  218.   begin
  219.     Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,
  220.       Length(Buffer)));
  221.     Result := Buffer;
  222.     DriveGuidCache.Values[Letter] := Result;
  223.   end;
  224. end;
  225.  
  226. class function TfrmIndexCreator.uniqueFilename(const filename: string): string;
  227. var
  228.   guid: string;
  229. begin
  230.   if Length(filename) < 2 then
  231.     exit;
  232.   if filename[2] = ':' then
  233.   begin
  234.     guid := DriveGuid(filename[1]);
  235.  
  236.     Result := guid + Copy(filename, 4, Length(filename) - 3);
  237.  
  238.     // result := LowerCase(result);
  239.   end
  240.   else
  241.     Result := filename; // z.B. UNC-Pfad
  242. end;
  243.  
  244. class function TfrmIndexCreator.VtsSpecial(const filename: string): string;
  245. begin
  246.   Result := filename;
  247. {$IFDEF VIATHINKSOFT}
  248.   Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);
  249.   Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);
  250.   Result := StringReplace(Result, GUID_EHDD_R, 'EHDD:\', []);
  251. {$ENDIF}
  252. end;
  253.  
  254. function SpecialCompare(a, b: TDateTime): boolean; // true = same timestamp
  255. begin
  256.   if SecondsBetween(a,b) < 2 then exit(true); // equal
  257.  
  258.   if SecondsBetween(a,b) > 7200 then exit(false);
  259.  
  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);
  262.  
  263.   result := false;
  264. end;
  265.  
  266. procedure TfrmIndexCreator.CheckFile(const originalFileName,
  267.   uniqueFilename: string);
  268.  
  269.   function DateTimeToSQL(dt: TDateTime): string;
  270.   begin
  271.     if dt = -1 then
  272.       Result := 'NULL'
  273.     else
  274.       Result := conn.SQLStringEscape(DateTimetoStr(dt));
  275.   end;
  276.  
  277. type
  278.   TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);
  279.  
  280. var
  281.   lastCheckedMd5: string;
  282.  
  283.   function Exists(const filename: string; size: int64;
  284.     const modified: TDateTime): TExistResult;
  285.   var
  286.     q: TADODataSet;
  287.   begin
  288.     q := conn.GetTable('select error, size, modified, md5hash from ' + TableName
  289.       + ' where filename = ' + conn.SQLStringEscape
  290.       (VtsSpecial(uniqueFilename)));
  291.     try
  292.       if q.RecordCount = 0 then
  293.         Result := erDoesNotExist
  294.       else if not q.Fields[0].IsNull then
  295.         Result := erHadError
  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
  298.       begin
  299.         Result := erChanged
  300.       end
  301.       else
  302.         Result := erUnchanged;
  303.       lastCheckedMd5 := q.Fields[3].AsString;
  304.     finally
  305.       FreeAndNil(q);
  306.     end;
  307.   end;
  308.  
  309. var
  310.   created, modified: TDateTime;
  311.   size: int64;
  312.   md5: string;
  313. begin
  314.   Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);
  315.   Application.ProcessMessages;
  316.  
  317.   try
  318.     if FileExists(uniqueFilename) then
  319.       created := FileCTime_UTC(uniqueFilename)
  320.     else
  321.       created := -1;
  322.  
  323.     if FileExists(uniqueFilename) then
  324.       modified := FileMTime_UTC(uniqueFilename)
  325.     else
  326.       modified := -1;
  327.  
  328.     size := GetFileSize(uniqueFilename);
  329.     Inc(sumsize, size);
  330.     Inc(sumfiles);
  331.  
  332.     if rgModus.ItemIndex = modusRecreate then
  333.     begin
  334.       md5 := MD5File(uniqueFilename);
  335.       if not cbSimulate.Checked then
  336.       begin
  337.         conn.ExecSQL('INSERT INTO ' + TableName +
  338.           ' (filename, size, created, modified, md5hash, error) values (' +
  339.           conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
  340.           IntToStr(size) + ', ' + DateTimeToSQL(created) +
  341.           ', ' + DateTimeToSQL(modified) + ', ' +
  342.           conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
  343.       end;
  344.       if cbVerboseLogs.Checked then
  345.         Memo2.Lines.Add('New: ' + uniqueFilename);
  346.       Inc(sumfiles_new);
  347.     end
  348.     else
  349.     begin
  350.       case Exists(uniqueFilename, size, modified) of
  351.         erDoesNotExist: // File does not exist or has a different hash
  352.           begin
  353.             if rgModus.ItemIndex <> modusValidation then
  354.               md5 := MD5File(uniqueFilename);
  355.             if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
  356.             then
  357.             begin
  358.               conn.ExecSQL('INSERT INTO ' + TableName +
  359.                 ' (filename, size, created, modified, md5hash, error) values ('
  360.                 + conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
  361.                 IntToStr(size) + ', ' +
  362.                 DateTimeToSQL(created) + ', ' +
  363.                 DateTimeToSQL(modified) + ', ' +
  364.                 conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
  365.             end;
  366.             if cbVerboseLogs.Checked then
  367.               Memo2.Lines.Add('New: ' + uniqueFilename);
  368.             Inc(sumfiles_new);
  369.           end;
  370.         erHadError, erChanged:
  371.           begin
  372.             if rgModus.ItemIndex <> modusValidation then
  373.               md5 := MD5File(uniqueFilename);
  374.             if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
  375.             then
  376.             begin
  377.               conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
  378.                 IntToStr(size) + ', created = ' +
  379.                 DateTimeToSQL(created) + ', modified = ' +
  380.                 DateTimeToSQL(modified) + ', md5hash = ' +
  381.                 conn.SQLStringEscape(LowerCase(md5)) +
  382.                 ', error = NULL WHERE filename = ' + conn.SQLStringEscape
  383.                 (VtsSpecial(uniqueFilename)) + ';');
  384.             end;
  385.             if cbVerboseLogs.Checked then
  386.               Memo2.Lines.Add('Updated: ' + uniqueFilename);
  387.             Inc(sumfiles_updated);
  388.           end;
  389.         erUnchanged: // Date/Time+Size has not changed
  390.           begin
  391.             {$REGION 'Update it to correct wrong UTC/DST datasets...'}
  392.             conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
  393.               IntToStr(size) + ', created = ' +
  394.               DateTimeToSQL(created) + ', modified = ' +
  395.               DateTimeToSQL(modified) +
  396.               ', error = NULL WHERE filename = ' + conn.SQLStringEscape
  397.               (VtsSpecial(uniqueFilename)) + ';');
  398.             {$ENDREGION}
  399.  
  400.             if rgModus.ItemIndex = modusValidation then
  401.             begin
  402.               md5 := MD5File(uniqueFilename);
  403.               if not SameText(md5, lastCheckedMd5) then
  404.               begin
  405.                 Memo2.Lines.Add
  406.                   ('!!! HASH HAS CHANGED WHILE DATETIME+SIZE IS THE SAME: ' +
  407.                   uniqueFilename + ' (' + lastCheckedMd5 + ' became ' +
  408.                   md5 + ')');
  409.                 Memo2.Color := clRed;
  410.                 Inc(sumfiles_integrityfail);
  411.               end;
  412.             end;
  413.           end;
  414.       end;
  415.     end;
  416.   except
  417.     on E: Exception do
  418.     begin
  419.       if E is EAbort then
  420.         Abort;
  421.       // if AdoConnection1.InTransaction then AdoConnection1.RollbackTrans;
  422.       // AdoConnection1.BeginTrans;
  423.       try
  424.         if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
  425.         then
  426.         begin
  427.           conn.ExecSQL('DELETE FROM ' + TableName + ' WHERE filename = ' +
  428.             conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ';');
  429.           conn.ExecSQL('INSERT INTO ' + TableName +
  430.             ' (filename, size, created, modified, md5hash, error) values (' +
  431.             conn.SQLStringEscape(VtsSpecial(uniqueFilename)) +
  432.             ', NULL, NULL, NULL, NULL, ' + conn.SQLStringEscape(Copy(E.Message,
  433.             1, ERROR_FIELD_SIZE)) + ');');
  434.           Memo2.Lines.Add('Error (logged): ' + E.Message + ' at file ' +
  435.             VtsSpecial(uniqueFilename));
  436.         end
  437.         else
  438.         begin
  439.           Memo2.Lines.Add('Error: ' + E.Message + ' at file ' +
  440.             VtsSpecial(uniqueFilename));
  441.         end;
  442.         // AdoConnection1.CommitTrans;
  443.       except
  444.         // AdoConnection1.RollbackTrans;
  445.         Memo2.Lines.Add('Cannot write error into file database! ' + E.Message +
  446.           ' at file ' + VtsSpecial(uniqueFilename));
  447.       end;
  448.       Inc(sumfiles_error);
  449.     end;
  450.   end;
  451.  
  452.   RedrawStats;
  453.   Application.ProcessMessages;
  454. end;
  455.  
  456. function TfrmIndexCreator.conn: TAdoConnection;
  457. begin
  458.   Result := frmMain.AdoConnection1;
  459. end;
  460.  
  461. procedure TfrmIndexCreator.RedrawStats;
  462. begin
  463.   Label5.Caption := ConvertBytes(sumsize);
  464.   Label6.Caption := IntToStr2(sumfiles);
  465.   Label7.Caption := IntToStr2(sumfiles_new);
  466.   Label9.Caption := IntToStr2(sumfiles_updated);
  467.   Label11.Caption := IntToStr2(sumfiles_error);
  468.   Label12.Caption := IntToStr2(sumfiles_deleted);
  469.   // LabelXX.Caption := IntToStr2(sumfiles_integrityfail);
  470. end;
  471.  
  472. procedure TfrmIndexCreator.Copyuniquepathtoclipboard1Click(Sender: TObject);
  473. var
  474.   s: string;
  475. begin
  476.   s := uniqueFilename(LabeledEdit2.Text);
  477.   Clipboard.AsText := s;
  478. {$IFDEF VIATHINKSOFT}
  479.   if VtsSpecial(s) <> s then
  480.   begin
  481.     s := s + #13#10 + VtsSpecial(s);
  482.   end;
  483. {$ENDIF}
  484.   ShowMessageFmt('Copied to clipboard:' + #13#10#13#10 + '%s', [s]);
  485. end;
  486.  
  487. procedure TfrmIndexCreator.rgModusClick(Sender: TObject);
  488. begin
  489.   cbSimulate.enabled := rgModus.ItemIndex <> modusValidation;
  490.   cbNoDelete.enabled := rgModus.ItemIndex <> modusValidation;
  491. end;
  492.  
  493. function TfrmIndexCreator.TableName: string;
  494. begin
  495.   Result := frmMain.TableName;
  496. end;
  497.  
  498. procedure TfrmIndexCreator.Rec(StartDir: string; const FileMask: string);
  499. var
  500.   SR: TSearchRec;
  501.   DirList: TStrings;
  502.   IsFound: boolean;
  503.   i: Integer;
  504.   UniqueStartDir: string;
  505. begin
  506.   StartDir := IncludeTrailingPathDelimiter(StartDir);
  507.  
  508.   i := 0;
  509.   conn.BeginTrans;
  510.   IsFound := FindFirst(StartDir + FileMask, faAnyFile - faDirectory, SR) = 0;
  511.   try
  512.     while IsFound do
  513.     begin
  514.       Inc(i);
  515.       if i mod 1000 = 0 then // Only for performance
  516.       begin
  517.         conn.CommitTrans;
  518.         conn.BeginTrans;
  519.       end;
  520.       Application.ProcessMessages;
  521.       if Application.Terminated or StopRequest then
  522.         Abort;
  523.  
  524.       if UniqueStartDir = '' then
  525.         UniqueStartDir := uniqueFilename(StartDir);
  526.       CheckFile(StartDir + SR.Name, UniqueStartDir + SR.Name);
  527.       IsFound := FindNext(SR) = 0;
  528.     end;
  529.   finally
  530.     FindClose(SR);
  531.     conn.CommitTrans;
  532.   end;
  533.  
  534.   // Build a list of subdirectories
  535.   DirList := TStringList.Create;
  536.   try
  537.     IsFound := FindFirst(StartDir + '*', faDirectory, SR) = 0;
  538.     try
  539.       while IsFound do
  540.       begin
  541.         if (SR.Name <> '.') and (SR.Name <> '..') then
  542.         begin
  543.           Application.ProcessMessages;
  544.           if Application.Terminated or StopRequest then
  545.             Abort;
  546.  
  547.           DirList.Add(StartDir + SR.Name);
  548.         end;
  549.         IsFound := FindNext(SR) = 0;
  550.       end;
  551.     finally
  552.       FindClose(SR);
  553.     end;
  554.  
  555.     // Scan the list of subdirectories
  556.     for i := 0 to DirList.Count - 1 do
  557.     begin
  558.       try
  559.         Rec(DirList[i], FileMask);
  560.       except
  561.         on E: Exception do
  562.         begin
  563.           if E is EAbort then
  564.             Abort;
  565.           Memo2.Lines.Add('Unexpected error at directory ' + DirList[i] + ': ' +
  566.             E.Message);
  567.         end;
  568.       end;
  569.     end;
  570.   finally
  571.     DirList.Free;
  572.   end;
  573. end;
  574.  
  575. procedure TfrmIndexCreator.DeleteAllFiles(mask: string = '');
  576. begin
  577.   sumfiles_deleted := conn.GetScalar('select count(*) as cnt from ' + TableName
  578.     + ' where filename like ' + conn.SQLStringEscape(VtsSpecial(mask)));
  579.   RedrawStats;
  580.  
  581.   if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation) then
  582.   begin
  583.     if (mask = '') or (mask = '%') then
  584.       conn.ExecSQL('delete from ' + TableName)
  585.     else
  586.       conn.ExecSQL('delete from ' + TableName + ' where filename like ' +
  587.         conn.SQLStringEscape(VtsSpecial(mask)));
  588.   end;
  589. end;
  590.  
  591. procedure TfrmIndexCreator.DeleteVanishedFiles(mask: string = '');
  592.  
  593. {$IFDEF VIATHINKSOFT}
  594. var
  595.   cacheAconnected: boolean;
  596.   cacheBconnected: boolean;
  597.   cacheRconnected: boolean;
  598. {$ENDIF}
  599.   function AllowFileCheck(AFileName: string): boolean;
  600.   var
  601.     guid: string;
  602.   begin
  603.     Result := false;
  604. {$IFDEF VIATHINKSOFT}
  605.     if StartsText('EHDD:\', AFileName) then
  606.     begin
  607.       if not cacheAconnected and SysUtils.DirectoryExists(GUID_EHDD_A) then
  608.       begin
  609.         cacheAconnected := true;
  610.       end;
  611.       if not cacheBconnected and SysUtils.DirectoryExists(GUID_EHDD_B) then
  612.       begin
  613.         cacheBconnected := true;
  614.       end;
  615.       if not cacheRconnected and SysUtils.DirectoryExists(GUID_EHDD_R) then
  616.       begin
  617.         cacheRconnected := true;
  618.       end;
  619.       Result := cacheAconnected or cacheBconnected or cacheRconnected;
  620.     end
  621.     else
  622. {$ENDIF}
  623.       if StartsText('\\?\Volume', AFileName) then
  624.       begin
  625.         guid := Copy(AFileName, 1, 49);
  626.         if EndsText('\', guid) then // should always happen
  627.         begin
  628.           // TODO: cache this result somehow, so that DirectoryExists() does not need to be called all the time
  629.           if SysUtils.DirectoryExists(guid) then // is drive connected/existing?
  630.           begin
  631.             Result := true;
  632.           end;
  633.         end;
  634.       end
  635.       else
  636.       begin
  637.         // TODO: Einen Code für Netzlaufwerke machen: Wir dürfen nur Dateien löschen,
  638.         // wenn das Netzlaufwerk wirklich da ist.
  639.       end;
  640.   end;
  641.  
  642.   function FileDoesExist(AFileName: string): boolean;
  643.   begin
  644. {$IFDEF VIATHINKSOFT}
  645.     if StartsText('EHDD:\', AFileName) then
  646.     begin
  647.       // Attention: AllowFileCheck must be called to initialize cacheAconnected and cacheBconnected and cacheRconnected
  648.  
  649.       if cacheAconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
  650.         GUID_EHDD_A, [])) then
  651.         exit(true);
  652.  
  653.       if cacheBconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
  654.         GUID_EHDD_B, [])) then
  655.         exit(true);
  656.  
  657.       if cacheRconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
  658.         GUID_EHDD_R, [])) then
  659.         exit(true);
  660.  
  661.       exit(false);
  662.     end;
  663. {$ENDIF}
  664.     exit(FileExists(AFileName));
  665.   end;
  666.  
  667. var
  668.   filename: string;
  669.   q: TADODataSet;
  670.   fFileName: TField;
  671.   i: int64;
  672. begin
  673.   if mask <> '' then
  674.     q := conn.GetTable('select filename from ' + TableName +
  675.       ' where filename like ' + conn.SQLStringEscape(VtsSpecial(mask)))
  676.   else
  677.     q := conn.GetTable('select filename from ' + TableName);
  678.   try
  679.     i := 0;
  680.     fFileName := q.FieldByName('filename');
  681.     while not q.Eof do
  682.     begin
  683.       filename := fFileName.AsString;
  684.  
  685.       if AllowFileCheck(filename) and not FileDoesExist(filename) then
  686.       begin
  687.         if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
  688.         then
  689.         begin
  690.           conn.ExecSQL('delete from ' + TableName + ' where filename = ' +
  691.             conn.SQLStringEscape(filename));
  692.         end;
  693.         Inc(sumfiles_deleted);
  694.         if cbVerboseLogs.Checked then
  695.           Memo2.Lines.Add('Deleted: ' + filename);
  696.         RedrawStats;
  697.       end;
  698.  
  699.       Inc(i);
  700.       if i mod 100 = 0 then
  701.       begin
  702.         Label1.Caption := MinimizeName(filename, Label1.Canvas, Label1.Width);
  703.         Application.ProcessMessages;
  704.         if Application.Terminated or StopRequest then
  705.           Abort;
  706.       end;
  707.  
  708.       q.Next;
  709.     end;
  710.   finally
  711.     FreeAndNil(q);
  712.   end;
  713. end;
  714.  
  715. procedure TfrmIndexCreator.IndexDrive(initialdir: string);
  716. begin
  717.   if not cbNoDelete.Checked and not cbSimulate.Checked and
  718.     (rgModus.ItemIndex <> modusValidation) then
  719.   begin
  720.     if rgModus.ItemIndex = modusRecreate then
  721.     begin
  722.       DeleteAllFiles(uniqueFilename(IncludeTrailingPathDelimiter
  723.         (initialdir)) + '%');
  724.     end
  725.     else
  726.     begin
  727.       DeleteVanishedFiles
  728.         (uniqueFilename(IncludeTrailingPathDelimiter(initialdir)) + '%');
  729.     end;
  730.   end;
  731.  
  732.   Rec(IncludeTrailingPathDelimiter(initialdir), '*');
  733. end;
  734.  
  735. procedure TfrmIndexCreator.Button1Click(Sender: TObject);
  736. begin
  737.   sumsize := 0;
  738.   sumfiles := 0;
  739.   sumfiles_new := 0;
  740.   sumfiles_updated := 0;
  741.   sumfiles_error := 0;
  742.   sumfiles_deleted := 0;
  743.   sumfiles_integrityfail := 0;
  744.  
  745.   Label1.Caption := 'Please wait...';
  746.   Label5.Caption := '0';
  747.   Label6.Caption := '0';
  748.   Label7.Caption := '0';
  749.   Label9.Caption := '0';
  750.   Label11.Caption := '0';
  751.   Label12.Caption := '0';
  752.   Application.ProcessMessages;
  753.  
  754.   EnableDisableControls(false);
  755.   try
  756.     if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
  757.     begin
  758.       raise Exception.CreateFmt('Directory %s not found.', [LabeledEdit2.Text]);
  759.     end;
  760.  
  761.     IndexDrive(LabeledEdit2.Text);
  762.  
  763.     (*
  764.       if not Application.Terminated or StopRequest then
  765.       begin
  766.       ShowMessage('Finished');
  767.       end;
  768.     *)
  769.   finally
  770.     if not StopRequest then EnableDisableControls(true);
  771.   end;
  772.  
  773.   if not StopRequest then
  774.   begin
  775.     Beep;
  776.     Label1.Caption := 'Done.';
  777.     Application.ProcessMessages;
  778.   end;
  779. end;
  780.  
  781. procedure TfrmIndexCreator.FormClose(Sender: TObject; var Action: TCloseAction);
  782. begin
  783.   StopRequest := true;
  784.   Action := caFree; // TODO: müssen wir warten bis der prozess angehalten ist?
  785. end;
  786.  
  787. procedure TfrmIndexCreator.FormShow(Sender: TObject);
  788. var
  789.   ini: TMemIniFile;
  790. begin
  791.   ini := frmMain.ini;
  792.   rgModus.ItemIndex := ini.ReadInteger('IndexCreator', 'DefaultMode', modusUpdate);
  793.   cbNoDelete.Checked := ini.ReadBool('IndexCreator', 'DefaultCheckVanished', false);
  794.   cbVerboseLogs.Checked := ini.ReadBool('IndexCreator', 'DefaultVerboseLogs', false);
  795.   cbSimulate.Checked := ini.ReadBool('IndexCreator', 'DefaultSimulate', false);
  796.   LabeledEdit2.Text := ini.ReadString('IndexCreator', 'DefaultDir', 'C:\');
  797. end;
  798.  
  799. procedure TfrmIndexCreator.Button2Click(Sender: TObject);
  800. begin
  801.   StopRequest := true;
  802.   Close;
  803. end;
  804.  
  805. procedure TfrmIndexCreator.Button4Click(Sender: TObject);
  806. var
  807.   i: Integer;
  808.   s: string;
  809. begin
  810.   sumsize := 0;
  811.   sumfiles := 0;
  812.   sumfiles_new := 0;
  813.   sumfiles_updated := 0;
  814.   sumfiles_error := 0;
  815.   sumfiles_deleted := 0;
  816.  
  817.   Label1.Caption := 'Please wait...';
  818.   Label5.Caption := '0';
  819.   Label6.Caption := '0';
  820.   Label7.Caption := '0';
  821.   Label9.Caption := '0';
  822.   Label11.Caption := '0';
  823.   Label12.Caption := '0';
  824.   Application.ProcessMessages;
  825.  
  826.   EnableDisableControls(false);
  827.   try
  828.     // if fileexists('tmp') then memo1.lines.LoadFromFile('tmp');
  829.     for i := Memo1.Lines.Count - 1 downto 0 do
  830.     begin
  831.       s := Memo1.Lines.strings[i];
  832.       if Trim(s) <> '' then
  833.       begin
  834.         LabeledEdit2.Text := s;
  835.  
  836.         if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
  837.         begin
  838.           raise Exception.CreateFmt('Directory %s not found.',
  839.             [LabeledEdit2.Text]);
  840.         end;
  841.  
  842.         IndexDrive(LabeledEdit2.Text);
  843.       end;
  844.       Memo1.Lines.Delete(i);
  845.       // memo1.lines.SaveToFile('tmp');
  846.     end;
  847.  
  848.     (*
  849.       if not Application.Terminated or StopRequest then
  850.       begin
  851.       ShowMessage('Finished');
  852.       end;
  853.     *)
  854.   finally
  855.     EnableDisableControls(true);
  856.   end;
  857.  
  858.   Beep;
  859.   Label1.Caption := 'Done.';
  860.   Application.ProcessMessages;
  861. end;
  862.  
  863. procedure TfrmIndexCreator.EnableDisableControls(enabled: boolean);
  864. begin
  865.   rgModus.enabled := enabled;
  866.   cbNoDelete.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
  867.   cbVerboseLogs.enabled := enabled;
  868.   cbSimulate.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
  869.   Button1.enabled := enabled;
  870.   LabeledEdit2.enabled := enabled;
  871.   Memo1.enabled := enabled;
  872.   Button4.enabled := enabled;
  873. end;
  874.  
  875. end.
  876.