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