source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/IECache.pas@ 1591

Last change on this file since 1591 was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 22.1 KB
RevLine 
[541]1//**************************************************************
2// *
3// TIECache * // *
4// For Delphi 5, 6, 7, 2005, 2006 *
5// Freeware Component *
6// by *
7// Per Lindsø Larsen *
8// per.lindsoe@larsen.dk *
9// *
10// Contributions: *
11// Christian Lovis for lib dynamic linking *
12// {christian.lovis@dim.hcuge.ch] *
13// Eran Bodankin (bsalsa) bsalsa@gmail.com *
14// - D2005 update *
15// *
16// Updated versions: *
17// http://www.bsalsa.com *
18//**************************************************************
19
20{*******************************************************************************}
21{LICENSE:
22THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
23EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
24WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
25YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
26AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
27AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
28OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
29OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
30INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
31OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
32AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
33DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
34
35You may use, change or modify the component under 4 conditions:
361. In your website, add a link to "http://www.bsalsa.com"
372. In your application, add credits to "Embedded Web Browser"
383. Mail me (bsalsa@gmail.com) any code change in the unit
39 for the benefit of the other users.
404. Please consider donation in our web site!
41{*******************************************************************************}
42
43unit IECache;
44
45interface
46
47{$I EWB.inc}
48
49uses
50 WinInet, Windows, Messages, SysUtils, Classes, IeConst;
51
52type
53 PInternetCacheTimeStamps = ^TInternetCacheTimeStamps;
54 TInternetCacheTimeStamps = record
55 ftExpires: TFileTime;
56 ftLastModified: TFileTime;
57 end;
58 PInternetCacheGroupInfo = ^TInternetCacheGroupInfo;
59 TInternetCacheGroupInfo = record
60 dwGroupSize: DWORD;
61 dwGroupFlags: DWORD;
62 dwGroupType: DWORD;
63 dwDiskUsage: DWORD;
64 dwDiskQuota: DWORD;
65 dwOwnerStorage: array[0..GROUP_OWNER_STORAGE_SIZE - 1] of DWORD;
66 szGroupName: array[0..GROUPNAME_MAX_LENGTH - 1] of AnsiChar;
67 end;
68 TEntryInfo = record
69 SourceUrlName: string;
70 LocalFileName: string;
71 EntryType: DWORD;
72 UseCount: DWORD;
73 HitRate: DWORD;
74 FSize: DWORD;
75 LastModifiedTime: TDateTime;
76 ExpireTime: TDateTime;
77 LastAccessTime: TDateTime;
78 LastSyncTime: TDateTime;
79 HeaderInfo: string;
80 FileExtension: string;
81 ExemptDelta: DWORD;
82 end;
83 TGroupInfo = record
84 DiskUsage: DWORD;
85 DiskQuota: DWORD;
86 OwnerStorage: array[0..GROUP_OWNER_STORAGE_SIZE - 1] of DWORD;
87 GroupName: string;
88 end;
89 TContent = record
90 Buffer: Pointer;
91 BufferLength: Integer;
92 end;
93 TFilterOption = (NORMAL_ENTRY,
94 STABLE_ENTRY,
95 STICKY_ENTRY,
96 COOKIE_ENTRY,
97 URLHISTORY_ENTRY,
98 TRACK_OFFLINE_ENTRY,
99 TRACK_ONLINE_ENTRY,
100 SPARSE_ENTRY,
101 OCX_ENTRY);
102 TFilterOptions = set of TFilterOption;
103 TOnEntryEvent = procedure(Sender: TObject; var Cancel: Boolean) of object;
104 TOnGroupEvent = procedure(Sender: TObject; GroupID: GROUPID; var Cancel: Boolean) of object;
105 TSearchPattern = (spAll, spCookies, spHistory, spUrl);
106
107 TIECache = class(TComponent)
108 private
109 FSearchPattern: TSearchPattern;
110 FOnEntry: TOnEntryEvent;
111 FOnGroup: TOnGroupEvent;
112 GrpHandle: THandle;
113 H: THandle;
114 FCancel: Boolean;
115 FFilterOptions: TFilterOptions;
116 FFilterOptionValue: Cardinal;
117 procedure SetFilterOptions(const Value: TFilterOptions);
118 procedure UpdateFilterOptionValue;
119 procedure GetEntryValues(Info: PInternetCacheEntryInfo);
120 procedure ClearEntryValues;
121 protected { Protected declarations }
122 public
123 GroupInfo: TGroupInfo;
124 EntryInfo: TEntryInfo;
125 Content: TContent;
126 constructor Create(AOwner: TComponent); override;
127 function AddUrlToGroup(GroupID: INT64; URL: string): DWORD;
128 function CloseFindEntry: BOOL;
129 function CopyFileToCache(URL, FileName: string; CacheType: DWORD; Expire: TDateTime): DWORD;
130 // function CopyFileToCache(UrlName, FileName: Pchar): string;
131 function CreateEntry(URL, FileExtension: string; ExpectedFileSize: DWORD; var FName: string): DWORD;
132 function CreateGroup: INT64;
133 function DeleteEntry(URL: string): DWORD;
134 function DeleteGroup(GroupID: INT64): DWORD;
135 function FindFirstEntry(GroupID: INT64): DWORD;
136 function FindFirstGroup(var GroupID: Int64): DWORD;
137 function FindNextEntry: DWORD;
138 function FindNextGroup(var GroupID: Int64): BOOL;
139 function GetEntryContent(URL: string): DWORD;
140 function GetEntryInfo(URL: string): DWORD;
141 function GetGroupInfo(GroupID: INT64): DWORD;
142 function getLibraryFound: Boolean;
143 function RemoveUrlFromGroup(GroupID: INT64; URL: string): DWORD;
144 function RetrieveGroups: DWORD;
145 function SetEntryInfo(URL: string): DWORD;
146 function SetGroupInfo(GroupID: INT64): DWORD;
147 procedure ClearAllEntries;
148 procedure RetrieveEntries(GroupID: INT64);
149 { Public declarations }
150 published
151 property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions;
152 property LibraryFound: Boolean read getLibraryFound;
153 property OnEntry: TOnEntryEvent read FOnEntry write FOnEntry;
154 property OnGroup: TOnGroupEvent read FOnGroup write FOnGroup;
155 property SearchPattern: TSearchpattern read FSearchpattern write FSearchPattern;
156 { Published declarations }
157 end;
158
159implementation
160
161type
162
163 TFindFirstUrlCacheGroup =
164 function(dwFlags, dwFilter: DWORD;
165 lpSearchCondition: Pointer; dwSearchCondition: DWORD;
166 var Group: Int64; lpReserved: Pointer): THandle; stdcall;
167
168 TFindNextUrlCacheGroup =
169 function(hFind: THandle; var GroupID: Int64; lpReserved: Pointer): BOOL; stdcall;
170
171 TSetUrlCacheGroupAttribute =
172 function(gid: Int64; dwFlags, dwAttributes: DWORD; var lpGroupInfo: TInternetCacheGroupInfo;
173 lpReserved: Pointer): BOOL; stdcall;
174
175 TGetUrlCacheGroupAttribute =
176 function(gid: Int64; dwFlags, dwAttributes: DWORD;
177 var GroupInfo: TInternetCacheGroupInfo; var dwGroupInfo: DWORD; lpReserved: Pointer): BOOL; stdcall;
178
179var
180 FindFirstUrlCacheGroup: tFindFirstUrlCacheGroup;
181 FindNextUrlCacheGroup: tFindNextUrlCacheGroup;
182 GetUrlCacheGroupAttribute: tGetUrlCacheGroupAttribute;
183 SetUrlCacheGroupAttribute: tSetUrlCacheGroupAttribute;
184 winInetLibFound: Boolean;
185
186const
187 winetdll = 'wininet.dll';
188
189//====Accessories===============================================================
190
191function InitializeWinInet: Boolean;
192var
193 fPointer: tFarProc;
194 hInst: tHandle;
195begin
196 if winInetLibFound then
197 Result := true
198 else
199 begin
200 Result := False;
201 hInst := loadLibrary(winetdll);
202 if hInst > 0 then
203 try
204 fPointer := getProcAddress(hInst, 'FindFirstUrlCacheGroup');
205 if fPointer <> nil then
206 begin
207 FindFirstUrlCacheGroup := tFindFirstUrlCacheGroup(fPointer);
208 fPointer := getProcAddress(hInst, 'FindNextUrlCacheGroup');
209 if fPointer <> nil then
210 begin
211 FindNextUrlCacheGroup := tFindNextUrlCacheGroup(fPointer);
212 fPointer := getProcAddress(hInst, 'GetUrlCacheGroupAttributeA');
213 if fPointer <> nil then
214 begin
215 GetUrlCacheGroupAttribute := tGetUrlCacheGroupAttribute(fPointer);
216 fPointer := getProcAddress(hInst, 'SetUrlCacheGroupAttributeA');
217 if fPointer <> nil then
218 begin
219 SetUrlCacheGroupAttribute := tSetUrlCacheGroupAttribute(fPointer);
220 fPointer := getProcAddress(hInst, 'FindFirstUrlCacheEntryExA');
221 if fPointer <> nil then
222 Result := true;
223 end; // SetUrlCacheGroupAttribute
224 end; // GetUrlCacheGroupAttribute
225 end; // FindNextUrlCacheGroup
226 end; // FindFirstUrlCacheGroup
227 except
228 end; // loadLib
229 winInetLibFound := Result;
230 end;
231end;
232
233function FileTimeToDateTime(Ft: TFileTime): TDateTime;
234var
235 St: TSystemTime;
236 lft: TFileTime;
237begin
238 Result := 0;
239 try
240 if FileTimeToLocalFiletime(Ft, lft) then
241 if FileTimeToSyStemTime(lft, st) then
242 Result := SystemTimeTODateTime(st);
243 except
244 end;
245end;
246
247function DateTimeToFileTime(Dt: TDateTime): TFileTime;
248var
249 St: TSystemTime;
250 lft: TFileTime;
251begin
252 try
253 DateTimeToSystemTime(Dt, ST);
254 if SystemTimeToFileTime(st, lft) then
255 LocalFileTimeToFileTime(lft, Result);
256 except
257 Result.dwLowDateTime := 0;
258 Result.dwHighDateTime := 0;
259 end;
260end;
261
262//====IE Cache==================================================================
263
264constructor TIECache.Create(AOwner: TComponent);
265begin
266 inherited;
267 Content.Buffer := nil;
268 ClearEntryValues;
269 // Identical to URLCACHE_FIND_DEFAULT_FILTER
270 FFilterOptions := [NORMAL_ENTRY, COOKIE_ENTRY, URLHISTORY_ENTRY,
271 TRACK_OFFLINE_ENTRY, TRACK_ONLINE_ENTRY, STICKY_ENTRY];
272end;
273
274function TIECache.getLibraryFound: Boolean;
275begin
276 Result := InitializeWinInet;
277end;
278
279function TIECache.RemoveUrlFromGroup(GroupID: INT64; URL: string): DWORD;
280begin
281 Result := S_OK;
282 if not InitializeWinInet then
283 begin
284 Result := ERROR_FILE_NOT_FOUND;
285 Exit;
286 end;
287 if not SetUrlCacheEntryGroup(Pchar(URL), INTERNET_CACHE_GROUP_REMOVE, GroupID, nil, 0, nil)
288 then
289 Result := GetLastError;
290end;
291
292function TIECache.AddUrlToGroup(GroupID: INT64; URL: string): DWORD;
293begin
294 Result := S_OK;
295 if not InitializeWinInet then
296 begin
297 Result := ERROR_FILE_NOT_FOUND;
298 Exit;
299 end;
300 if not SetUrlCacheEntryGroup(Pchar(URL), INTERNET_CACHE_GROUP_ADD, GroupID, nil, 0, nil)
301 then
302 Result := GetLastError;
303end;
304
305function TIECache.CopyFileToCache(URL, FileName: string; CacheType: DWORD; Expire: TDateTime): DWORD;
306var
307 FName: string;
308 Ext: string;
309 F: file of Byte;
310 Size: DWORD;
311begin
312 if not InitializeWinInet then
313 begin
314 Result := ERROR_FILE_NOT_FOUND;
315 Exit;
316 end;
317 if not FileExists(FileName) then
318 begin
319 Result := ERROR_FILE_NOT_FOUND;
320 Exit;
321 end;
322 AssignFile(F, FileName);
323 Reset(F);
324 Size := FileSize(F);
325 CloseFile(F);
326 Ext := ExtractFileExt(FileName);
327 Ext := Copy(Ext, 2, Length(ext));
328 Result := CreateEntry(URL, Ext, Size, FName);
329 if Result <> S_OK then
330 Exit;
331 if not windows.copyfile(PChar(FileName), Pchar(FName), False) then
332 begin
333 Result := GetLastError;
334 Exit;
335 end;
336 if not CommitUrlCacheEntry(Pchar(URL), Pchar(Fname), DateTimeToFileTime(Expire), DateTimeToFileTime(now), CacheType, nil, 0, Pchar(Ext), 0)
337 then
338 Result := GetLastError;
339end;
340
341function TIECache.CreateEntry(URL, FileExtension: string; ExpectedFileSize: DWORD; var FName: string): DWORD;
342var
343 PC: array[0..MAX_PATH] of Char;
344begin
345 PC := '';
346 Result := S_OK;
347 if not InitializeWinInet then
348 begin
349 Result := ERROR_FILE_NOT_FOUND;
350 Exit;
351 end;
352 if not CreateUrlCacheEntry(Pchar(URL), ExpectedFileSize, Pchar(FileExtension), PC, 0) then
353 Result := GetLastError
354 else
355 FName := StrPas(PC);
356end;
357
358function TIECache.GetGroupInfo(GroupID: INT64): DWORD;
359var
360 info: TInternetCacheGroupInfo;
361 dw: DWORD;
362begin
363 Result := S_OK;
364 if not InitializeWinInet then
365 begin
366 Result := ERROR_FILE_NOT_FOUND;
367 Exit;
368 end;
369 dw := SizeOf(TInternetCacheGroupInfo);
370 if not GetUrlCacheGroupAttribute(GroupID, 0, CACHEGROUP_ATTRIBUTE_GET_ALL, info, dw, nil)
371 then
372 Result := GetLastError
373 else
374 with GroupInfo do
375 begin
376 DiskUsage := info.dwDiskUsage;
377 DiskQuota := info.dwDiskQuota;
378 Move(info.dwOwnerStorage, OwnerStorage, Sizeof(OwnerStorage));
379 GroupName := string(info.szGroupName);
380 end;
381end;
382
383function TIECache.SetGroupInfo(GroupID: INT64): DWORD;
384var
385 info: TInternetCacheGroupInfo;
386begin
387 Result := S_OK;
388 if not InitializeWinInet then
389 begin
390 Result := ERROR_FILE_NOT_FOUND;
391 Exit;
392 end;
393 info.dwGroupSize := SizeOf(Info);
394 info.dwGroupFlags := CACHEGROUP_FLAG_NONPURGEABLE;
395 info.dwGroupType := CACHEGROUP_TYPE_INVALID;
396 info.dwDiskQuota := GroupInfo.DiskQuota;
397 move(GroupInfo.OwnerStorage, info.dwOwnerStorage, Sizeof(info.dwOwnerStorage));
398 move(GroupInfo.Groupname[1], info.szGroupName[0], length(GroupInfo.Groupname));
399 if not SetUrlCacheGroupAttribute(GroupID, 0, CACHEGROUP_READWRITE_MASK, info, nil) then
400 Result := GetLastError;
401end;
402
403function TIECache.CreateGroup: INT64;
404begin
405 if not InitializeWinInet then
406 begin
407 Result := ERROR_FILE_NOT_FOUND;
408 Exit;
409 end;
410 Result := CreateUrlCacheGroup(0, nil);
411end;
412
413function TIECache.DeleteGroup(GroupID: INT64): DWORD;
414begin
415 Result := S_OK;
416 if not InitializeWinInet then
417 begin
418 Result := ERROR_FILE_NOT_FOUND;
419 Exit;
420 end;
421 if not DeleteUrlCacheGroup(GroupID, CACHEGROUP_FLAG_FLUSHURL_ONDELETE, nil) then
422 Result := GetLastError;
423end;
424
425function TIECache.SetEntryInfo(URL: string): DWORD;
426var
427 Info: TInternetCacheEntryInfo;
428 FC: DWORD;
429begin
430 Result := S_OK;
431 if not InitializeWinInet then
432 begin
433 Result := ERROR_FILE_NOT_FOUND;
434 Exit;
435 end;
436 FC := CACHE_ENTRY_ATTRIBUTE_FC +
437 CACHE_ENTRY_HITRATE_FC +
438 CACHE_ENTRY_MODTIME_FC +
439 CACHE_ENTRY_EXPTIME_FC +
440 CACHE_ENTRY_ACCTIME_FC +
441 CACHE_ENTRY_SYNCTIME_FC +
442 CACHE_ENTRY_EXEMPT_DELTA_FC;
443 with Info do
444 begin
445 CacheEntryType := EntryInfo.EntryType;
446 dwHitRate := EntryInfo.HitRate;
447 LastModifiedTime := DateTimeToFileTime(EntryInfo.LastModifiedTime);
448 ExpireTime := DateTimeToFileTime(EntryInfo.ExpireTime);
449 LastAccessTime := DateTimeToFileTime(EntryInfo.LastAccessTime);
450 LastSyncTime := DateTimeToFileTime(EntryInfo.LastSyncTime);
451 dwReserved := EntryInfo.ExemptDelta;
452 end;
453 if not SetUrlCacheEntryInfo(Pchar(URL), Info, FC) then
454 Result := GetLastError;
455end;
456
457function TIECache.GetEntryInfo(URL: string): DWORD;
458var
459 D: DWORD;
460 T: PInternetCacheEntryInfo;
461begin
462 Result := S_OK;
463 if not InitializeWinInet then
464 begin
465 Result := ERROR_FILE_NOT_FOUND;
466 Exit;
467 end;
468 if (D <= 0) or (not GetUrlCacheEntryInfoEx(Pchar(URL), nil, @D, nil, nil, nil, 0)) then
469 begin
470 // (PChar(SysErrorMessage(GetLastError)));
471 // https objects are not stored in cache
472 Result := GetLastError();
473 end
474 else
475 begin
476 GetMem(T, D);
477 try
478 if GetUrlCacheEntryInfoEx(Pchar(URL), T, @D, nil, nil, nil, 0)
479 then
480 GetEntryValues(t)
481 else
482 Result := GetLastError;
483 finally
484 FreeMem(T, D);
485 end;
486 end;
487end;
488
489function TIECache.GetEntryContent(URL: string): DWORD;
490var
491 HR: THandle;
492 D: Cardinal;
493 T: PInternetCacheEntryInfo;
494begin
495 Result := S_OK;
496 if not InitializeWinInet then
497 begin
498 Result := ERROR_FILE_NOT_FOUND;
499 Exit;
500 end;
501 D := 0;
502 T := nil;
503 RetrieveUrlCacheEntryStream(PChar(URL), T^, D, TRUE, 0);
504 Getmem(T, D);
505 try
506 HR := THandle(RetrieveUrlCacheEntryStream(PChar(URL), T^, D, TRUE, 0));
507 if HR <> 0 then
508 begin
509 Content.BufferLength := T^.dwSizeLow + 1;
510 GetEntryValues(T);
511 Getmem(Content.Buffer, Content.BufferLength);
512 Fillchar(Content.Buffer^, Content.BufferLength, #0);
513 if not ReadUrlCacheEntryStream(Hr, 0, Content.Buffer, T^.DwSizeLow, 0)
514 then
515 Result := GetLastError;
516 end;
517 finally
518 FreeMem(T, D);
519 end;
520 UnLockUrlCacheEntryStream(HR, 0);
521end;
522
523function TIECache.FindNextGroup(var GroupID: Int64): BOOL;
524begin
525 if not InitializeWinInet then
526 begin
527 Result := False;
528 Exit;
529 end;
530 Result := FindNextUrlCacheGroup(GrpHandle, GroupID, nil);
531 GetGroupInfo(GroupID);
532end;
533
534function TIECache.FindFirstGroup(var GroupID: Int64): DWORD;
535begin
536 if not InitializeWinInet then
537 begin
538 Result := ERROR_FILE_NOT_FOUND;
539 Exit;
540 end;
541 GrpHandle := FindFirstUrlCacheGroup(0, 0, nil, 0, GroupID, nil);
542 if GrpHandle <> 0 then
543 Result := S_OK
544 else
545 Result := GetLastError;
546 if Result = S_OK then
547 GetGroupInfo(GroupID);
548end;
549
550function TIECache.RetrieveGroups: DWORD;
551var
552 GroupID: INT64;
553 Res: DWORD;
554 NewGroup, Cancel: Boolean;
555begin
556 Result := S_OK;
557 if not InitializeWinInet then
558 begin
559 Result := ERROR_FILE_NOT_FOUND;
560 Exit;
561 end;
562 Cancel := False;
563 NewGroup := True;
564 Res := FindFirstGroup(GroupID);
565 if Res = S_OK then
566 begin
567 GetGroupInfo(GroupID);
568 if Assigned(FOngroup) then
569 FOnGroup(self, GroupID, FCancel);
570 while not Cancel and NewGroup do
571 begin
572 NewGroup := FindNextGroup(GroupID);
573 GetGroupInfo(GroupID);
574 if Assigned(FOngroup) and NewGroup then
575 FOnGroup(self, GroupID, Cancel);
576 end;
577 end
578 else
579 Result := GetLastError;
580end;
581
582function TIECache.DeleteEntry(URL: string): DWORD;
583begin
584 Result := S_OK;
585 if not InitializeWinInet then Exit;
586 if not DeleteUrlCacheEntry(PChar(URL)) then
587 Result := GetLastError
588 else
589 ClearEntryValues;
590end;
591
592procedure TIECache.ClearAllEntries;
593var
594 HR: DWord;
595begin
596 if not InitializeWinInet then Exit;
597 if FindFirstEntry(0) = S_OK then
598 begin
599 repeat
600 DeleteEntry(EntryInfo.SourceUrlName);
601 HR := FindNextEntry;
602 until HR = ERROR_NO_MORE_ITEMS;
603 end;
604 FindCloseUrlCache(H);
605end;
606
607procedure TIECache.ClearEntryValues;
608begin
609 if not InitializeWinInet then Exit;
610 Content.Buffer := nil;
611 Content.BufferLength := 0;
612 with EntryInfo do
613 begin
614 SourceUrlName := '';
615 LocalFileName := '';
616 EntryType := 0;
617 UseCount := 0;
618 Hitrate := 0;
619 LastModifiedTime := 0;
620 ExpireTime := 0;
621 LastAccessTime := 0;
622 LastSyncTime := 0;
623 FileExtension := '';
624 FSize := 0;
625 HeaderInfo := '';
626 ExemptDelta := 0;
627 end;
628end;
629
630procedure TIECache.GetEntryValues(Info: PInternetCacheEntryInfo);
631begin
632 if not InitializeWinInet then Exit;
633 with entryInfo do
634 begin
635 SourceUrlName := info^.lpszSourceUrlName;
636 LocalFileName := info^.lpszLocalFileName;
637 EntryType := info^.CacheEntryType;
638 UseCount := info^.dwUseCount;
639 Hitrate := info^.dwHitRate;
640 LastModifiedTime := FileTimeToDateTime(info^.LastModifiedTime);
641 ExpireTime := FileTimeToDateTime(info^.ExpireTime);
642 LastAccessTime := FileTimeToDateTime(info^.LastAccessTime);
643 LastSyncTime := FileTimeToDateTime(info^.LastSyncTime);
644 FileExtension := info^.lpszFileExtension;
645 FSize := (info^.dwSizeHigh shl 32) + info^.dwSizeLow;
646 HeaderInfo := StrPas(PChar(info^.lpHeaderInfo));
647 ExemptDelta := info^.dwReserved;
648 end;
649end;
650
651function TIECache.FindFirstEntry(GroupID: INT64): DWORD;
652const
653 Pattern: array[TSearchPattern] of PChar = (nil, 'Cookie:', 'Visited:', '');
654var
655 T: PInternetCacheEntryInfo;
656 D: DWORD;
657begin
658 Result := S_OK;
659 if not InitializeWinInet then
660 begin
661 Result := ERROR_FILE_NOT_FOUND;
662 Exit;
663 end;
664 H := 0;
665 D := 0;
666 FindFirstUrlCacheEntryEx(Pattern[SearchPattern], 0, FFilterOptionValue, GroupID, nil, @D, nil, nil, nil);
667 GetMem(T, D);
668 try
669 H := FindFirstUrlCacheEntryEx(Pattern[SearchPattern], 0, FFilterOptionValue, GroupID, T, @D, nil, nil, nil);
670 if (H = 0) then
671 Result := GetLastError
672 else
673 GetEntryValues(T);
674 finally
675 FreeMem(T, D)
676 end;
677end;
678
679function TIECache.FindNextEntry: DWORD;
680var
681 T: PInternetCacheEntryInfo;
682 D: DWORD;
683begin
684 Result := S_OK;
685 if not InitializeWinInet then
686 begin
687 Result := ERROR_FILE_NOT_FOUND;
688 Exit;
689 end;
690 D := 0;
691 FindNextUrlCacheEntryEx(H, nil, @D, nil, nil, nil);
692 GetMem(T, D);
693 try
694 if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil)
695 then
696 Result := GetLastError
697 else
698 GetEntryValues(T);
699 finally
700 FreeMem(T, D)
701 end;
702end;
703
704procedure TIECache.RetrieveEntries(GroupID: INT64);
705var
706 HR: DWORD;
707begin
708 if not InitializeWinInet then Exit;
709 FCancel := False;
710 HR := FindFirstEntry(GroupID);
711 if (HR = S_OK) then
712 begin
713 if Assigned(FOnEntry) then
714 with EntryInfo do
715 FOnEntry(self, FCancel);
716 while (HR = S_OK) and not FCancel do
717 begin
718 HR := FindNextEntry;
719 if (HR = S_OK) and Assigned(FOnEntry) then
720 with EntryInfo do
721 FOnEntry(self, FCancel);
722 end;
723 end;
724 FindCloseUrlCache(H);
725end;
726
727function TIECache.CloseFindEntry: BOOL;
728begin
729 if not InitializeWinInet then
730 begin
731 Result := False;
732 Exit;
733 end;
734 Result := FindCloseUrlCache(H);
735end;
736
737procedure TIECache.SetFilterOptions(const Value: TFilterOptions);
738begin
739 FFilterOptions := Value;
740 UpdateFilterOptionValue;
741end;
742
743procedure TIECache.UpdateFilterOptionValue;
744const
745 AcardFilterOptionValues: array[TFilterOption] of Cardinal = (
746 $00000001, $00000002, $00000004, $00100000, $00200000,
747 $00000010, $00000020, $00010000, $00020000);
748var
749 i: TFilterOption;
750begin
751 FFilterOptionValue := 0;
752 if (FFilterOptions <> []) then
753 for i := Low(TFilterOption) to High(TFilterOption) do
754 if (i in FFilterOptions) then
755 Inc(FFilterOptionValue, AcardFilterOptionValues[i]);
756end;
757
758initialization
759 wininetLibFound := InitializeWinInet;
760
761end.
Note: See TracBrowser for help on using the repository browser.