Subversion Repositories indexer_suite

Rev

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