lib/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