src/shared/fhashdb.pas

   1 (* Copyright (C)  Doom 2D: Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, version 3 of the License ONLY.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  14  *)
  15 {$INCLUDE ../shared/a_modes.inc}
  16 // database of file hashes (md5)
  17 unit fhashdb;
  18
  19 interface
  20
  21 uses
  22   SysUtils, Classes,
  23   md5, hashtable, utils;
  24
  25
  26 type
  27   THashKeyMD5 = class
  28   public
  29     class function hash (const k: TMD5Digest): LongWord; inline;
  30     class function equ (const a, b: TMD5Digest): Boolean; inline;
  31     class procedure freekey (var k: TMD5Digest); inline;
  32   end;
  33
  34   THashStrCIInt = specialize THashBase<AnsiString, Integer, THashKeyStrAnsiCI>;
  35   THashMD5Int = specialize THashBase<TMD5Digest, Integer, THashKeyMD5>;
  36
  37   TFileHashDB = class
  38   private
  39     type TStrDynArray = array of AnsiString;
  40
  41     type
  42       TFileInfo = record
  43         name: AnsiString; // name includes `mBasePath`, if necessary
  44         hash: TMD5Digest;
  45         size: LongWord;
  46         age: LongInt;
  47         nextFree: Integer;
  48         // used in directory scanner
  49         wasSeen: Boolean;
  50       end;
  51
  52   private
  53     mBasePath: AnsiString; // ends with '/', or empty string
  54     mPathList: TStrDynArray;
  55     mHash2List: THashMD5Int; // hash -> list index
  56     mFile2List: THashStrCIInt; // file name -> list index
  57     mFileList: array of TFileInfo;
  58     mFreeHead: Integer;
  59
  60   private
  61     procedure removeIndex (idx: Integer);
  62     function allocIndex (): Integer;
  63
  64     procedure scanDir (path: AnsiString; var changed: Boolean);
  65
  66     procedure appendOneDir (dir: AnsiString);
  67
  68     procedure setup (aBasePath: AnsiString; const aPathList: TStrDynArray);
  69
  70   public
  71     constructor Create (aBasePath: AnsiString; const aPathList: TStrDynArray);
  72     constructor Create (aBasePath: AnsiString; const aPathList: SSArray);
  73     destructor Destroy (); override;
  74
  75     // doesn't automatically rescans
  76     procedure appendMoreDirs (const aPathList: SSArray);
  77
  78     // doesn't clear base path
  79     procedure clear ();
  80
  81     // (re)scans base path and all its subdirs
  82     // returns `true` if db was changed
  83     // you'd better call it after loading a database
  84     function scanFiles (): Boolean;
  85
  86     // those throws
  87     procedure saveTo (st: TStream);
  88     // this clears existing data
  89     procedure loadFrom (st: TStream);
  90
  91     // returns file name relative to base path or empty string
  92     function findByHash (const md5: TMD5Digest): AnsiString;
  93     // returns `true` if something was changed
  94     // name is relative to base
  95     function addWithHash (fdiskname: AnsiString; const md5: TMD5Digest): Boolean;
  96   end;
  97
  98
  99 implementation
 100
 101
 102 class function THashKeyMD5.hash (const k: TMD5Digest): LongWord; inline; begin
 103   //result := joaatHashPtr(@k, sizeof(TMD5Digest));
 104   //k8: use first 4 bytes of k as a hash instead? it should be good enough
 105   Move(k, result, sizeof(result));
 106 end;
 107 class function THashKeyMD5.equ (const a, b: TMD5Digest): Boolean; inline; begin result := MD5Match(a, b); end;
 108 class procedure THashKeyMD5.freekey (var k: TMD5Digest); inline; begin end;
 109
 110
 111 //==========================================================================
 112 //
 113 //  fixSlashes
 114 //
 115 //  fixes all slashes; adds a final one too
 116 //
 117 //==========================================================================
 118 function fixSlashes (const path: AnsiString; addFinal: Boolean): AnsiString;
 119 var
 120   f: Integer;
 121 begin
 122   result := path;
 123   for f := 1 to length(result) do if (result[f] = '\') then result[f] := '/';
 124   if (addFinal) and (length(result) > 0) and (result[length(result)] <> '/') then result := result+'/';
 125 end;
 126
 127
 128 //==========================================================================
 129 //
 130 //  TFileHashDB.appendOneDir
 131 //
 132 //==========================================================================
 133 procedure TFileHashDB.appendOneDir (dir: AnsiString);
 134 var
 135   mps: AnsiString;
 136   found: Boolean;
 137 begin
 138   if (length(dir) = 0) then exit;
 139   if not findFileCI(dir, true) then exit;
 140   dir := fixSlashes(dir, true);
 141   if (mBasePath <> '') and (dir[1] <> '/') then
 142   begin
 143     dir := mBasePath+dir;
 144     if not findFileCI(dir, true) then exit;
 145     dir := fixSlashes(dir, true);
 146   end;
 147   if (dir = '/') then exit;
 148   found := false;
 149   for mps in mPathList do if (dir = mps) then begin found := true; break; end;
 150   if not found then
 151   begin
 152     SetLength(mPathList, length(mPathList)+1);
 153     mPathList[High(mPathList)] := dir;
 154   end;
 155 end;
 156
 157
 158 //==========================================================================
 159 //
 160 //  TFileHashDB.setup
 161 //
 162 //==========================================================================
 163 procedure TFileHashDB.setup (aBasePath: AnsiString; const aPathList: TStrDynArray);
 164 var
 165   s: AnsiString;
 166 begin
 167   mBasePath := aBasePath;
 168   if (length(aBasePath) <> 0) then
 169   begin
 170     if not findFileCI(mBasePath, true) then mBasePath := aBasePath;
 171   end;
 172   mBasePath := fixSlashes(mBasePath, true);
 173   SetLength(mPathList, 0);
 174   for s in aPathList do appendOneDir(s);
 175   mHash2List := THashMD5Int.Create();
 176   mFile2List := THashStrCIInt.Create();
 177   SetLength(mFileList, 0);
 178   mFreeHead := -1;
 179 end;
 180
 181
 182 //==========================================================================
 183 //
 184 //  TFileHashDB.Create
 185 //
 186 //==========================================================================
 187 constructor TFileHashDB.Create (aBasePath: AnsiString; const aPathList: TStrDynArray);
 188 begin
 189   setup(aBasePath, aPathList);
 190 end;
 191
 192
 193 //==========================================================================
 194 //
 195 //  TFileHashDB.Create
 196 //
 197 //==========================================================================
 198 constructor TFileHashDB.Create (aBasePath: AnsiString; const aPathList: SSArray);
 199 var
 200   f: Integer;
 201   pl: TStrDynArray = nil;
 202 begin
 203   SetLength(pl, length(aPathList));
 204   for f := Low(pl) to High(pl) do pl[f] := aPathList[f-Low(pl)+Low(aPathList)];
 205   setup(aBasePath, pl);
 206 end;
 207
 208
 209 //==========================================================================
 210 //
 211 //  TFileHashDB.appendMoreDirs
 212 //
 213 //==========================================================================
 214 procedure TFileHashDB.appendMoreDirs (const aPathList: SSArray);
 215 var
 216   f: Integer;
 217 begin
 218   for f := Low(aPathList) to High(aPathList) do appendOneDir(aPathList[f]);
 219 end;
 220
 221
 222 //==========================================================================
 223 //
 224 //  TFileHashDB.Destroy
 225 //
 226 //==========================================================================
 227 destructor TFileHashDB.Destroy ();
 228 begin
 229   mBasePath := '';
 230   mHash2List.Free;
 231   mFile2List.Free;
 232   SetLength(mFileList, 0);
 233   SetLength(mPathList, 0);
 234   mFreeHead := -1;
 235 end;
 236
 237
 238 //==========================================================================
 239 //
 240 //  TFileHashDB.clear
 241 //
 242 //  doesn't clear base path
 243 //
 244 //==========================================================================
 245 procedure TFileHashDB.clear ();
 246 begin
 247   mHash2List.clear();
 248   mFile2List.clear();
 249   SetLength(mFileList, 0);
 250   //SetLength(mPathList, 0);
 251   mFreeHead := -1;
 252 end;
 253
 254
 255 //==========================================================================
 256 //
 257 //  TFileHashDB.saveTo
 258 //
 259 //==========================================================================
 260 procedure TFileHashDB.saveTo (st: TStream);
 261 var
 262   sign: array[0..3] of AnsiChar;
 263   f: Integer;
 264 begin
 265   sign := 'FHDB';
 266   st.WriteBuffer(sign, 4);
 267   st.WriteWord(1); // version
 268   st.WriteDWord(LongWord(mFile2List.count));
 269   for f := Low(mFileList) to High(mFileList) do
 270   begin
 271     if (length(mFileList[f].name) = 0) then continue;
 272     st.WriteAnsiString(mFileList[f].name);
 273     st.WriteBuffer(mFileList[f].hash, sizeof(TMD5Digest));
 274     st.WriteDWord(mFileList[f].size);
 275     st.WriteDWord(LongWord(mFileList[f].age));
 276   end;
 277 end;
 278
 279
 280 //==========================================================================
 281 //
 282 //  TFileHashDB.loadFrom
 283 //
 284 //==========================================================================
 285 procedure TFileHashDB.loadFrom (st: TStream);
 286 var
 287   sign: array[0..3] of AnsiChar;
 288   count: Integer;
 289   idx: Integer;
 290   fi: ^TFileInfo;
 291 begin
 292   clear();
 293   try
 294     st.ReadBuffer(sign, 4);
 295     if (sign <> 'FHDB') then raise Exception.Create('invalid database signature');
 296     count := st.ReadWord();
 297     if (count <> 1) then raise Exception.Create('invalid database version');
 298     count := Integer(st.ReadDWord());
 299     if (count < 0) or (count > 1024*1024) then raise Exception.Create('invalid database file count');
 300     while (count > 0) do
 301     begin
 302       idx := allocIndex();
 303       fi := @mFileList[idx];
 304       fi.name := st.ReadAnsiString();
 305       st.ReadBuffer(fi.hash, sizeof(TMD5Digest));
 306       fi.size := st.ReadDWord();
 307       fi.age := Integer(st.ReadDWord());
 308       if (length(fi.name) = 0) then raise Exception.Create('invalid database file name');
 309       if (fi.age = -1) then raise Exception.Create('invalid database file age');
 310       mFile2List.put(fi.name, idx);
 311       mHash2List.put(fi.hash, idx);
 312       Dec(count);
 313     end;
 314   except
 315     begin
 316       clear();
 317       raise;
 318      end;
 319   end;
 320 end;
 321
 322
 323 //==========================================================================
 324 //
 325 //  TFileHashDB.removeIndex
 326 //
 327 //==========================================================================
 328 procedure TFileHashDB.removeIndex (idx: Integer);
 329 begin
 330   if (idx < 0) or (idx > High(mFileList)) or (length(mFileList[idx].name) = 0) then exit; // nothing to do
 331   mFile2List.del(mFileList[idx].name);
 332   mHash2List.del(mFileList[idx].hash);
 333   mFileList[idx].name := '';
 334   mFileList[idx].nextFree := mFreeHead;
 335   mFreeHead := idx;
 336 end;
 337
 338
 339 //==========================================================================
 340 //
 341 //  TFileHashDB.allocIndex
 342 //
 343 //==========================================================================
 344 function TFileHashDB.allocIndex (): Integer;
 345 begin
 346   result := mFreeHead;
 347   if (result >= 0) then
 348   begin
 349     mFreeHead := mFileList[result].nextFree;
 350   end
 351   else
 352   begin
 353     result := length(mFileList);
 354     SetLength(mFileList, length(mFileList)+1); // oooh...
 355   end;
 356 end;
 357
 358
 359 //==========================================================================
 360 //
 361 //  TFileHashDB.scanDir
 362 //
 363 //==========================================================================
 364 procedure TFileHashDB.scanDir (path: AnsiString; var changed: Boolean);
 365 var
 366   sr: TSearchRec;
 367   dfn: AnsiString;
 368   hfn: AnsiString;
 369   md5: TMD5Digest;
 370   ok: Boolean;
 371   idx: Integer;
 372   age: LongInt;
 373   needUpdate: Boolean;
 374 begin
 375   //writeln('TFileHashDB.scanDir(000): [', path, ']');
 376   if (FindFirst(path+'*', faAnyFile, sr) <> 0) then
 377   begin
 378     FindClose(sr);
 379     exit;
 380   end;
 381   //writeln('TFileHashDB.scanDir(001): [', path, ']');
 382   try
 383     repeat
 384       if ((sr.Attr and faDirectory) <> 0) then
 385       begin
 386         // directory
 387         if (sr.Name <> '.') and (sr.Name <> '..') then scanDir(path+sr.Name+'/', changed);
 388       end
 389       else if (hasWadExtension(sr.Name)) then
 390       begin
 391         // file
 392         dfn := fixSlashes(path+sr.Name, false);
 393         // build internal file name
 394         hfn := dfn;
 395         //Delete(hfn, 1, length(mBasePath)); // remove prefix
 396         // find file in hash
 397         if not mFile2List.get(hfn, idx) then idx := -1;
 398         // check if we already have this file
 399         age := FileAge(dfn);
 400         if (age <> -1) then
 401         begin
 402           // do we need to update this file?
 403           if (idx >= 0) then
 404           begin
 405             needUpdate :=
 406               (age <> mFileList[idx].age) or
 407               (LongWord(sr.size) <> mFileList[idx].size);
 408           end
 409           else
 410           begin
 411             needUpdate := true;
 412           end;
 413           // recalc md5 and update file entry, if necessary
 414           if (needUpdate) then
 415           begin
 416             ok := false;
 417             try
 418               md5 := MD5File(dfn);
 419               ok := true;
 420             except
 421             end;
 422             if (ok) then
 423             begin
 424               changed := true;
 425               // remove old hash -> index mapping
 426               if (idx >= 0) then mHash2List.del(mFileList[idx].hash);
 427               // update
 428               if (idx < 0) then idx := allocIndex();
 429               mFileList[idx].name := hfn;
 430               mFileList[idx].hash := md5;
 431               mFileList[idx].size := LongWord(sr.size);
 432               mFileList[idx].age := age;
 433               mFileList[idx].nextFree := -1;
 434               mFileList[idx].wasSeen := true;
 435               mFile2List.put(hfn, idx);
 436               mHash2List.put(md5, idx);
 437             end
 438             else
 439             begin
 440               // update failed, remove this entry
 441               if (idx >= 0) then changed := true;
 442               removeIndex(idx); // cannot read, remove
 443             end;
 444           end
 445           else
 446           begin
 447             if (idx >= 0) then mFileList[idx].wasSeen := true;
 448           end;
 449         end
 450         else
 451         begin
 452           // remove this file if we don't have it anymore
 453           if (idx >= 0) then changed := true;
 454           removeIndex(idx);
 455         end;
 456       end
 457       else
 458       begin
 459         dfn := fixSlashes(path+sr.Name, false);
 460         // build internal file name
 461         hfn := dfn;
 462         Delete(hfn, 1, length(mBasePath)); // remove prefix
 463         // find file in hash
 464         if mFile2List.get(hfn, idx) then
 465         begin
 466           changed := true;
 467           removeIndex(idx);
 468         end;
 469       end;
 470     until (FindNext(sr) <> 0);
 471   finally
 472     FindClose(sr);
 473   end;
 474 end;
 475
 476
 477 //==========================================================================
 478 //
 479 //  TFileHashDB.scanFiles
 480 //
 481 //  scans base path and all its subdirs
 482 //  returns `true` if db was changed
 483 //
 484 //==========================================================================
 485 function TFileHashDB.scanFiles (): Boolean;
 486 var
 487   f: Integer;
 488 begin
 489   result := false;
 490   for f := Low(mFileList) to High(mFileList) do mFileList[f].wasSeen := false;
 491   //scanDir(mBasePath, result);
 492   //writeln('TFileHashDB.scanFiles: dll=', length(mPathList));
 493   for f := Low(mPathList) to High(mPathList) do scanDir(mPathList[f], result);
 494   // remove all unseen files
 495   f := High(mFileList);
 496   while (f >= 0) do
 497   begin
 498     if (length(mFileList[f].name) > 0) and (not mFileList[f].wasSeen) then removeIndex(f);
 499     Dec(f);
 500   end;
 501 end;
 502
 503
 504 //==========================================================================
 505 //
 506 //  TFileHashDB.findByHash
 507 //
 508 //  returns file name relative to base path or empty string
 509 //
 510 //==========================================================================
 511 function TFileHashDB.findByHash (const md5: TMD5Digest): AnsiString;
 512 var
 513   idx: Integer;
 514 begin
 515   if not mHash2List.get(md5, idx) then begin result := ''; exit; end;
 516   result := mFileList[idx].name;
 517 end;
 518
 519
 520 //==========================================================================
 521 //
 522 //  TFileHashDB.addWithHash
 523 //
 524 //  returns `true` if something was changed
 525 //  name is *NOT* relative to base
 526 //
 527 //==========================================================================
 528 function TFileHashDB.addWithHash (fdiskname: AnsiString; const md5: TMD5Digest): Boolean;
 529 var
 530   age: LongInt;
 531   size: LongInt;
 532   handle: THandle;
 533   fn: AnsiString;
 534   idx: Integer;
 535 begin
 536   result := false;
 537   //if (length(fdiskname) > length(mBasePath)) and strEquCI1251(mBasePath, Copy(fdiskname, 1, length(mBasePath))) then Delete(fdiskname, 1, Length(mBasePath));
 538   if (length(fdiskname) = 0) then exit;
 539   //fn := mBasePath+fdiskname;
 540   fn := fdiskname;
 541   if not findFileCI(fn) then exit;
 542   // get age
 543   age := FileAge(fn);
 544   if (age = -1) then exit;
 545   // get size
 546   handle := FileOpen(fn, fmOpenRead or fmShareDenyNone);
 547   if (handle = THandle(-1)) then exit;
 548   size := FileSeek(handle, 0, fsFromEnd);
 549   FileClose(handle);
 550   if (size = -1) then exit;
 551   // find old file, if any
 552   //Delete(fn, 1, length(mBasePath));
 553   if not mFile2List.get(fn, idx) then idx := -1;
 554   // check for changes
 555   if (idx >= 0) then
 556   begin
 557     if (mFileList[idx].size = size) and (mFileList[idx].age = age) and (MD5Match(mFileList[idx].hash, md5)) then exit;
 558     removeIndex(idx);
 559   end;
 560   idx := allocIndex();
 561   mFileList[idx].name := fn;
 562   mFileList[idx].hash := md5;
 563   mFileList[idx].size := size;
 564   mFileList[idx].age := age;
 565   mFileList[idx].nextFree := -1;
 566   mFile2List.put(fn, idx);
 567   mHash2List.put(md5, idx);
 568   result := true;
 569 end;
 570
 571
 572 end.