From 2e56c87d916da7541aedd8f604876dc3bde20560 Mon Sep 17 00:00:00 2001
From: Martin Mares <mj@ucw.cz>
Date: Sat, 13 Sep 2008 12:31:18 +0200
Subject: [PATCH] CGI.pm: Make cookie setting headers backwards-compatible.

---
 ucw/perl/CGI.pm | 52 ++++++++++++++++++++++++++++++-------------------
 1 file changed, 32 insertions(+), 20 deletions(-)

diff --git a/ucw/perl/CGI.pm b/ucw/perl/CGI.pm
index acdb39cb..7389511a 100644
--- a/ucw/perl/CGI.pm
+++ b/ucw/perl/CGI.pm
@@ -416,38 +416,50 @@ sub self_form(@) {
 
 ### Cookies
 
-sub cookie_esc($) {
-	my $x = shift @_;
-	if ($x !~ /^[a-zA-Z0-9%]+$/) {
-		$x =~ s/([\\\"])/\\$1/g;
-		$x = "\"$x\"";
-	}
-	return $x;
-}
-
 sub set_cookie($$@) {
+	#
+	# Unfortunately, the support for the new cookie standard (RFC 2965) among
+	# web browsers is still very scarce, so we are still using the old Netscape
+	# specification.
+	#
+	# Usage: set_cookie(name, value, option => value...), where options are:
+	#
+	#	max-age		maximal age in seconds
+	#	domain		domain name scope
+	#	path		path name scope
+	#	secure		if non-zero, cookie applies only to SSL connections
+	#
+
 	my $key = shift @_;
 	my $value = shift @_;
 	my %other = @_;
-	$other{'version'} = 1 unless defined $other{'version'};
-	print "Set-Cookie: $key=", cookie_esc($value);
+	if (my $age = $other{'max-age'}) {
+		delete $other{'max-age'};
+		my $exp = ($age ? (time + $age) : 0);
+		# Avoid problems with locales
+		my ($S,$M,$H,$d,$m,$y,$wd) = gmtime $exp;
+		my @wdays = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' );
+		my @mons = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
+		$other{'expires'} = sprintf("%s, %02d-%s-%d %02d:%02d:%02d GMT",
+			$wdays[$wd], $d, $mons[$m], $y+1900, $H, $M, $S);
+	}
+	my $secure = $other{'secure'};
+	delete $other{'secure'};
+
+	print "Set-Cookie: $key=", url_escape($value);
 	foreach my $k (keys %other) {
-		print ";$k=", cookie_esc($other{$k});
+		print "; $k=", $other{$k};
 	}
+	print "; secure" if $secure;
 	print "\n";
 }
 
 sub parse_cookies() {
 	my $h = http_get("Cookie") or return ();
 	my @cook = ();
-	while (my ($padding,$name,$val,$xx,$rest) = ($h =~ /\s*([,;]\s*)*([^ =]+)=([^ =,;\"]*|\"([^\"\\]|\\.)*\")(\s.*|;.*|$)/)) {
-		if ($val =~ /^\"/) {
-			$val =~ s/^\"//;
-			$val =~ s/\"$//;
-			$val =~ s/\\(.)/$1/g;
-		}
-		push @cook, $name, $val;
-		$h = $rest;
+	foreach my $x (split /;\s*/, $h) {
+		my ($k,$v) = split /=/, $x;
+		push @cook, $k => url_deescape($v);
 	}
 	return @cook;
 }
-- 
2.39.2