PLP/Tie/Headers.pm

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