use strict;
use lib qw(.);
use CGI;
use CGI::Cookie;
my $cgi = new CGI;
my $op = $cgi->param('op');
$main::cookie_name = $cgi->param('cookie_name');
$main::full_url = $ENV{SERVER_URL} . $ENV{SCRIPT_NAME};
$main::domain = $cgi->param('domain');
$main::path = $cgi->param('path');
$main::cookie_value = $cgi->param('cookie_value');
$main::domain ||= '.mybc.com';
$main::path ||= '/';
$main::cookie_value ||= 'na';
#$main::domain = $ENV{HTTP_HOST};
#($main::path) = ($ENV{SCRIPT_NAME} =~ m|(.*)/[^/]+$|);
$main::cookie = $cgi->cookie($main::cookie_name);
#$op='rm';$main::cookie=1;
set_cookie($cgi) if ($op eq 'set');
remove_cookie($cgi) if ($op eq 'rm');
%main::cookies = fetch CGI::Cookie;
my ($html_cookie_table, $html_cookie_select);
parse_all_cookies({
html_table => \$html_cookie_table,
html_select => \$html_cookie_select,
});
print $cgi->header();
print qq|
Cookie Test
Cookie set/remove test.
$html_cookie_table
|;
exit;
##
## SUBS
##
sub set_cookie {
my $cgi = shift;
unless ($main::cookie) {
$main::cookie = $cgi->cookie(
-name => $main::cookie_name,
-value => $main::cookie_value,
-expires=> '+1h',
-path => $main::path,
-domain => $main::domain,
);
print CGI::redirect(-location => $main::full_url, -cookie => [$main::cookie]);
exit;
}
}
sub remove_cookie {
my $cgi = shift;
$DB::single = 1;
if ($main::cookie) {
my $cookie = $cgi->cookie(
-name => $main::cookie_name,
-value => 1, # also this one can't be 0 or undef!
# Setting expires to 'now' doesn't quite work.
# I have to hit the 'Remove Cookie' button
# 2/3 times (# of remove attempts) to actually
# remove the cookie.
# -expires => 'now',
# however, this works well all the time.
# what's the trick?
-expires=> 1,
-path => $main::path,
-domain => $main::domain,
);
# print $cgi->header();
# print qq|
#