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     if ($PLP::sentheaders) {
  44         my @caller = caller;
  45         die "Can't set headers after sending them at " .
  46             "$caller[1] line $caller[2].\n(Output started at " .
  47             "$PLP::sentheaders->[0] line $PLP::sentheaders->[1].)\n"
  48     }
  49     if (defined $self->[1]->{_lc $key}){
  50         $key = $self->[1]->{_lc $key};
  51     } else {
  52         $self->[1]->{lc $key} = $key;
  53     }
  54     return ($self->[0]->{$key} = $value);
  55 }
  56
  57 sub DELETE {
  58     my ($self, $key) = @_;
  59     delete $self->[0]->{$key};
  60     return delete $self->[1]->{_lc $key};
  61 }
  62
  63 sub CLEAR {
  64     my $self = $_[0];
  65     return (@$self = ());
  66 }
  67
  68 sub EXISTS {
  69     my ($self, $key) = @_;
  70     return exists $self->[1]->{_lc $key};
  71 }
  72
  73 sub FIRSTKEY {
  74     my $self = $_[0];
  75     keys %{$self->[0]};
  76     return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong.
  77 }
  78
  79 sub NEXTKEY {
  80     return each %{ $_[0]->[0] };
  81 }
  82
  83 1;
  84