Simple Perl Cookies Example

Clearing cookies

#!/usr/bin/perl
# cookies.cgi
# a simple cookies example

# constants
$CRLF = "\x0d\x0a";
$servername = $ENV{'SERVER_NAME'};  # this server
$scriptname = $ENV{'SCRIPT_NAME'};  # this program's URI
$callback = "http://$servername$scriptname";  # how to call back

# date fmt: Wdy, DD-Mon-YYYY HH:MM:SS GMT
$expdate = "Mon, 01-Jan-1990 00:00:00 GMT";

# get the query vars, if any
%query = getquery();

# if there's no data, assume this is the first iteration
$state = 'first' unless %query;

# make variables from query hash
while(($qname, $qvalue) = each %query) 
  { $$qname = $qvalue; }

parsecookies();

# need this at the top of all CGI progs
print "Content-type: text/html$CRLF$CRLF";

# the main jump table
if    ($state eq 'first'   )  { first()     }
elsif ($state eq 'setcookie') { setcookie() }
else                          { unknown()   }

exit;

# STATE SCREENS
sub first
{
$cc = $ENV{HTTP_COOKIE};
htmlp("first.htmlp");
}
sub setcookie
{
if ($cookie && $value) { htmlp("set-read-cookies.jspp") }
else { htmlp("notset-read-cookies.jspp") }
}
sub unknown{
htmlp("unk.htmlp");
}
# UTILITY ROUTINES

# parsecookies
# parse the cookie string from the browser
# and set new ones, if necessary
sub parsecookies
{
$clientcookie = $ENV{HTTP_COOKIE};
$cookiestring = <<COOKIES if $clientcookie;
<p> You have a cookie header!</p>

<blockquote>$clientcookie</blockquote>

COOKIES
if ($cookie) {
  $value = "x; expires=$expdate" unless $value;
  print "Set-cookie: $cookie=$value$CRLF"; 
  }
}

# getquery
# returns hash of CGI query strings
sub getquery
{
my $method = $ENV{'REQUEST_METHOD'};
my ($query_string, $pair);
my %query_hash;

$query_string = $ENV{'QUERY_STRING'} if $method eq 'GET';
$query_string = <STDIN> if $method eq 'POST';
return undef unless $query_string;

foreach $pair (split(/&/, $query_string)) {
  $pair =~ s/\+/ /g;
  $pair =~ s/%([\da-f]{2})/pack('c',hex($1))/ieg;
  ($_qsname, $_qsvalue) = split(/=/, $pair);
  $query_hash{$_qsname} = $_qsvalue;
  }
return %query_hash;
}

# printvars
# diagnostic to print the environment and CGI variables
sub printvars
{
print "<p>Environment:<br>\n";
foreach $e (sort keys %ENV) {
  print "<br><tt>$e => $ENV{$e}</tt>\n";
  }

print "<p>Form Vars:<br>\n";
foreach $name (sort keys %query) {
  print "<br><tt>$name => [$query{$name}]</tt>\n"; }
}
sub htmlp{
local $filename = shift;
my $fhstring = $filename;
$fhstring =~ s/[^a-z]//i;
unless (-f $filename) {
  print qq(<h1>Error: </h1>\n);
  print qq(<p><em>htmlp</em> can't find "$filename"</p>\n);
  return "";
  }
open($fhstring, "<$filename");

while(<$fhstring>) {

  #  to execute perl code
  s/$\{(.*?)}/eval($1),""/eg; 

  # $$filename to include another file
  s/$$([\S;]+;?)/htmlp($1)/eg;

  # $variable to include a variable
  s/$(\w+)//eg;

  print;
  }

close $fhstring;
return "";
}