lib/PLP/Tie/Headers.pm

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