DEADSOFTWARE

put network interp back in
[d2df-sdl.git] / 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;
19 interface
21 uses
22 SysUtils, Classes,
23 md5, hashtable, utils;
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;
34 THashStrCIInt = specialize THashBase<AnsiString, Integer, THashKeyStrAnsiCI>;
35 THashMD5Int = specialize THashBase<TMD5Digest, Integer, THashKeyMD5>;
37 TFileHashDB = class
38 private
39 type TStrDynArray = array of AnsiString;
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;
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;
60 private
61 procedure removeIndex (idx: Integer);
62 function allocIndex (): Integer;
64 procedure scanDir (path: AnsiString; var changed: Boolean);
66 procedure appendOneDir (dir: AnsiString);
68 procedure setup (aBasePath: AnsiString; const aPathList: TStrDynArray);
70 public
71 constructor Create (aBasePath: AnsiString; const aPathList: TStrDynArray);
72 constructor Create (aBasePath: AnsiString; const aPathList: SSArray);
73 destructor Destroy (); override;
75 // doesn't automatically rescans
76 procedure appendMoreDirs (const aPathList: SSArray);
78 // doesn't clear base path
79 procedure clear ();
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;
86 // those throws
87 procedure saveTo (st: TStream);
88 // this clears existing data
89 procedure loadFrom (st: TStream);
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;
99 implementation
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;
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;
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;
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;
182 //==========================================================================
183 //
184 // TFileHashDB.Create
185 //
186 //==========================================================================
187 constructor TFileHashDB.Create (aBasePath: AnsiString; const aPathList: TStrDynArray);
188 begin
189 setup(aBasePath, aPathList);
190 end;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
572 end.