PLP/Tie/Headers.pm

   1 #----------------------------#
   2   package PLP::Tie::Headers;
   3 #----------------------------#
   4 use strict;
   5 use Carp;
   6
   7 =head1 PLP::Tie::Headers
   8
   9 Makes a hash case insensitive, and sets some headers. <_> equals <->, so C<$foo{CONTENT_TYPE}> is
  10 the same as C<$foo{'Content-Type'}>.
  11
  12     tie %somehash, 'PLP::Tie::Headers';
  13
  14 =cut
  15
  16 sub _lc($) {
  17     local $_ = $_[0];
  18     tr/_/-/;
  19     return lc;
  20 }
  21
  22 sub TIEHASH {
  23     return bless [ # Defaults.
  24         {
  25             'Content-Type'  => 'text/html',
  26             'X-PLP-Version' => $PLP::VERSION,
  27         },
  28         {
  29             'content-type'  => 'Content-Type',
  30             'x-plp-version' => 'X-PLP-Version',
  31         }
  32     ], $_[0];
  33 }
  34
  35 sub FETCH {
  36     my ($self, $key) = @_;
  37     return $self->[0]->{ $self->[1]->{_lc $key} };
  38 }
  39
  40 sub STORE {
  41     my ($self, $key, $value) = @_;
  42     croak 'Can\'t set headers after sending them!' if $PLP::sentheaders;
  43     if (defined $self->[1]->{_lc $key}){
  44         $key = $self->[1]->{_lc $key};
  45     }else{
  46         $self->[1]->{lc $key} = $key;
  47     }
  48     return ($self->[0]->{$key} = $value);
  49 }
  50
  51 sub DELETE {
  52     my ($self, $key) = @_;
  53     delete $self->[0]->{$key};
  54     return delete $self->[1]->{_lc $key};
  55 }
  56
  57 sub CLEAR {
  58     my $self = $_[0];
  59     return (@$self = ());
  60 }
  61
  62 sub EXISTS {
  63     my ($self, $key) = @_;
  64     return exists $self->[1]->{_lc $key};
  65 }
  66
  67 sub FIRSTKEY {
  68     my $self = $_[0];
  69     keys %{$self->[0]};
  70     return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong.
  71 }
  72
  73 sub NEXTKEY {
  74     return each %{ $_[0]->[0] };
  75 }
  76
  77 1;
  78