idcookie.pas

delphi indy9.0.18组件包

  result := GetCookie;
end;

{
Cookie: NAME1=OPAQUE_STRING1; NAME2=OPAQUE_STRING2 ...
}
function TIdNetscapeCookie.GetClientCookie: String;
begin
  result := FName + '=' + FValue;    {Do not Localize}
end;

function TIdNetscapeCookie.GetCookie: String;
begin
  result := AddCookieProperty(FName, FValue, '');    {Do not Localize}
  result := AddCookieProperty('path', FPath, result);    {Do not Localize}
  if FInternalVersion = cvNetscape then
  begin
    result := AddCookieProperty('expires', FExpires, result);    {Do not Localize}
  end;

  result := AddCookieProperty('domain', FDomain, result);    {Do not Localize}

  if FSecure then
  begin
    result := AddCookieFlag('secure', result);    {Do not Localize}
  end;
end;

procedure TIdNetscapeCookie.LoadProperties(APropertyList: TStringList);
begin
  FPath :=  APropertyList.values['PATH'];    {Do not Localize}
  // Tomcat can return SetCookie2 with path wrapped in "
  if ( Length(FPath) > 0 ) then
  begin
    if ( FPath[1] = '"' ) then    {Do not Localize}
      Delete(FPath,1,1);
    if ( FPath[Length(FPath)] = '"' ) then    {Do not Localize}
      SetLength(FPath,Length(FPath)-1);
  end;
  Expires := APropertyList.values['EXPIRES'];    {Do not Localize}
  FDomain := APropertyList.values['DOMAIN'];    {Do not Localize}
  FSecure := APropertyList.IndexOf('SECURE') <> -1;    {Do not Localize}
end;

procedure TIdNetscapeCookie.SetCookie(AValue: String);
Var
  i: Integer;
  CookieProp: TStringList;
begin
  if AValue <> FCookieText then
  begin
    FCookieText := AValue;

    CookieProp := TStringList.Create;

    try
      while Pos(';', AValue) > 0 do    {Do not Localize}
      begin
        CookieProp.Add(Trim(Fetch(AValue, ';')));    {Do not Localize}
        if (Pos(';', AValue) = 0) and (Length(AValue) > 0) then CookieProp.Add(Trim(AValue));    {Do not Localize}
      end;

      if CookieProp.Count = 0 then CookieProp.Text := AValue;

      FName := CookieProp.Names[0];
      FValue := CookieProp.Values[CookieProp.Names[0]];
      CookieProp.Delete(0);

      for i := 0 to CookieProp.Count - 1 do
        if Pos('=', CookieProp[i]) = 0 then    {Do not Localize}
        begin
          CookieProp[i] := UpperCase(CookieProp[i]);  // This is for cookie flags (secure)
        end
        else begin
          CookieProp[i] := UpperCase(CookieProp.Names[i]) + '=' + CookieProp.values[CookieProp.Names[i]];    {Do not Localize}
        end;

      LoadProperties(CookieProp);
    finally
      FreeAndNil(CookieProp);
    end;
  end;
end;

{ TIdCookieRFC2109 }

constructor TIdCookieRFC2109.Create(ACollection: TCollection);
begin
  inherited Create(ACollection);
  FMax_Age := GFMaxAge;
  FInternalVersion := cvRFC2109;
end;

procedure TIdCookieRFC2109.SetExpires(AValue: String);
begin
  if Length(AValue) > 0 then
  begin
    try
      // If you see an exception here then that means the HTTP server has returned an invalid expires
      // date/time value. The correct format is Wdy, DD-Mon-YY HH:MM:SS GMT

      // AValue := StringReplace(AValue, '-', ' ', [rfReplaceAll]);    {Do not Localize}
      FMax_Age := Trunc((GMTToLocalDateTime(AValue) - Now) * MSecsPerDay / 1000);
    except end;
  end;
  inherited SetExpires(AValue);
end;

{
   cookie          =       "Cookie:" cookie-version
                           1*((";" | ",") cookie-value)
   cookie-value    =       NAME "=" VALUE [";" path] [";" domain]
   cookie-version  =       "$Version" "=" value
   NAME            =       attr
   VALUE           =       value
   path            =       "$Path" "=" value
   domain          =       "$Domain" "=" value
}

