root/trunk/lib/Mungo/Cookie.pm

Revision 17, 4.5 kB (checked in by jesus, 6 years ago)

first whack at resolving mod_perl2 support. refs #8

Line 
1 package Mungo::Cookie;
2
3 # Copyright (c) 2007 OmniTI Computer Consulting, Inc. All rights reserved.
4 # For information on licensing see:
5 #   https://labs.omniti.com/zetaback/trunk/LICENSE
6
7 use strict;
8 use Mungo::Utils;
9 eval "use APR::Table;";
10
11 my %reserved = (
12   'Expires' => 1,
13   'Domain'  => 1,
14   'Path'    => 1,
15   'Secure'  => 1,
16 );
17
18 my %time_multiplier = (
19   's' => 1,
20   'm' => 60,
21   'h' => 3600,
22   'd' => 86400,
23   'w' => 604800,
24   'M' => 2592000,
25   'y' => 31536000
26 );
27
28 sub new {
29   my $class = shift;
30   my $arg = shift;
31   my $cstr =  (ref $arg && UNIVERSAL::can($arg, 'headers_in')) ? # pull from
32                 $arg->headers_in->get('Cookie') :      # Apache2::RequestRec
33                 (ref $arg && UNIVERSAL::can($arg, 'header_in')) ?
34                   $arg->header_in('Cookie') :          # Apache::Request
35                   $arg;                                # or a passed string
36   my $self = bless {}, $class;
37   foreach my $cookie (split /;\s*/, $cstr) {        # ; seperated cookies
38     my ($cname, $rest) = split /=/, $cookie, 2;     # cookie=OPAQUE_STRING
39     my @lk = ($rest !~ /[=&]/) ?                    # single value ?
40                ($rest) :                            # then use that
41                map {
42                  my @kv = split /=/, $_, 2;         # split k(=v)?
43                  (@kv == 1) ? ($kv[0], 1) : @kv;    # return (k,v||1)
44                } split /&/, $rest;                  # from & delimited bits
45
46     ($cname, @lk) = map {                           # decode all the tokens
47                       s/\+/ /g;
48                       s/%([0-9a-f]{2})/chr(hex($1))/ieg;
49                       $_;
50                     } ($cname, @lk);
51
52     next if(exists $self->{$cname}->{Value});       # first one wins
53
54     $self->{$cname}->{Value} = (scalar(@lk) <= 1) ?
55                         $lk[0] :                    # single value
56                         {my %tmp = @lk};            # value set
57   }
58   return $self;
59 }
60
61 sub make_cookie_string {
62   my ($self, $cname, $info) = @_;
63   my $cstring;
64   if(ref $info->{Value}) {
65     my ($ecname, %lk) = map {
66       s/([^a-zA-Z0-9])/sprintf("%%%02x", ord($1))/eg;
67       $_;
68     } ($cname, %{$info->{Value}});
69     $cstring = "$ecname=";
70     my @parts;
71     while(my($k,$v) = each %lk) { push @parts, "$k=$v"; }
72     $cstring .= join('&', @parts);
73   }
74   else {
75     $cstring = join('=', map {
76       s/([^a-zA-Z0-9])/sprintf("%%%02x", ord($1))/eg;
77       $_;
78     } ($cname, $info->{Value}));
79   }
80   if(exists $info->{Expires}) {
81     if($info->{Expires} =~ /^\d+([smhdwMy])?$/) {
82       my $s = $info->{Expires} * $time_multiplier{$1 || 's'};
83       $info->{Expires} = Mungo::Utils::time2str(time + $s);
84     }
85   }
86   foreach my $attr (grep { $_ ne 'Secure' } keys %reserved) {
87     if(exists $info->{$attr}) {
88       $cstring .= "; ".lc($attr)."=".$info->{$attr};
89     }
90   }
91   if(exists $info->{Secure} && $info->{Secure}) {
92     $cstring .= "; secure";
93   }
94   return $cstring;
95 }
96 sub inject_headers {
97   my $self = shift;
98   my $Response = shift;
99   my $r = $Response;
100   if(UNIVERSAL::isa($Response,'Mungo::Response')) {
101     $r = $Response->{'Apache::Request'};
102   }
103   die __PACKAGE__ .
104     "->inject_header requires Apache2::RequestRec or Apache::Request or Mungo::Response"
105       if(!$r || (!UNIVERSAL::can($r, 'headers_out') &&
106                  !UNIVERSAL::can($r, 'header_out')));
107   # $r is our Apache::Request at this point
108   while(my ($cname, $info) = each %$self) {
109     my $cookiestr = $self->make_cookie_string($cname, $info);
110     $r->can('headers_out') ?
111       $r->headers_out->add('Set-Cookie', $cookiestr) :
112       $r->header_out('Set-Cookie', $cookiestr);
113   }
114   return;
115 }
116
117 sub __get {
118   my $self = shift;
119   # Short circuit if no args were given
120   return $self unless(@_);
121
122   my $key = shift;
123   if(@_) {
124     my $part = shift;
125     return (exists $self->{$key} && ref $self->{$key}->{Value} eq 'HASH' &&
126             exists $self->{$key}->{Value}->{$part}) ?
127              $self->{$key}->{Value}->{$part} :
128              undef;
129   }
130   return (exists $self->{$key}->{Value}) ? $self->{$key}->{Value} : undef;
131 }
132
133 sub __set {
134   my $self = shift;
135   my $cname = shift;
136   my $key = undef;
137   my $value = shift;
138   if(@_) {
139     $key = $value;
140     $value = shift;
141   }
142   $self->{$cname} ||= {};
143   if(!defined($key)) {
144     $self->{$cname}->{Value} = $value;
145   }
146   else {
147     if(exists $reserved{ucfirst(lc($key))}) {
148       $self->{$cname}->{ucfirst(lc($key))} = $value;
149     }
150     else {
151       $self->{$cname}->{Value} = {}
152         unless(ref $self->{$cname}->{Value} eq 'HASH');
153       $self->{$cname}->{Value}->{$key} = $value;
154     }
155   }
156 }
157 1;
Note: See TracBrowser for help on using the browser.