CGI.pm: More improvements to the cookie mechanism.

[libucw.git] / ucw / perl / CGI.pm

diff --git a/ucw/perl/CGI.pm b/ucw/perl/CGI.pm
index 7d7cc4573b0158d2e22ad0266a590ac8367f80f8..99ab83a9ffc2eb7705b892e7fb5791feeeb5cb48 100644 (file)
--- a/ucw/perl/CGI.pm
+++ b/ucw/perl/CGI.pm
@@ -57,7 +57,7 @@ use warnings;
 require Exporter;
 our $VERSION = 1.0;
 our @ISA = qw(Exporter);
-our @EXPORT = qw(&html_escape &url_escape &url_param_escape &self_ref &self_form &http_get);
+our @EXPORT = qw(&html_escape &url_escape &url_deescape &url_param_escape &url_param_deescape &self_ref &self_form &http_get);
 our @EXPORT_OK = qw();
 
 ### Escaping ###
@@ -68,6 +68,12 @@ sub url_escape($) {
        return $x;
 }
 
+sub url_deescape($) {
+       my $x = shift @_;
+       $x =~ s/%(..)/pack("H2",$1)/ge;
+       return $x;
+}
+
 sub url_param_escape($) {
        my $x = shift @_;
        $x = url_escape($x);
@@ -75,6 +81,12 @@ sub url_param_escape($) {
        return $x;
 }
 
+sub url_param_deescape($) {
+       my $x = shift @_;
+       $x =~ s/\+/ /g;
+       return url_deescape($x);
+}
+
 sub html_escape($) {
        my $x = shift @_;
        $x =~ s/&/&/g;
@@ -105,8 +117,7 @@ sub rfc822_prepare($) {
 
 sub rfc822_deescape($) {
        my $x = shift @_;
-       $x =~ s/%(..)/pack("H2",$1)/ge;
-       return $x;
+       return url_deescape($x);
 }
 
 ### Reading of HTTP headers ###
@@ -405,23 +416,44 @@ 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 present, cookie applies only to SSL connections
+       #                       (in this case, the value should be undefined)
+       #       discard         if present with any value, the cookie is discarded
+       #
+
        my $key = shift @_;
        my $value = shift @_;
        my %other = @_;
-       $other{'version'} = 1 unless defined $other{'version'};
-       print "Set-Cookie: $key=", cookie_esc($value);
+       if (exists $other{'discard'}) {
+               delete $other{'discard'};
+               $other{'max-age'} = 0;
+       }
+       if (defined(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);
+       }
+
+       print "Set-Cookie: $key=", url_escape($value);
        foreach my $k (keys %other) {
-               print ";$k=", cookie_esc($other{$k});
+               print "; $k";
+               print "=", $other{$k} if defined $other{$k};
        }
        print "\n";
 }
@@ -429,14 +461,10 @@ sub set_cookie($$@) {
 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;
+               $v = url_deescape($v) if defined $v;
+               push @cook, $k => $v;
        }
        return @cook;
 }