function TIdCookieRFC2109.GetClientCookie: String;
begin
  result := inherited GetClientCookie;

  {if (Length(Version) > 0) and (Length(result) > 0) then
  begin
    result := AddCookieProperty('$Version', '"' + Version + '"', '') + ';' + result;
  end;

  result := AddCookieProperty('$Path', Path, result);
  if IsDomain(Domain) then
  begin
    result := AddCookieProperty('$Domain', Domain, result);
  end;}
end;

{
   set-cookie      =       "Set-Cookie:" cookies
   cookies         =       1#cookie
   cookie          =       NAME "=" VALUE *(";" cookie-av)
   NAME            =       attr
   VALUE           =       value
   cookie-av       =       "Comment" "=" value
                   |       "Domain" "=" value
                   |       "Max-Age" "=" value
                   |       "Path" "=" value
                   |       "Secure"
                   |       "Version" "=" 1*DIGIT
}
function TIdCookieRFC2109.GetCookie: String;
begin
  result := inherited GetCookie;

   if (FMax_Age > -1) and (Length(FExpires) = 0) then
   begin
    result := AddCookieProperty('max-age', IntToStr(FMax_Age), result);    {Do not Localize}
  end;

  result := AddCookieProperty('comment', FComment, result);    {Do not Localize}
  result := AddCookieProperty('version', FVersion, result);    {Do not Localize}
end;

procedure TIdCookieRFC2109.LoadProperties(APropertyList: TStringList);
begin
  inherited LoadProperties(APropertyList);

  FMax_Age := StrToIntDef(APropertyList.values['MAX-AGE'], -1);    {Do not Localize}
  FVersion := APropertyList.values['VERSION'];    {Do not Localize}
  FComment := APropertyList.values['COMMENT'];    {Do not Localize}

  if Length(Expires) = 0 then
  begin
    FInternalVersion := cvNetscape;
    if FMax_Age >= 0 then
    begin
      Expires := DateTimeToInternetStr(Now + FMax_Age * 1000 / MSecsPerDay);
    end;
    // else   Free this cookie
  end;
end;

{ TIdCookieRFC2965 }

constructor TIdCookieRFC2965.Create(ACollection: TCollection);
begin
  inherited Create(ACollection);
  FInternalVersion := cvRFC2965;
end;

function TIdCookieRFC2965.GetCookie: String;
begin
  result := inherited GetCookie;
end;

procedure TIdCookieRFC2965.LoadProperties(APropertyList: TStringList);
Var
  PortListAsString: TStringList;
  i: Integer;
  S: String;
begin
  inherited LoadProperties(APropertyList);

  FCommentURL := APropertyList.values['CommentURL'];    {Do not Localize}
  FDiscard := APropertyList.IndexOf('DISCARD') <> -1;    {Do not Localize}
  PortListAsString := TStringList.Create;

  try
    S := APropertyList.Values['Port'];    {Do not Localize}
    if Length(S) > 0 then
    begin
      if (S[1] = '"') and (S[Length(S)] = '"') then    {Do not Localize}
      begin
        PortListAsString.CommaText := Copy(S, 2, Length(S) - 2);
        if PortListAsString.Count = 0 then
        begin
          PortList[0] := IdPORT_HTTP;
        end
        else begin
          for i := 0 to PortListAsString.Count - 1 do
          begin
            PortList[i] := StrToInt(PortListAsString[i]);
          end;
        end;
      end;
    end
    else begin
      PortList[0] := IdPORT_HTTP;
    end;
  finally
    PortListAsString.Free;
  end;
end;

procedure TIdCookieRFC2965.SetPort(AIndex, AValue: Integer);
begin
  if (AIndex - High(FPortList) > 1) or (AIndex < 0) then
  begin
    raise EIdException.Create('Index out of range.');    {Do not Localize}
  end;
  if AIndex - High(FPortList) = 1 then
  begin
    SetLength(FPortList, AIndex + 1);
  end;
  FPortList[AIndex] := AValue;
