File Coverage

blib/lib/CGI/Easy/Headers.pm
Criterion Covered Total %
statement 53 61 86.8
branch 5 12 41.6
condition 1 3 33.3
subroutine 9 10 90.0
pod 5 5 100.0
total 73 91 80.2


line stmt bran cond sub pod time code
1             package CGI::Easy::Headers;
2              
3 3     3   8414 use warnings;
  3         6  
  3         111  
4 3     3   14 use strict;
  3         9  
  3         90  
5 3     3   18 use Carp;
  3         5  
  3         266  
6              
7 3     3   16 use version; our $VERSION = qv('1.0.0'); # REMINDER: update Changes
  3         8  
  3         23  
8              
9             # REMINDER: update dependencies in Makefile.PL
10 3     3   277 use CGI::Easy::Util qw( date_http make_cookie );
  3         7  
  3         22  
11              
12              
13             sub new {
14 11     11 1 76 my ($class, $opt) = @_;
15 0         0 my $self = {
16             'Status' => '200 OK',
17             'Content-Type' => 'text/html; charset=utf-8',
18             'Date' => q{},
19             'Set-Cookie' => [],
20 11 50       65 $opt ? %{$opt} : (),
21             };
22 11         38 return bless $self, $class;
23             }
24              
25             sub add_cookie {
26 11     11 1 431 my ($self, @cookies) = @_;
27 11         16 push @{ $self->{'Set-Cookie'} }, @cookies;
  11         31  
28 11         27 return;
29             }
30              
31             sub redirect {
32 1     1 1 16 my ($self, $url, $status) = @_;
33 1         3 $self->{'Location'} = $url;
34 1 50       4 if (!defined $status) {
35 1         2 $status = '302 Found';
36             }
37 1         2 $self->{'Status'} = $status;
38 1         3 return;
39             }
40              
41             sub require_basic_auth {
42 0     0 1 0 my ($self, $realm) = @_;
43 0 0       0 if (!defined $realm) {
44 0         0 $realm = q{};
45             }
46 0         0 $self->{'WWW-Authenticate'} = "Basic realm=\"$realm\"";
47 0         0 $self->{'Status'} = '401 Authorization Required';
48 0         0 return;
49             }
50              
51             sub compose {
52 6     6 1 911 my ($self) = @_;
53 6         11 my %h = %{$self};
  6         30  
54 6         20 for my $header (keys %h) {
55 26         57 my $expect = join q{-}, map {ucfirst lc} split /-/xms, $header;
  38         93  
56 26         52 $expect =~ s/\bEtag\b/ETag/xms;
57 26         35 $expect =~ s/\bWww\b/WWW/xms;
58 26         32 $expect =~ s/\bMd5\b/MD5/xms;
59 26 50       67 if ($header ne $expect) {
60 0         0 croak "Bad header name '$header' (should be '$expect')";
61             }
62             }
63              
64 6         31 my $s = sprintf "Status: %s\r\n", delete $h{'Status'};
65 6         19 $s .= sprintf "Content-Type: %s\r\n", delete $h{'Content-Type'};
66 6         13 my $date = delete $h{'Date'};
67 6 50       14 if (defined $date) {
68 6   33     33 $s .= sprintf "Date: %s\r\n", $date || date_http(time);
69             }
70 6         12 for my $cookie (@{ delete $h{'Set-Cookie'} }) {
  6         15  
71 12         37 $s .= make_cookie($cookie);
72             }
73 6         18 for my $header (keys %h) {
74 2 50       5 if (!ref $h{$header}) {
75 2         5 $h{$header} = [ $h{$header} ];
76             }
77 2         5 for my $value (@{ $h{$header} }) {
  2         4  
78 2         10 $s .= sprintf "%s: %s\r\n", $header, $value;
79             }
80             }
81              
82 6         59 return $s . "\r\n";
83             }
84              
85              
86             1; # Magic true value required at end of module
87             __END__
88              
89             =encoding utf8
90              
91             =head1 NAME
92              
93             CGI::Easy::Headers - Manage HTTP headers
94              
95              
96             =head1 SYNOPSIS
97              
98             use CGI::Easy::Headers;
99              
100             my $h = CGI::Easy::Headers->new();
101              
102             $h->{Expires} = 'Sat, 01 Jan 2000 00:00:00 GMT';
103             $h->add_cookie({
104             name => 'somevar',
105             value => 'someval',
106             expires => time + 86400,
107             domain => '.example.com',
108             path => '/admin/',
109             secure => 1,
110             });
111             print $h->compose(), '<html>...</html>';
112              
113             $h->redirect('http://google.com/');
114             print $h->compose();
115              
116             $h->require_basic_auth('Secret Area');
117             print $h->compose();
118              
119              
120             =head1 DESCRIPTION
121              
122             Provides user with simple hash where user can easy add/modify/delete HTTP
123             headers while preparing them for sending in CGI reply.
124              
125              
126             =head1 INTERFACE
127              
128             =over
129              
130             =item new( [\%headers] )
131              
132             Create new CGI::Easy::Headers object/hash with these fields:
133              
134             'Status' => '200 OK',
135             'Content-Type' => 'text/html; charset=utf-8',
136             'Date' => q{},
137             'Set-Cookie' => [],
138              
139             If %headers given, it will be appended to default keys and so may
140             overwrite default values.
141              
142             See compose() below about special values in 'Date' and 'Set-Cookie' fields.
143              
144             While you're free to add/modify/delete any fields in this object/hash,
145             HTTP headers is case-insensitive, and thus it's possible to accidentally
146             create different keys in this hash for same HTTP header:
147              
148             $h->{'Content-Type'} = 'text/plain';
149             $h->{'content-type'} = 'image/png';
150              
151             To protect against this, compose() allow only keys named in 'Content-Type'
152             way and will throw exception if it found keys named in other way. There
153             few exceptions from this rule: 'ETag', 'WWW-Authenticate' and 'Digest-MD5'.
154              
155             Return created CGI::Easy::Headers object.
156              
157              
158             =item add_cookie( \%cookie, … )
159              
160             Add new cookies to current HTTP headers. Actually it's just do this:
161              
162             push @{ $self->{'Set-Cookie'} }, \%cookie, …;
163              
164             Possible keys in %cookie:
165              
166             name REQUIRED STRING
167             value OPTIONAL STRING (default "")
168             domain OPTIONAL STRING (default "")
169             path OPTIONAL STRING (default "/")
170             expires OPTIONAL STRING or SECONDS
171             secure OPTIONAL BOOL
172              
173             Format for "expires" should be either correct date
174             'Thu, 01-Jan-1970 00:00:00 GMT' or time in seconds.
175              
176             Return nothing.
177              
178              
179             =item redirect( $url [, $status] )
180              
181             Set HTTP headers 'Location' and 'Status'.
182              
183             If $status not provided, use '302 Found'.
184              
185             Return nothing.
186              
187              
188             =item require_basic_auth( [$realm] )
189              
190             Set HTTP headers 'WWW-Authenticate' and 'Status'.
191              
192             Return nothing.
193              
194              
195             =item compose( )
196              
197             Render all object's fields into single string with all HTTP headers suitable
198             for sending to user's browser.
199              
200             Most object's field values expected to be simple strings (or ARRAYREF with
201             strings for headers with more than one values) which should be copied to
202             HTTP headers as is:
203              
204             $h->{ETag} = '123';
205             $h->{'X-My-Header'} = 'my value';
206             $h->{'X-Powered-By'} = ['Perl', 'CGI::Easy'];
207             $headers = $h->compose();
208             # $headers will be:
209             # "ETag: 123\r\n" .
210             # "X-My-Header: my value\r\n" .
211             # "X-Powered-By: Perl\r\n" .
212             # "X-Powered-By: CGI::Easy\r\n" .
213             # "\r\n"
214              
215             But there few fields with special handling:
216              
217             =over
218              
219             =item Date
220              
221             You can set it to usual string (like 'Sat, 01 Jan 2000 00:00:00 GMT')
222             or to unix time in seconds (as returned by time()) - in later case time
223             in seconds will be automatically converted to string with date/time.
224              
225             If it set to empty string (new() will initially set it this way),
226             then current date/time will be automatically used.
227              
228             =item Set-Cookie
229              
230             This field must be ARRAYREF (new() will initially set it to []), and
231             instead of strings must contain HASHREF with cookie properties (see
232             add_cookie() above).
233              
234             =back
235              
236             Return string with HTTP headers ending with empty line.
237             Throw exception on keys named with wrong case (see new() about details).
238              
239              
240             =back
241              
242              
243             =head1 BUGS AND LIMITATIONS
244              
245             No bugs have been reported.
246              
247              
248             =head1 SUPPORT
249              
250             Please report any bugs or feature requests through the web interface at
251             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Easy>.
252             I will be notified, and then you'll automatically be notified of progress
253             on your bug as I make changes.
254              
255             You can also look for information at:
256              
257             =over
258              
259             =item * RT: CPAN's request tracker
260              
261             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Easy>
262              
263             =item * AnnoCPAN: Annotated CPAN documentation
264              
265             L<http://annocpan.org/dist/CGI-Easy>
266              
267             =item * CPAN Ratings
268              
269             L<http://cpanratings.perl.org/d/CGI-Easy>
270              
271             =item * Search CPAN
272              
273             L<http://search.cpan.org/dist/CGI-Easy/>
274              
275             =back
276              
277              
278             =head1 AUTHOR
279              
280             Alex Efros C<< <powerman-asdf@ya.ru> >>
281              
282              
283             =head1 LICENSE AND COPYRIGHT
284              
285             Copyright 2009-2010 Alex Efros <powerman-asdf@ya.ru>.
286              
287             This program is distributed under the MIT (X11) License:
288             L<http://www.opensource.org/licenses/mit-license.php>
289              
290             Permission is hereby granted, free of charge, to any person
291             obtaining a copy of this software and associated documentation
292             files (the "Software"), to deal in the Software without
293             restriction, including without limitation the rights to use,
294             copy, modify, merge, publish, distribute, sublicense, and/or sell
295             copies of the Software, and to permit persons to whom the
296             Software is furnished to do so, subject to the following
297             conditions:
298              
299             The above copyright notice and this permission notice shall be
300             included in all copies or substantial portions of the Software.
301              
302             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
303             EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
304             OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
305             NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
306             HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
307             WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
308             FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
309             OTHER DEALINGS IN THE SOFTWARE.
310