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 TIEHASH {
  18     return bless [ # Defaults
  19         {
  20             'Content-Type'  => 'text/html',
  21             'X-PLP-Version' => $PLP::VERSION,
  22         },
  23         {
  24             'content-type'  => 'Content-Type',
  25             'x-plp-version' => 'X-PLP-Version',
  26         }
  27     ], $_[0];
  28 }
  29
  30 sub FETCH {
  31     my ($self, $key) = @_;
  32     $key =~ tr/_/-/;
  33     return $self->[0]->{ $self->[1]->{lc $key} };
  34 }
  35
  36 sub STORE {
  37     my ($self, $key, $value) = @_;
  38     $key =~ tr/_/-/;
  39     if ($PLP::sentheaders) {
  40         my @caller = caller;
  41         die "Can't set headers after sending them at " .
  42             "$caller[1] line $caller[2].\n(Output started at " .
  43             "$PLP::sentheaders->[0] line $PLP::sentheaders->[1].)\n"
  44     }
  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     $key =~ tr/_/-/;
  56     delete $self->[0]->{$key};
  57     return delete $self->[1]->{lc $key};
  58 }
  59
  60 sub CLEAR {
  61     my $self = $_[0];
  62     return (@$self = ());
  63 }
  64
  65 sub EXISTS {
  66     my ($self, $key) = @_;
  67     $key =~ tr/_/-/;
  68     return exists $self->[1]->{lc $key};
  69 }
  70
  71 sub FIRSTKEY {
  72     my $self = $_[0];
  73     keys %{$self->[0]};
  74     return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong.
  75 }
  76
  77 sub NEXTKEY {
  78     return each %{ $_[0]->[0] };
  79 }
  80
  81 1;
  82