end;

function TIdCookieRFC2965.GetPort(AIndex: Integer): Integer;
begin
  if (AIndex > High(FPortList)) or (AIndex < Low(FPortList)) then
  begin
    raise EIdException.Create('Index out of range.');    {Do not Localize}
  end;

  result := FPortList[AIndex];
end;

{ TIdServerCookie }

constructor TIdServerCookie.Create(ACollection: TCollection);
begin
  inherited Create(ACollection);
  FInternalVersion := cvNetscape;
  // Version := '1';    {Do not Localize}
end;

function TIdServerCookie.GetCookie: String;
// Wdy, DD-Mon-YY HH:MM:SS GMT
const
  wdays: array[1..7] of string = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); {do not localize}
  monthnames: array[1..12] of string = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',  {do not localize}
    'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'); {do not localize}
var
  wDay,
  wMonth,
  wYear: Word;
  ANow: TDatetime;
begin
  if FMax_Age > -1 then
  begin
    ANow := Now + TimeZoneBias + FMax_Age / MSecsPerDay * 1000;
    DecodeDate(ANow, wYear, wMonth, wDay);
    FExpires := Format('%s, %d-%s-%d %s GMT',    {do not localize}
                   [wdays[DayOfWeek(ANow)], wDay, monthnames[wMonth],
                    wYear, FormatDateTime('HH":"NN":"SS', ANow)]); {do not localize}
  end;

  result := inherited GetCookie;
end;

procedure TIdServerCookie.AddAttribute(const Attribute, Value: String);
begin
  if UpperCase(Attribute) = '$PATH' then    {Do not Localize}
  begin
    Path := Value;
  end;
  if UpperCase(Attribute) = '$DOMAIN' then    {Do not Localize}
  begin
    Domain := Value;
  end;
end;

{ TIdCookies }

constructor TIdCookies.Create(AOwner: TPersistent);
begin
  inherited Create(AOwner, TIdCookieRFC2109);

  FRWLock := TMultiReadExclusiveWriteSynchronizer.Create;
  FCookieListByDomain := TIdCookieList.Create;
  FCookieListByDomain.Sorted := false;
end;

destructor TIdCookies.Destroy;
var i : Integer;
begin
  // This will force the Cookie removing process before we free the FCookieListByDomain and
  // FRWLock
  Clear;
  for i := 0 to FCookieListByDomain.Count -1 do
  begin
    FCookieListByDomain.Objects[i].Free;
  end;
  FreeAndNil(FCookieListByDomain);
  FreeAndNil(FRWLock);
  inherited Destroy;
end;

 {FLX}
function TIdCookieList.IndexByPathAndName(Const APath, AName : string) : integer;
var i : integer;
begin
   result := -1;
   for i := Count - 1 downto 0 do
   begin
        if (AnsiSametext(Cookies[i].Path, APath)) and (AnsiSameText(Cookies[i].CookieName , AName)) then
    // if (Pos(Cookies[i].Path, APath) = 1) and (AnsiSameText(Cookies[i].CookieName , AName)) then
     begin
        result := i;
        exit;
     end;
   end;
end;

{FLX}

procedure TIdCookies.AddCookie(ACookie: TIdCookieRFC2109);
Var
  LList: TIdCookieList;
  j: Integer;
  LCookiesByDomain : TIdCookieList;
  LCookieList : TIdCookieList; //FLX
begin
  LCookiesByDomain := LockCookieListByDomain(caReadWrite);

  with LCookiesByDomain do try
    if IndexOf(ACookie.Domain + ACookie.path) = -1 then  //FLX
    begin
      LList := TIdCookieList.Create;
      AddObject(ACookie.Domain + ACookie.path , LList);  //FLX
    end;

    //LCookieList : Liste des cookies pour le domaine du cookie
    LCookieList := TIdCookieList(Objects[IndexOf(ACookie.Domain + ACookie.path)]); //FLX

    //recherche pour voir si un cookie existe pour ce nom
    j := LCookieList.IndexOf(ACookie.CookieName);

    //S'il n'y a pas de cookie pour ce nom et ce chemin, on l'ajoute