Copyright © 1996-1999 Rex Swain
Email rex@rexswain.com,
Web
http://www.rexswain.com
Permission granted to distribute unmodified copies
Reports of errors or omissions appreciated
#!/usr/bin/perl -w
# COOKIE.CGI
# Demonstrate a Cookie
# 18 Aug 1996 Rex Swain, Independent Consultant, rex@rexswain.com
# 23 Nov 1999 Pushed "future" date into 2002
# 30 Aug 2004 Pushed "future" date into 2007 [thanks Rick!]
# 22 Apr 2009 Pushed "future" date into 2012 [thanks Dennis!]
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
### Start HTTP header
print "Content-type: text/html; charset=iso-8859-1\n"; # note just one LF
### What does argument say to do?
if (exists $ENV{'QUERY_STRING'}) {
$q = $ENV{'QUERY_STRING'};
$create = $q eq 'create';
$update = $q eq 'update';
$delete = $q eq 'delete';
}
else {
$create = 0;
$update = 0;
$delete = 0;
}
# Query is implied if no or unanticipated argument
if ($create || $update || $delete) { $query = 0; }
else { $query = 1; }
if ($create) { $action = 'create'; }
elsif ($update) { $action = 'update'; }
elsif ($delete) { $action = 'delete'; }
else { $action = 'query' ; }
### Create, update, or delete the cookie
$exists = 0; # any cookies?
$cookies = ''; # cookies
$cookie = 0; # our cookie?
$visit = 0; # default counter
if (exists $ENV{'HTTP_COOKIE'}) {
$exists = 1;
$cookies = $ENV{'HTTP_COOKIE'};
@cookies = split(';',$ENV{'HTTP_COOKIE'});
foreach (@cookies) {
($k,$v) = split('=',$_);
$k =~ s/ //g;
if ($k eq 'VISIT') {
$cookie = 1;
$visit = $v;
}
}
}
$newvisit = $visit+1;
if ($create) { $newvisit = 1; }
if ($query) {
$set = '';
}
if ($create || $update) {
$set = "Set-Cookie: " .
"VISIT=$newvisit; " .
"path=/cgi-bin; " .
"expires=Tuesday, 31-Dec-2020 23:12:40 GMT"; # future
}
if ($delete) {
$set = "Set-Cookie: " .
"VISIT=; " .
"path=/cgi-bin; " .
"expires=Wednesday, 03-Jan-1996 23:12:40 GMT"; # past
}
print "$set" , # set cookie
"\n\n"; # end of header
### Start HTML
select(STDOUT); $| = 1; # don't block output
print '<HTML>' ,
'<HEAD>' ,
'<TITLE>Rex Swain\'s HTTP Cookie Demo</TITLE>' ,
'</HEAD>' ,
'<BODY BGCOLOR="#FFFFFF" TEXT="#000000">' ,
"\n";
print '<!-- Google AdSense added 10/08/2003 -->
<TABLE ALIGN=right WIDTH=176 BORDER=0 CELLSPACING=0 CELLPADDING=0>
<TR>
<TD WIDTH=16> </TD>
<TD WIDTH=160>
<script type="text/javascript"><!--
google_ad_client = "pub-7510521706485409";
google_ad_width = 160;
google_ad_height = 600;
google_ad_format = "160x600_as";
google_color_border = "336699";
google_color_bg = "FFFFFF";
google_color_link = "0000FF";
google_color_url = "008000";
google_color_text = "000000";
//--></script>
<script type="text/javascript" src="http://pagead2.googlesyndication.com/pagead/show_ads.js"></script>
</TD></TR></TABLE>
';
print '<CENTER>' ,
'<H1>Rex Swain\'s HTTP Cookie Demo</H1>' ,
'<P>Last updated 23 November 1999</P>' ,
'</CENTER>' ,
'<P><HR></P>' ,
"\n";
# print 'exists=' , $exists , "<BR>\n";
# print 'cookies=' , $cookies , "<BR>\n";
# print 'cookie=' , $cookie , "<BR>\n";
# print 'visit=' , $visit , "<BR>\n";
### What's happening?
if ($exists) { $g = '<TT>' . $ENV{'HTTP_COOKIE'} . '</TT>'; }
else { $g = 'nothing'; }
if ($query) { $s = 'nothing'; }
else { $s = '<TT>' . $set . '</TT>'; }
print '<TABLE CELLSPACING=0 CELLPADDING=0>' ,
'<TR>' ,
'<TD ALIGN=right NOWRAP><STRONG>We asked for:</STRONG></TD>' ,
'<TD><TT> </TT></TD>' ,
'<TD><TT>$ENV{\'HTTP_COOKIE\'}</TT></TD>' ,
'</TR>' ,
'<TR>' ,
'<TD ALIGN=right><STRONG>...and got:</STRONG></TD>' ,
'<TD></TD>' ,
'<TD>' , $g , '</TD>' ,
'</TR>' ,
'<TR>' ,
'<TD COLSPAN=3><STRONG>You asked that we ' , $action , ' the cookie, ' ,
'so...</STRONG></TD>' ,
'</TR>' ,
'<TR>' ,
'<TD ALIGN=right VALIGN=top><STRONG>We sent:</STRONG></TD>' ,
'<TD></TD>' ,
'<TD>' , $s , '</TD>' ,
'</TR>' ,
'</TABLE>' ,
"\n";
unless ($exists) {
print '<P>We did not get any response to our request for cookies, so...' ,
'<UL>' ,
'<LI>Your browser does not support cookies,' ,
'<LI>or you haven\'t created our cookie yet,' ,
'<LI>or you <I>just</I> created our cookie ' ,
'(in which case it will show up the next time you invoke this program),' ,
'<LI>or you deleted our cookie earlier.' ,
'</UL>' ,
"\n";
}
else {
unless ($cookie) {
print '<P>We got some cookies but did not get "our" cookie, so...' ,
'<UL>' ,
'<LI>Your browser supports cookies.' ,
'<LI>You just created our cookie, this is your first visit; or' ,
'<LI>you <I>just</I> deleted our cookie.' ,
'</UL>' ,
"\n";
}
else {
print '<P>We got our cookie, ' ,
'and its value tells us that<UL><LI>You have been here ' ,
'<STRONG>' , $visit , &plural($visit,' time') , '</STRONG> ' ,
'<I>before</I> this time (create and each update count as 1).</UL></P>';
}
}
if ($action eq 'create') {
print '<P>We also created our cookie (set it to 1).</P>';
}
if ($action eq 'update') {
print '<P>We also incremented our cookie (set it to ' , $newvisit , ').</P>';
}
if ($action eq 'delete') {
print '<P>We also deleted our cookie.</P>';
}
$me = '/cgi-bin/cookie.cgi';
print "\n" ,
'<P><HR></P>' ,
'<P>You may ' ,
'<A HREF="' , $me , '">query</A>, ' ,
'<A HREF="' , $me , '?create">create</A>, ' ,
'<A HREF="' , $me , '?update">update</A>, ' ,
'or <A HREF="' , $me , '?delete">delete</A> ' ,
'the cookie.</P>' ,
"\n";
print '<P>Or you may view the ' ,
'<A HREF="/cgi-bin/showsource.cgi' ,
'?file=cookie.cgi">' ,
'source code</A>.</P>' ,
'<P><HR></P>' ,
"\n";
# Author
print '<H3>Other Summaries and Demos</H3>
<UL>
<LI>See my <A HREF="http://www.rexswain.com/">home page</A> for other summaries and demos:
APL, REXX, XEDIT, Perl, HTML, RGB Colors, HTTP Cookies, Email Forms,
CGI Environment Variables, Server Side Includes, etc...
</UL>
';
print '<CENTER><HR SIZE=1>' ,
'You are visitor ',
'<IMG SRC="/cgi-bin/countrex.cgi?cookie"',
'ALIGN=absmiddle WIDTH=90 HEIGHT=20 ALT="[Odometer]"> ' ,
'since 23 August 1996' ,
'<HR SIZE=1><ADDRESS>' ,
'Copyright © 1996-2004 Rex Swain<BR>' ,
'Email <A HREF="mailto:rex@rexswain.com">rex@rexswain.com</A>, ' ,
'Web <A HREF="http://www.rexswain.com/">' ,
'http://www.rexswain.com</A><BR>' ,
'Permission granted to distribute unmodified copies<BR>' ,
'Reports of errors or omissions appreciated' ,
'</ADDRESS></CENTER>' ,
"\n";
### End HTML
print "</BODY></HTML>\n";
exit;
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub plural { # &plural(n,'word'[,'words'])
local ($n,$s,$p) = @_;
unless (defined($p)) { $p = $s . 's'; }
if ($n == 1) { $s; } else { $p; }
}