DelphiLab - Куки в Delphi

Куки в Delphi

Статьи - Статьи

Написал aktuba

03.07.2007

Недавно понадобилось удалять куки, при использовании SwinHTTP, производства Snowy (создателя сайта). Т.к. SwinHTTP работает через WinInet, это оказалось не так-то просто. Перерыл весь инет - мало чего нашел =(. Пришлось создавать небольшой модуль, который и представляю Вашему вниманию.

Модуль писался на коленке, т.к. времени было в обрез. Много лишнего, много не хватает, но думаю, кому надо - сам все поправит =).

 
unit uCookies;
 
interface
 
procedure AddCookie(const AUrl, AName, AValue: string);
procedure DeleteCookies(const AHost: string);
 
implementation
 
uses
  Classes,
  WinInet;
 
type
  PCookieItem = ^TCookieItem;
  TCookieItem = record
    Name: string;
    Source: string;
  end;
 
  TCookieList = class
  private
    List: TList;
    procedure GetEntries;
    procedure GetEntry(lpEntryInfo: PInternetCacheEntryInfo);
  public
    constructor Create;
    destructor Destroy; override;
 
    procedure Delete(const AUrl: string);
    procedure Clear;
  end;
 
procedure AddCookie(const AUrl, AName, AValue: string);
begin
  InternetSetCookie(PChar(AUrl), PChar(AName), PChar(AValue));
end;
 
procedure DeleteCookies(const AHost: string);
var
  Idx: Integer;
  lUrl: string;
  li: Integer;
  lList: TCookieList;
begin
  lUrl := '';
  lList := TCookieList.Create;
  try
    Idx := Length(AHost);
    lUrl := '';
    li := 0;
    while (Idx > 0) do
      begin
        if AHost[Idx] = '.' then
          begin
            Inc(li);
            if li > 1 then
              begin
                lUrl := Copy(AHost, Idx + 1, Length(AHost) - Idx);
                lList.Delete(lUrl);
                lUrl := '';
              end;
          end;
        Dec(Idx);
      end;
    lList.Delete(AHost);
  finally
    lList.Free;
    lUrl := '';
  end;
end;
 
{ TCookieList }
 
procedure TCookieList.GetEntry(lpEntryInfo: PInternetCacheEntryInfo);
var
  S: string;
  lItem: PCookieItem;
