File Coverage

blib/lib/PLP/Tie/Headers.pm
Criterion Covered Total %
statement 41 46 89.1
branch 11 14 78.5
condition 2 3 66.6
subroutine 9 11 81.8
pod n/a
total 63 74 85.1


line stmt bran cond sub pod time code
1             package PLP::Tie::Headers;
2              
3 1     1   5 use strict;
  1         3  
  1         36  
4 1     1   6 use warnings;
  1         2  
  1         29  
5 1     1   5 use Carp;
  1         3  
  1         808  
6              
7             our $VERSION = '1.01';
8              
9             =head1 PLP::Tie::Headers
10              
11             Makes a hash case insensitive, and sets some headers. <_> equals <->, so C<$foo{CONTENT_TYPE}> is
12             the same as C<$foo{'Content-Type'}>.
13              
14             tie %somehash, 'PLP::Tie::Headers';
15              
16             This module is part of the PLP internals and probably not of much use to others.
17              
18             =cut
19              
20             sub TIEHASH {
21 18     18   145 return bless [ # Defaults
22             {
23             'Content-Type' => 'text/html',
24             'X-PLP-Version' => $PLP::VERSION,
25             },
26             {
27             'content-type' => 'Content-Type',
28             'x-plp-version' => 'X-PLP-Version',
29             },
30             1 # = content-type untouched
31             ], $_[0];
32             }
33              
34             sub FETCH {
35 38     38   461 my ($self, $key) = @_;
36 38 100 66     137 if ($self->[2] and defined $self->[0]->{'Content-Type'}) {
37 18         31 my $utf8 = eval { grep {$_ eq "utf8"} PerlIO::get_layers(*STDOUT) };
  18         88  
  19         56  
38 18 100       46 $self->[0]->{'Content-Type'} .= '; charset=utf-8' if $utf8;
39 18         28 $self->[2] = 0;
40             }
41 38         62 $key =~ tr/_/-/;
42 38 50       114 defined ($key = $self->[1]->{lc $key}) or return;
43 38         160 return $self->[0]->{$key};
44             }
45              
46             sub STORE {
47 4     4   10 my ($self, $key, $value) = @_;
48 4         6 $key =~ tr/_/-/;
49 4 100       9 if ($PLP::sentheaders) {
50 1         5 my @caller = caller;
51 1         20 die "Can't set headers after sending them at " .
52             "$caller[1] line $caller[2].\n(Output started at " .
53             "$PLP::sentheaders->[0] line $PLP::sentheaders->[1].)\n"
54             }
55 3 100       13 if (defined $self->[1]->{lc $key}){
56 1         3 $key = $self->[1]->{lc $key};
57             } else {
58 2         7 $self->[1]->{lc $key} = $key;
59             }
60 3 50       8 $self->[2] = 0 if $key eq 'Content-Type';
61 3         60 return ($self->[0]->{$key} = $value);
62             }
63              
64             sub DELETE {
65 1     1   2 my ($self, $key) = @_;
66 1         2 $key =~ tr/_/-/;
67 1 50       9 defined ($key = delete $self->[1]->{lc $key}) or return;
68 1         5 return delete $self->[0]->{$key};
69             }
70              
71             sub CLEAR {
72 0     0   0 my $self = $_[0];
73 0         0 return (@$self = ());
74             }
75              
76             sub EXISTS {
77 0     0   0 my ($self, $key) = @_;
78 0         0 $key =~ tr/_/-/;
79 0         0 return exists $self->[1]->{lc $key};
80             }
81              
82             sub FIRSTKEY {
83 18     18   23 my $self = $_[0];
84 18         18 keys %{$self->[0]};
  18         50  
85 18         20 return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong.
  18         112  
86             }
87              
88             sub NEXTKEY {
89 37     37   36 return each %{ $_[0]->[0] };
  37         174  
90             }
91              
92             1;
93