Howdy -
I'm having some trouble deleting a cookie using CGI::Cookie. Here is the
code I'm using to do this. Note this is in a module, so I have written
wrappers for the CGI::Cookie Set/Get functionality. However, this is test
code, so it's being accessed in it's own namespace. I know that this code
writes cookies. But, I cannot seem to modify the properties of an existing
cookie.
use strict;
use CGI qw/:standard/;
use CGI::Cookie;
my $name = 'Johnny';
my $cookie = GetCookie($name);
if ($cookie)
{
# Set the 'expires' attribute to -1M
$cookie = DeleteCookie($name);
# If the cookie object is returned, print its new properties
if ($cookie)
{
print $h_self{cgi}->header(-cookie=>$cookie);
print qq[Just set the cookie to be deleted. These are the
properties:<br />];
print "-name is ". $cookie->name ."<br />";
print "-value is ". $cookie->value ."<br />";
print "-expires is ". $cookie->expires ."<br />";
print "-path is ". $cookie->path ."<br />";
print "-domain is ". $cookie->domain ."<br />";
print "-secure is ". $cookie->secure ."<br />";
print qq[Close the browser and look in the cookies folder<br />];
}
# If the cookie was not returned, there was a problem.
else
{
print $h_self{cgi}->header;
print qq[Something has gone completely wrong here!];
}
}
sub GetCookie
{
my ($name) = @_;
my %h_cookies = fetch CGI::Cookie();
(exists $h_cookies{$name})?return $h_cookies{$name}:return 0;
}
sub DeleteCookie
{
my ($name) = @_;
# Get the cookie
my $cookie = GetCookie($name);
# Set the expiration date to delete cookie
$cookie = SetCookieProp($name,'expires','-1M');
($cookie)?return $cookie:return 0;
}
sub SetCookieProp
{
my ($name, $prop, $value) = @_;
# Get the cookie
my $cookie = $hr_self->GetCookie($name);
# Set the named property to the new value
$cookie->$prop($value);
($cookie)?return $cookie:return 0;
}
Ron Goral
Up On The Mountain Design Group
Custom solutions for your database driven web site.
--
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
<http://learn.perl.org/> <http://learn.perl.org/first-response>
