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);

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

Поиск

pupkin

2008-03-06 16:50:18

Кстати, пример не рабочий. :dry: