//************************************************************** // * // TIECache * // * // For Delphi 5, 6, 7, 2005, 2006 * // Freeware Component * // by * // Per Lindsų Larsen * // per.lindsoe@larsen.dk * // * // Contributions: * // Christian Lovis for lib dynamic linking * // {christian.lovis@dim.hcuge.ch] * // Eran Bodankin (bsalsa) bsalsa@gmail.com * // - D2005 update * // * // Updated versions: * // http://www.bsalsa.com * //************************************************************** {*******************************************************************************} {LICENSE: THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE. YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS, INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS, AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE. You may use, change or modify the component under 4 conditions: 1. In your website, add a link to "http://www.bsalsa.com" 2. In your application, add credits to "Embedded Web Browser" 3. Mail me (bsalsa@gmail.com) any code change in the unit for the benefit of the other users. 4. Please consider donation in our web site! {*******************************************************************************} unit IECache; interface {$I EWB.inc} uses WinInet, Windows, Messages, SysUtils, Classes, IeConst; type PInternetCacheTimeStamps = ^TInternetCacheTimeStamps; TInternetCacheTimeStamps = record ftExpires: TFileTime; ftLastModified: TFileTime; end; PInternetCacheGroupInfo = ^TInternetCacheGroupInfo; TInternetCacheGroupInfo = record dwGroupSize: DWORD; dwGroupFlags: DWORD; dwGroupType: DWORD; dwDiskUsage: DWORD; dwDiskQuota: DWORD; dwOwnerStorage: array[0..GROUP_OWNER_STORAGE_SIZE - 1] of DWORD; szGroupName: array[0..GROUPNAME_MAX_LENGTH - 1] of AnsiChar; end; TEntryInfo = record SourceUrlName: string; LocalFileName: string; EntryType: DWORD; UseCount: DWORD; HitRate: DWORD; FSize: DWORD; LastModifiedTime: TDateTime; ExpireTime: TDateTime; LastAccessTime: TDateTime; LastSyncTime: TDateTime; HeaderInfo: string; FileExtension: string; ExemptDelta: DWORD; end; TGroupInfo = record DiskUsage: DWORD; DiskQuota: DWORD; OwnerStorage: array[0..GROUP_OWNER_STORAGE_SIZE - 1] of DWORD; GroupName: string; end; TContent = record Buffer: Pointer; BufferLength: Integer; end; TFilterOption = (NORMAL_ENTRY, STABLE_ENTRY, STICKY_ENTRY, COOKIE_ENTRY, URLHISTORY_ENTRY, TRACK_OFFLINE_ENTRY, TRACK_ONLINE_ENTRY, SPARSE_ENTRY, OCX_ENTRY); TFilterOptions = set of TFilterOption; TOnEntryEvent = procedure(Sender: TObject; var Cancel: Boolean) of object; TOnGroupEvent = procedure(Sender: TObject; GroupID: GROUPID; var Cancel: Boolean) of object; TSearchPattern = (spAll, spCookies, spHistory, spUrl); TIECache = class(TComponent) private FSearchPattern: TSearchPattern; FOnEntry: TOnEntryEvent; FOnGroup: TOnGroupEvent; GrpHandle: THandle; H: THandle; FCancel: Boolean; FFilterOptions: TFilterOptions; FFilterOptionValue: Cardinal; procedure SetFilterOptions(const Value: TFilterOptions); procedure UpdateFilterOptionValue; procedure GetEntryValues(Info: PInternetCacheEntryInfo); procedure ClearEntryValues; protected { Protected declarations } public GroupInfo: TGroupInfo; EntryInfo: TEntryInfo; Content: TContent; constructor Create(AOwner: TComponent); override; function AddUrlToGroup(GroupID: INT64; URL: string): DWORD; function CloseFindEntry: BOOL; function CopyFileToCache(URL, FileName: string; CacheType: DWORD; Expire: TDateTime): DWORD; // function CopyFileToCache(UrlName, FileName: Pchar): string; function CreateEntry(URL, FileExtension: string; ExpectedFileSize: DWORD; var FName: string): DWORD; function CreateGroup: INT64; function DeleteEntry(URL: string): DWORD; function DeleteGroup(GroupID: INT64): DWORD; function FindFirstEntry(GroupID: INT64): DWORD; function FindFirstGroup(var GroupID: Int64): DWORD; function FindNextEntry: DWORD; function FindNextGroup(var GroupID: Int64): BOOL; function GetEntryContent(URL: string): DWORD; function GetEntryInfo(URL: string): DWORD; function GetGroupInfo(GroupID: INT64): DWORD; function getLibraryFound: Boolean; function RemoveUrlFromGroup(GroupID: INT64; URL: string): DWORD; function RetrieveGroups: DWORD; function SetEntryInfo(URL: string): DWORD; function SetGroupInfo(GroupID: INT64): DWORD; procedure ClearAllEntries; procedure RetrieveEntries(GroupID: INT64); { Public declarations } published property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions; property LibraryFound: Boolean read getLibraryFound; property OnEntry: TOnEntryEvent read FOnEntry write FOnEntry; property OnGroup: TOnGroupEvent read FOnGroup write FOnGroup; property SearchPattern: TSearchpattern read FSearchpattern write FSearchPattern; { Published declarations } end; implementation type TFindFirstUrlCacheGroup = function(dwFlags, dwFilter: DWORD; lpSearchCondition: Pointer; dwSearchCondition: DWORD; var Group: Int64; lpReserved: Pointer): THandle; stdcall; TFindNextUrlCacheGroup = function(hFind: THandle; var GroupID: Int64; lpReserved: Pointer): BOOL; stdcall; TSetUrlCacheGroupAttribute = function(gid: Int64; dwFlags, dwAttributes: DWORD; var lpGroupInfo: TInternetCacheGroupInfo; lpReserved: Pointer): BOOL; stdcall; TGetUrlCacheGroupAttribute = function(gid: Int64; dwFlags, dwAttributes: DWORD; var GroupInfo: TInternetCacheGroupInfo; var dwGroupInfo: DWORD; lpReserved: Pointer): BOOL; stdcall; var FindFirstUrlCacheGroup: tFindFirstUrlCacheGroup; FindNextUrlCacheGroup: tFindNextUrlCacheGroup; GetUrlCacheGroupAttribute: tGetUrlCacheGroupAttribute; SetUrlCacheGroupAttribute: tSetUrlCacheGroupAttribute; winInetLibFound: Boolean; const winetdll = 'wininet.dll'; //====Accessories=============================================================== function InitializeWinInet: Boolean; var fPointer: tFarProc; hInst: tHandle; begin if winInetLibFound then Result := true else begin Result := False; hInst := loadLibrary(winetdll); if hInst > 0 then try fPointer := getProcAddress(hInst, 'FindFirstUrlCacheGroup'); if fPointer <> nil then begin FindFirstUrlCacheGroup := tFindFirstUrlCacheGroup(fPointer); fPointer := getProcAddress(hInst, 'FindNextUrlCacheGroup'); if fPointer <> nil then begin FindNextUrlCacheGroup := tFindNextUrlCacheGroup(fPointer); fPointer := getProcAddress(hInst, 'GetUrlCacheGroupAttributeA'); if fPointer <> nil then begin GetUrlCacheGroupAttribute := tGetUrlCacheGroupAttribute(fPointer); fPointer := getProcAddress(hInst, 'SetUrlCacheGroupAttributeA'); if fPointer <> nil then begin SetUrlCacheGroupAttribute := tSetUrlCacheGroupAttribute(fPointer); fPointer := getProcAddress(hInst, 'FindFirstUrlCacheEntryExA'); if fPointer <> nil then Result := true; end; // SetUrlCacheGroupAttribute end; // GetUrlCacheGroupAttribute end; // FindNextUrlCacheGroup end; // FindFirstUrlCacheGroup except end; // loadLib winInetLibFound := Result; end; end; function FileTimeToDateTime(Ft: TFileTime): TDateTime; var St: TSystemTime; lft: TFileTime; begin Result := 0; try if FileTimeToLocalFiletime(Ft, lft) then if FileTimeToSyStemTime(lft, st) then Result := SystemTimeTODateTime(st); except end; end; function DateTimeToFileTime(Dt: TDateTime): TFileTime; var St: TSystemTime; lft: TFileTime; begin try DateTimeToSystemTime(Dt, ST); if SystemTimeToFileTime(st, lft) then LocalFileTimeToFileTime(lft, Result); except Result.dwLowDateTime := 0; Result.dwHighDateTime := 0; end; end; //====IE Cache================================================================== constructor TIECache.Create(AOwner: TComponent); begin inherited; Content.Buffer := nil; ClearEntryValues; // Identical to URLCACHE_FIND_DEFAULT_FILTER FFilterOptions := [NORMAL_ENTRY, COOKIE_ENTRY, URLHISTORY_ENTRY, TRACK_OFFLINE_ENTRY, TRACK_ONLINE_ENTRY, STICKY_ENTRY]; end; function TIECache.getLibraryFound: Boolean; begin Result := InitializeWinInet; end; function TIECache.RemoveUrlFromGroup(GroupID: INT64; URL: string): DWORD; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; if not SetUrlCacheEntryGroup(Pchar(URL), INTERNET_CACHE_GROUP_REMOVE, GroupID, nil, 0, nil) then Result := GetLastError; end; function TIECache.AddUrlToGroup(GroupID: INT64; URL: string): DWORD; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; if not SetUrlCacheEntryGroup(Pchar(URL), INTERNET_CACHE_GROUP_ADD, GroupID, nil, 0, nil) then Result := GetLastError; end; function TIECache.CopyFileToCache(URL, FileName: string; CacheType: DWORD; Expire: TDateTime): DWORD; var FName: string; Ext: string; F: file of Byte; Size: DWORD; begin if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; if not FileExists(FileName) then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; AssignFile(F, FileName); Reset(F); Size := FileSize(F); CloseFile(F); Ext := ExtractFileExt(FileName); Ext := Copy(Ext, 2, Length(ext)); Result := CreateEntry(URL, Ext, Size, FName); if Result <> S_OK then Exit; if not windows.copyfile(PChar(FileName), Pchar(FName), False) then begin Result := GetLastError; Exit; end; if not CommitUrlCacheEntry(Pchar(URL), Pchar(Fname), DateTimeToFileTime(Expire), DateTimeToFileTime(now), CacheType, nil, 0, Pchar(Ext), 0) then Result := GetLastError; end; function TIECache.CreateEntry(URL, FileExtension: string; ExpectedFileSize: DWORD; var FName: string): DWORD; var PC: array[0..MAX_PATH] of Char; begin PC := ''; Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; if not CreateUrlCacheEntry(Pchar(URL), ExpectedFileSize, Pchar(FileExtension), PC, 0) then Result := GetLastError else FName := StrPas(PC); end; function TIECache.GetGroupInfo(GroupID: INT64): DWORD; var info: TInternetCacheGroupInfo; dw: DWORD; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; dw := SizeOf(TInternetCacheGroupInfo); if not GetUrlCacheGroupAttribute(GroupID, 0, CACHEGROUP_ATTRIBUTE_GET_ALL, info, dw, nil) then Result := GetLastError else with GroupInfo do begin DiskUsage := info.dwDiskUsage; DiskQuota := info.dwDiskQuota; Move(info.dwOwnerStorage, OwnerStorage, Sizeof(OwnerStorage)); GroupName := string(info.szGroupName); end; end; function TIECache.SetGroupInfo(GroupID: INT64): DWORD; var info: TInternetCacheGroupInfo; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; info.dwGroupSize := SizeOf(Info); info.dwGroupFlags := CACHEGROUP_FLAG_NONPURGEABLE; info.dwGroupType := CACHEGROUP_TYPE_INVALID; info.dwDiskQuota := GroupInfo.DiskQuota; move(GroupInfo.OwnerStorage, info.dwOwnerStorage, Sizeof(info.dwOwnerStorage)); move(GroupInfo.Groupname[1], info.szGroupName[0], length(GroupInfo.Groupname)); if not SetUrlCacheGroupAttribute(GroupID, 0, CACHEGROUP_READWRITE_MASK, info, nil) then Result := GetLastError; end; function TIECache.CreateGroup: INT64; begin if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; Result := CreateUrlCacheGroup(0, nil); end; function TIECache.DeleteGroup(GroupID: INT64): DWORD; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; if not DeleteUrlCacheGroup(GroupID, CACHEGROUP_FLAG_FLUSHURL_ONDELETE, nil) then Result := GetLastError; end; function TIECache.SetEntryInfo(URL: string): DWORD; var Info: TInternetCacheEntryInfo; FC: DWORD; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; FC := CACHE_ENTRY_ATTRIBUTE_FC + CACHE_ENTRY_HITRATE_FC + CACHE_ENTRY_MODTIME_FC + CACHE_ENTRY_EXPTIME_FC + CACHE_ENTRY_ACCTIME_FC + CACHE_ENTRY_SYNCTIME_FC + CACHE_ENTRY_EXEMPT_DELTA_FC; with Info do begin CacheEntryType := EntryInfo.EntryType; dwHitRate := EntryInfo.HitRate; LastModifiedTime := DateTimeToFileTime(EntryInfo.LastModifiedTime); ExpireTime := DateTimeToFileTime(EntryInfo.ExpireTime); LastAccessTime := DateTimeToFileTime(EntryInfo.LastAccessTime); LastSyncTime := DateTimeToFileTime(EntryInfo.LastSyncTime); dwReserved := EntryInfo.ExemptDelta; end; if not SetUrlCacheEntryInfo(Pchar(URL), Info, FC) then Result := GetLastError; end; function TIECache.GetEntryInfo(URL: string): DWORD; var D: DWORD; T: PInternetCacheEntryInfo; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; if (D <= 0) or (not GetUrlCacheEntryInfoEx(Pchar(URL), nil, @D, nil, nil, nil, 0)) then begin // (PChar(SysErrorMessage(GetLastError))); // https objects are not stored in cache Result := GetLastError(); end else begin GetMem(T, D); try if GetUrlCacheEntryInfoEx(Pchar(URL), T, @D, nil, nil, nil, 0) then GetEntryValues(t) else Result := GetLastError; finally FreeMem(T, D); end; end; end; function TIECache.GetEntryContent(URL: string): DWORD; var HR: THandle; D: Cardinal; T: PInternetCacheEntryInfo; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; D := 0; T := nil; RetrieveUrlCacheEntryStream(PChar(URL), T^, D, TRUE, 0); Getmem(T, D); try HR := THandle(RetrieveUrlCacheEntryStream(PChar(URL), T^, D, TRUE, 0)); if HR <> 0 then begin Content.BufferLength := T^.dwSizeLow + 1; GetEntryValues(T); Getmem(Content.Buffer, Content.BufferLength); Fillchar(Content.Buffer^, Content.BufferLength, #0); if not ReadUrlCacheEntryStream(Hr, 0, Content.Buffer, T^.DwSizeLow, 0) then Result := GetLastError; end; finally FreeMem(T, D); end; UnLockUrlCacheEntryStream(HR, 0); end; function TIECache.FindNextGroup(var GroupID: Int64): BOOL; begin if not InitializeWinInet then begin Result := False; Exit; end; Result := FindNextUrlCacheGroup(GrpHandle, GroupID, nil); GetGroupInfo(GroupID); end; function TIECache.FindFirstGroup(var GroupID: Int64): DWORD; begin if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; GrpHandle := FindFirstUrlCacheGroup(0, 0, nil, 0, GroupID, nil); if GrpHandle <> 0 then Result := S_OK else Result := GetLastError; if Result = S_OK then GetGroupInfo(GroupID); end; function TIECache.RetrieveGroups: DWORD; var GroupID: INT64; Res: DWORD; NewGroup, Cancel: Boolean; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; Cancel := False; NewGroup := True; Res := FindFirstGroup(GroupID); if Res = S_OK then begin GetGroupInfo(GroupID); if Assigned(FOngroup) then FOnGroup(self, GroupID, FCancel); while not Cancel and NewGroup do begin NewGroup := FindNextGroup(GroupID); GetGroupInfo(GroupID); if Assigned(FOngroup) and NewGroup then FOnGroup(self, GroupID, Cancel); end; end else Result := GetLastError; end; function TIECache.DeleteEntry(URL: string): DWORD; begin Result := S_OK; if not InitializeWinInet then Exit; if not DeleteUrlCacheEntry(PChar(URL)) then Result := GetLastError else ClearEntryValues; end; procedure TIECache.ClearAllEntries; var HR: DWord; begin if not InitializeWinInet then Exit; if FindFirstEntry(0) = S_OK then begin repeat DeleteEntry(EntryInfo.SourceUrlName); HR := FindNextEntry; until HR = ERROR_NO_MORE_ITEMS; end; FindCloseUrlCache(H); end; procedure TIECache.ClearEntryValues; begin if not InitializeWinInet then Exit; Content.Buffer := nil; Content.BufferLength := 0; with EntryInfo do begin SourceUrlName := ''; LocalFileName := ''; EntryType := 0; UseCount := 0; Hitrate := 0; LastModifiedTime := 0; ExpireTime := 0; LastAccessTime := 0; LastSyncTime := 0; FileExtension := ''; FSize := 0; HeaderInfo := ''; ExemptDelta := 0; end; end; procedure TIECache.GetEntryValues(Info: PInternetCacheEntryInfo); begin if not InitializeWinInet then Exit; with entryInfo do begin SourceUrlName := info^.lpszSourceUrlName; LocalFileName := info^.lpszLocalFileName; EntryType := info^.CacheEntryType; UseCount := info^.dwUseCount; Hitrate := info^.dwHitRate; LastModifiedTime := FileTimeToDateTime(info^.LastModifiedTime); ExpireTime := FileTimeToDateTime(info^.ExpireTime); LastAccessTime := FileTimeToDateTime(info^.LastAccessTime); LastSyncTime := FileTimeToDateTime(info^.LastSyncTime); FileExtension := info^.lpszFileExtension; FSize := (info^.dwSizeHigh shl 32) + info^.dwSizeLow; HeaderInfo := StrPas(PChar(info^.lpHeaderInfo)); ExemptDelta := info^.dwReserved; end; end; function TIECache.FindFirstEntry(GroupID: INT64): DWORD; const Pattern: array[TSearchPattern] of PChar = (nil, 'Cookie:', 'Visited:', ''); var T: PInternetCacheEntryInfo; D: DWORD; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; H := 0; D := 0; FindFirstUrlCacheEntryEx(Pattern[SearchPattern], 0, FFilterOptionValue, GroupID, nil, @D, nil, nil, nil); GetMem(T, D); try H := FindFirstUrlCacheEntryEx(Pattern[SearchPattern], 0, FFilterOptionValue, GroupID, T, @D, nil, nil, nil); if (H = 0) then Result := GetLastError else GetEntryValues(T); finally FreeMem(T, D) end; end; function TIECache.FindNextEntry: DWORD; var T: PInternetCacheEntryInfo; D: DWORD; begin Result := S_OK; if not InitializeWinInet then begin Result := ERROR_FILE_NOT_FOUND; Exit; end; D := 0; FindNextUrlCacheEntryEx(H, nil, @D, nil, nil, nil); GetMem(T, D); try if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil) then Result := GetLastError else GetEntryValues(T); finally FreeMem(T, D) end; end; procedure TIECache.RetrieveEntries(GroupID: INT64); var HR: DWORD; begin if not InitializeWinInet then Exit; FCancel := False; HR := FindFirstEntry(GroupID); if (HR = S_OK) then begin if Assigned(FOnEntry) then with EntryInfo do FOnEntry(self, FCancel); while (HR = S_OK) and not FCancel do begin HR := FindNextEntry; if (HR = S_OK) and Assigned(FOnEntry) then with EntryInfo do FOnEntry(self, FCancel); end; end; FindCloseUrlCache(H); end; function TIECache.CloseFindEntry: BOOL; begin if not InitializeWinInet then begin Result := False; Exit; end; Result := FindCloseUrlCache(H); end; procedure TIECache.SetFilterOptions(const Value: TFilterOptions); begin FFilterOptions := Value; UpdateFilterOptionValue; end; procedure TIECache.UpdateFilterOptionValue; const AcardFilterOptionValues: array[TFilterOption] of Cardinal = ( $00000001, $00000002, $00000004, $00100000, $00200000, $00000010, $00000020, $00010000, $00020000); var i: TFilterOption; begin FFilterOptionValue := 0; if (FFilterOptions <> []) then for i := Low(TFilterOption) to High(TFilterOption) do if (i in FFilterOptions) then Inc(FFilterOptionValue, AcardFilterOptionValues[i]); end; initialization wininetLibFound := InitializeWinInet; end.