begin
  S := '';
  try
    S := Copy(lpEntryInfo^.lpszSourceUrlName,
      Pos('@', lpEntryInfo^.lpszSourceUrlName) + 1, 255);
    if (S[Length(S)] = '/') or (S[Length(S)] = '\') then
      S := Copy(S, 1, Length(S) - 1);
    New(lItem);
    lItem^.Name := Copy(S, 1, Length(S));
    lItem^.Source := Copy(lpEntryInfo^.lpszSourceUrlName, 1, Length(lpEntryInfo^.lpszSourceUrlName));
    List.Add(lItem);
  finally
    S := '';
  end;
end;
 
procedure TCookieList.GetEntries;
var
  lpEntryInfo: PInternetCacheEntryInfo;
  hHistoryDir: LongWord;
  dwEntrySize: LongWord;
  dwLastError: LongWord;
begin
  dwEntrySize := 0;
  FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
  New(lpEntryInfo);
  try
    hHistoryDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
    if (hHistoryDir <> 0) then
      if lpEntryInfo^.CacheEntryType = (lpEntryInfo^.CacheEntryType or COOKIE_CACHE_ENTRY) then
        GetEntry(lpEntryInfo);
  finally
    lpEntryInfo.lpszSourceUrlName := '';
    lpEntryInfo.lpszLocalFileName := '';
    lpEntryInfo.lpszFileExtension := '';
    Dispose(lpEntryInfo);
  end;
 
  repeat
    dwEntrySize := 0;
    FindNextUrlCacheEntry(hHistoryDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
    dwLastError := GetLastError();
 
    if (GetLastError = 122) then
    begin
      New(lpEntryInfo);
      try
        if (FindNextUrlCacheEntry(hHistoryDir, lpEntryInfo^, dwEntrySize)) then
          if (lpEntryInfo^.CacheEntryType = (lpEntryInfo^.CacheEntryType or COOKIE_CACHE_ENTRY)) then
            GetEntry(lpEntryInfo);
      finally
        lpEntryInfo.lpszSourceUrlName := '';
        lpEntryInfo.lpszLocalFileName := '';
        lpEntryInfo.lpszFileExtension := '';
        Dispose(lpEntryInfo);
      end;
    end;
  until ((dwLastError = 259) or (dwLastError = 87));
end;
 
procedure TCookieList.Clear;
var
  lItem: PCookieItem;
begin
  while List.Count > 0 do
    begin
      lItem := PCookieItem(List[0]);
      lItem^.Name := '';
      lItem^.Source := '';
      Dispose(lItem);
      List.Delete(0);
    end;
  List.Clear;
end;
 
constructor TCookieList.Create;
begin
  List := TList.Create;
  GetEntries;
end;
 
procedure TCookieList.Delete(const AUrl: string);
var
  Idx: Integer;
  lItem: PCookieItem;
  src: string;
begin
  src := '';
  try
    for Idx := 0 to List.Count - 1 do
      begin
        lItem := List[Idx];
        if lItem^.Name = AUrl then
          begin
            src := lItem^.Source;
            Break;
          end;  
      end;
    if src <> '' then
      begin
        DeleteUrlCacheEntry(PChar(src));
        src := '';
        Clear;
        GetEntries;
      end;
  finally
    src := '';
  end;
end;  
 
destructor TCookieList.Destroy;
begin
  Clear;
  List.Free;
  inherited;
end;
 
end.

P.S.: при вызове функции DeleteCookies, в параметры необходимо передавать хост, например для адреса http://www.delphilab.ru/index.php необходимо передавать delphilab.ru. При использовании SwinHTTP можно делать "финт ушами" =):

SwinHttp.Request.url.url := 'http://www.delphilab.ru/index.php';
DeleteCookies(SwinHttp.Request.url.Host);

опубликовано

Добавить новый

Поиск

Snowy

2008-03-07 13:56:42

За всё время использования этого примера разными людьми, это первый отзыв о том, что он не рабочий.
Без фактов, что-то сомневаюсь в данном утверждении.

Цитата

pupkin

2008-03-14 13:00:29

XP (Professional) SP2
Delphi 7.
IE 6.0.2900.2180 xpsp_sp2_gdr 070227-2254

При создании TCookieList вылетает ексцепшен:
---------------------------
Debugger Fault Notification
---------------------------
Project C:\Program Files\Borland\Delphi7\Projects\uCookies\Project1.exe faulted with message: 'access violation at 0x00405961: write of address 0x00030df4'. Process Stopped. Use Step or Run to continue.
---------------------------
OK
---------------------------

:huh:

Цитата

pupkin

2008-03-12 11:38:21

Цитата

pupkin

2008-03-18 11:31:32

Так что, кто-нибудь ещё проверит у себя этот пример?
Это займёт 3-и минуты от силы.. :dry:

У меня факты на лицо и мне нечего от себя добавить. :unsure:

Возможно, какая-то конфигурация влияет на работоспособность этого примера.

Цитата

Илья	2008-04-18 14:49:41

Проверил, дельфа 2007, виста (без сп1), ие8. Тоже вылетает АВ.

Цитата

Биг Бэд Мутух

2008-04-24 16:58:02

Все New(lpEntryInfo) надо заменить на
lpEntryInfo := AllocMem(dwEntrySize
);
а Dispose желательно на FreeMem

гыыыы

Цитата

Andrew

2008-08-06 09:52:00

Не пашет всё равно...

Расскажите плиз как заставить работать...

Цитата

Copernik - re:

2008-08-10 23:33:39

Andrew написано:

Не пашет всё равно...

Расскажите плиз как заставить работать...

procedure TCookieList. GetEntry(lpEntryInfo
: PInternetCacheEntryI
nfo);
var
S: string;
lItem: PCookieItem;
begin
S := '';
try
S := Copy(lpEntryInfo^. lpszSourceUrlName,Po
s('@', lpEntryInfo^.lpszSourceUrlName) + 1, 255);
if length(s)>0 then
if (S[Length(S)] = '/') or (S[Length(S)] = '\') then
S := Copy(S, 1, Length(S) - 1);
new(lItem);
lItem^.Name := Copy(S, 1, Length(S));
lItem^.Source := Copy(lpEntryInfo^.lpszSourceUrlName, 1, Length(lpEntryInfo^. lpszSourceUrlName));

List.Add(lItem);
finally
S := '';
end;
end;

procedure TCookieList.GetEntries;
var
lpEntryInfo: PInternetCacheEntryI
nfo;
hHistoryDir: LongWord;
dwEntrySize: LongWord;
dwLastError: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEnt
ry(nil, TInternetCacheEntryI
nfo(nil^), dwEntrySize);
lpEntryInfo := AllocMem(dwEntrySize
);
try
hHistoryDir := FindF...

Цитата

Copernik

2008-08-10 23:48:30

hHistoryDir := FindFirstUrlCacheEnt
ry(nil, lpEntryInfo^, dwEntrySize);
if (hHistoryDir 0) then
if lpEntryInfo^.CacheEntryType = (lpEntryInfo^.CacheEntryType or COOKIE_CACHE_ENTRY) then
GetEntry(lpEntryInfo
);
finally
lpEntryInfo.lpszSourceUrlName := '';
lpEntryInfo.lpszLocalFileName := '';
lpEntryInfo.lpszFileExtension := '';
freemem(lpEntryInfo)
;
end;

repeat
dwEntrySize := 0;
FindNextUrlCacheEntr
y(hHistoryDir, TInternetCacheEntryI
nfo(nil^), dwEntrySize);
dwLastError := GetLastError();

if (GetLastError = 122) then
begin
lpEntryInfo := AllocMem(dwEntrySize
);
try
if (FindNextUrlCacheEnt
ry(hHistoryDir, lpEntryInfo^, dwEntrySize)) then
if (lpEntryInfo^.CacheEntryType = (lpEntryInfo^.CacheEntryType or COOKIE_CACHE_ENTRY))
then
GetEntry(lpEntryInfo
);
finally
lpEntryInfo.lpszSourceUrlName := '';
lpEntryInfo.lpszLocalFileName := '';
lpEntryInfo....

Цитата