File Coverage

blib/lib/Apache/FakeCookie.pm
Criterion Covered Total %
statement 116 121 95.8
branch 48 68 70.5
condition 13 23 56.5
subroutine 21 21 100.0
pod n/a
total 198 233 84.9


line stmt bran cond sub pod time code
1             package Apache::FakeCookie;
2              
3 1     1   299791 use vars qw($VERSION);
  1         4  
  1         128  
4             $VERSION = do { my @r = (q$Revision: 0.08 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
5              
6             # Oh!, we really don't live in this package
7              
8             package Apache::Cookie;
9 1     1   7 use vars qw($Cookies);
  1         3  
  1         36  
10 1     1   6 use strict;
  1         7  
  1         6471  
11              
12             $Cookies = {};
13              
14             # emluation is fairly complete
15             # cookies can be created, altered and removed
16             #
17 10 100   10   98 sub fetch { return wantarray ? %{$Cookies} : $Cookies; }
  3         28  
18 4     4   431 sub path {&do_this;}
19 4     4   184 sub secure {&do_this;}
20 18     18   55 sub name {&do_this;}
21 4     4   437 sub domain {&do_this;}
22             sub value {
23 5     5   186 my ($self, $val) = @_;
24 5 100       19 $self->{-value} = $val if defined $val;
25 5 50       20 if (defined $self->{-value}) {
26 5 100       18 return wantarray ? @{$self->{-value}} : $self->{-value}->[0]
  3         20  
27             } else {
28 0 0       0 return wantarray ? () : '';
29             }
30             }
31             sub new {
32 11     11   257 my $proto = shift; # bless into Apache::Cookie
33 11         34 shift; # waste reference to $r;
34 11         49 my @vals = @_;
35 11         56 my $self = {@vals};
36 11   66     68 my $class = ref($proto) || $proto;
37             # make sure values are in array format
38 11         34 my $val = $self->{-value};;
39 11 100       36 if (defined $val) {
40 10         28 $val = $self->{-value};
41 10 50       39 if (ref($val) eq 'ARRAY') {
    0          
    0          
42 10         46 @vals = @$val;
43             } elsif (ref($val) eq 'HASH') {
44 0         0 @vals = %$val;
45             } elsif (!ref($val)) {
46 0         0 @vals = ($val); # it's a plain SCALAR
47             } # hmm.... must be a SCALAR ref or CODE ref
48 10         45 $self->{-value} = [@vals];
49             }
50 11 100 66     110 $self->{-expires} = _expires($self->{-expires})
51             if exists $self->{-expires} && defined $self->{-expires};
52 11         45 bless $self, $class;
53 11         65 return $self;
54             }
55             sub bake {
56 8     8   79 my $self = shift;
57 8 100       33 if ( defined $self->{-value} ) {
58 7         44 $Cookies->{$self->{-name}} = $self;
59             } else {
60 1         7 delete $Cookies->{$self->{-name}};
61             }
62             }
63             sub parse { # adapted from CGI::Cookie v1.20 by Lincoln Stein
64 3     3   91 my ($self,$raw_cookie) = @_;
65 3 100       13 if ($raw_cookie) {
66 2   66     11 my $class = ref($self) || $self;
67 2         4 my %results;
68              
69 2         16 my(@pairs) = split("; ?",$raw_cookie);
70 2         7 foreach (@pairs) {
71 3         23 s/\s*(.*?)\s*/$1/;
72 3         13 my($key,$value) = split("=",$_,2);
73             # Some foreign cookies are not in name=value format, so ignore
74             # them.
75 3 50       12 next if !defined($value);
76 3         9 my @values = ();
77 3 50       15 if ($value ne '') {
78 3         29 @values = map unescape($_),split(/[&;]/,$value.'&dmy');
79 3         9 pop @values;
80             }
81 3         9 $key = unescape($key);
82             # A bug in Netscape can cause several cookies with same name to
83             # appear. The FIRST one in HTTP_COOKIE is the most recent version.
84 3   33     37 $results{$key} ||= $self->new(undef,-name=>$key,-value=>\@values);
85             }
86 2         6 $self = \%results;
87 2         297 bless $self, $class;
88 2         10 $Cookies = $self;
89             }
90 3         10 @_ = ($self);
91 3         15 goto &fetch;
92             }
93             sub expires {
94 22     22   107 my $self = shift;
95 22 100       72 $self->{-expires} = _expires(shift)
96             if @_;
97 22 100 66     245 return (exists $self->{-expires} &&
98             defined $self->{-expires})
99             ? $self->{-expires} : undef;
100             }
101             # Adapted from CGI::Cookie v1.20 by Lincoln Stein
102             # This internal routine creates date strings suitable for use in
103             # cookies and HTTP headers. (They differ, unfortunately.)
104             # Thanks to Mark Fisher for this.
105             sub _expires {
106 7     7   19 my($time) = @_;
107 7         45 my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
108 7         27 my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
109              
110             # pass through preformatted dates for the sake of expire_calc()
111 7         29 $time = _expire_calc($time);
112 7 50       59 return $time unless $time =~ /^\d+$/;
113 7         17 my $sc = '-';
114 7         38 my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
115 7         21 $year += 1900;
116 7         100 return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
117             $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
118             }
119             # Copied directly from CGI::Cookie v1.20 by Lincoln Stein
120             # This internal routine creates an expires time exactly some number of
121             # hours from the current time. It incorporates modifications from
122             # Mark Fisher.
123             sub _expire_calc {
124 7     7   17 my($time) = @_;
125 7         54 my(%mult) = ('s'=>1,
126             'm'=>60,
127             'h'=>60*60,
128             'd'=>60*60*24,
129             'M'=>60*60*24*30,
130             'y'=>60*60*24*365);
131             # format for time can be in any of the forms...
132             # "now" -- expire immediately
133             # "+180s" -- in 180 seconds
134             # "+2m" -- in 2 minutes
135             # "+12h" -- in 12 hours
136             # "+1d" -- in 1 day
137             # "+3M" -- in 3 months
138             # "+2y" -- in 2 years
139             # "-3m" -- 3 minutes ago(!)
140             # If you don't supply one of these forms, we assume you are
141             # specifying the date yourself
142 7         14 my($offset);
143 7 50 33     113 if (!$time || (lc($time) eq 'now')) {
    100          
    50          
144 0         0 $offset = 0;
145             } elsif ($time=~/^\d+/) {
146 2         9 return $time;
147             } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
148 5   50     36 $offset = ($mult{$2} || 1)*$1;
149             } else {
150 0         0 return $time;
151             }
152 5         29 return (time+$offset);
153             }
154             sub remove {
155 3     3   73 my ($self,$name) = @_;
156 3 100       13 if ($name) {
157 2 50       79 delete $Cookies->{$name} if exists $Cookies->{$name};
158             } else {
159 1 50       15 delete $Cookies->{$self->{-name}}
160             if exists $Cookies->{$self->{-name}};
161             }
162             }
163             sub as_string {
164 17     17   192 my $self = shift;
165 17 50       64 return '' unless $self->name;
166 17         114 my %cook = %$self;
167 17 50       102 my $cook = ($cook{-name}) ? escape($cook{-name}) . '=' : '';
168 17 50       70 if ($cook{-value}) {
169 17         34 my $i = '';
170 17         252 foreach(@{$cook{-value}}) {
  17         73  
171 20         49 $cook .= $i . escape($_);
172 20         81 $i = '&';
173             }
174             }
175 17         50 foreach(qw(domain path)) {
176 34 100       161 $cook .= "; $_=" . $cook{"-$_"} if $cook{"-$_"};
177             }
178 17 100       62 $cook .= "; expires=$_" if ($_ = expires(\%cook));
179 17 100       130 $cook .= ($cook{-secure}) ? '; secure' : '';
180             }
181              
182             ### helpers
183             sub do_this {
184 30     30   481 (caller(1))[3] =~ /[^:]+$/;
185 30         156 splice(@_,1,0,'-'.$&);
186 30         267 goto &cookie_item;
187             }
188             # get or set a named item in cookie hash
189             sub cookie_item {
190 30     30   120 my($self,$item,$val) = @_;
191 30 100       96 if ( defined $val ) {
192             #
193             # Darn! this modifies a cookie item if user is generating
194             # a replacement cookie and has not yet "baked" it...
195             # Don't see how this can hurt in the real world... MAR 9-2-02
196 4 100 66     25 if ( $item eq '-name' &&
197             exists $Cookies->{$self->{-name}} ) {
198 1         7 $Cookies->{$val} = $Cookies->{$self->{-name}};
199 1         6 delete $Cookies->{$self->{-name}};
200             }
201 4         11 $self->{$item} = $val;
202             }
203 30 100       316 return (exists $self->{$item}) ? $self->{$item} : '';
204             }
205             sub escape {
206 78     78   403520 my ($x) = @_;
207 78 50       237 return undef unless defined($x);
208 78         389 $x =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
  34         274  
209 78         474 return $x;
210             }
211             # unescape URL-data, but leave +'s alone
212             sub unescape {
213 12     12   24 my ($x) = @_;
214 12 50       223 return undef unless defined($x);
215 12         22 $x =~ tr/+/ /; # pluses become spaces
216 12         37 $x =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
  2         19  
217 12         47 return $x;
218             }
219             1
220             __END__