File Coverage

blib/lib/Labyrinth/CookieLib.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package Labyrinth::CookieLib;
2              
3 2     2   3815 use warnings;
  2         3  
  2         54  
4 2     2   6 use strict;
  2         4  
  2         49  
5              
6 2     2   6 use vars qw(%cookie_config $VERSION @ISA %EXPORT_TAGS @EXPORT @EXPORT_OK);
  2         2  
  2         124  
7             $VERSION = '5.30';
8              
9             =head1 NAME
10              
11             Labyrinth::CookieLib - Cookie Management for Labyrinth
12              
13             =head1 DESCRIPTION
14              
15             This collection of functions provides the cookie functionality within
16             the Labyrinth framework.
17              
18             Based on the NMS cookielib script.
19              
20             =cut
21              
22             # -------------------------------------
23             # Library Modules
24              
25 2     2   67 use Labyrinth::Variables;
  0            
  0            
26              
27             # -------------------------------------
28             # Export Details
29              
30             require Exporter;
31             @ISA = qw(Exporter);
32              
33             %EXPORT_TAGS = (
34             'all' => [ qw(
35             SetCookieExpDate SetCookiePath SetCookieDomain SetSecureCookie
36             GetCookies SetCookie SetCookies GetCompressedCookies SetCompressedCookies
37             ) ]
38             );
39              
40             @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
41             @EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
42              
43             # -------------------------------------
44             # The Subs
45              
46             =head1 FUNCTIONS
47              
48             =over 4
49              
50             =item SetCookieExpDate
51              
52             Set the cookie expiration date.
53              
54             =item SetCookiePath
55              
56             Set the cookie path.
57              
58             =item SetCookieDomain
59              
60             Set the cookie domain.
61              
62             =item SetSecureCookie
63              
64             Set the cookie security.
65              
66             =item GetCookies
67              
68             Get all existing cookies.
69              
70             =item SetCookie
71              
72             Set a single cookie.
73              
74             =item SetCookies
75              
76             Set all given cookies.
77              
78             =item GetCompressedCookies
79              
80             Get all compressed cookies.
81              
82             =item SetCompressedCookies
83              
84             Set all given cookies as compressed cookies.
85              
86             =back
87              
88             =cut
89              
90             sub SetCookieExpDate {
91             $cookie_config{expires} = $_[0];
92             }
93              
94             sub SetCookiePath {
95             $cookie_config{path} = $_[0];
96             }
97              
98             sub SetCookieDomain {
99              
100             if ($_[0] =~ /(.com|.edu|.net|.org|.gov|.mil|.int)$/i &&
101             $_[0] =~ /\.[^.]+\.\w{3}$/) {
102             $cookie_config{domain} = $_[0];
103             return 1;
104             } elsif ($_[0] !~ /(.com|.edu|.net|.org|.gov|.mil|.int)$/i &&
105             $_[0] =~ /\.[^.]+\.[^.]+\./) {
106             $cookie_config{domain} = $_[0];
107             return 1;
108             } else {
109             return 0;
110             }
111             }
112              
113             sub SetSecureCookie {
114             $cookie_config{secure} = $_[0];
115             }
116              
117             sub GetCookies {
118             my @cookies = @_;
119              
120             my $exists = 0;
121             foreach my $name (@cookies)
122             {
123             my $value = $cgi->cookie($name);
124             $main::Cookies{$name} = $value;
125             $exists = 1 if $value;
126             }
127             return $exists;
128             }
129              
130             sub SetCookie {
131             my ($name,$value) = @_;
132             my $c = $cgi->cookie (
133             -name => $name,
134             -value => $value,
135             -expires => (exists($cookie_config{expires}) ? $cookie_config{expires} : undef),
136             -domain => (exists($cookie_config{domain}) ? $cookie_config{domain} : undef),
137             -secure => (exists($cookie_config{secure}) ? $cookie_config{secure} : undef),
138             -path => (exists($cookie_config{path}) ? $cookie_config{path} : undef),
139             );
140             return $c;
141             }
142              
143             sub SetCookies {
144             my (%input) = @_;
145             while( my($name,$value) = each %input ) {
146             my $c = SetCookie($name,$value);
147             print "Set-Cookie: ", $c, "\n";
148             }
149             }
150              
151             sub GetCompressedCookies {
152             my($cookie_name,@cookies) = @_;
153             my $exists = 0;
154              
155             return unless( GetCookies(@_) );
156              
157             # extract specified cookies
158             if( @cookies ) {
159             foreach my $name (@cookies) {
160             if($main::Cookies{$cookie_name} =~ /$name\:\:([^&]+)/) {
161             my $value = $1;
162             $main::Cookies{$name} = $value;
163             $exists = 1 if $value;
164             }
165             }
166              
167             # extract all cookies
168             } else {
169             foreach my $cookie (split /&/, $main::Cookies{$cookie_name}) {
170             my ($name,$value) = (split /::/, $cookie);
171             $main::Cookies{$name} = $value;
172             $exists = 1 if $value;
173             }
174             }
175              
176             return $exists;
177             }
178              
179             sub SetCompressedCookies {
180             my($cookie_name,@cookies) = @_;
181             my $cookie_value = "";
182              
183             my %input = (@cookies);
184             while( my($name,$value) = each %input ) {
185             if ($cookie_value) {
186             $cookie_value .= '&'.$name.'::'.$value;
187             } else {
188             $cookie_value = $name.'::'.$value;
189             }
190             }
191             SetCookies($cookie_name,$cookie_value);
192             }
193              
194             1;
195              
196             __END__