lib/PLP/Tie/Headers.pm

   1 package PLP::Tie::Headers;
   2
   3 use strict;
   4 use warnings;
   5 use Carp;
   6
   7 our $VERSION = '1.00';
   8
   9 =head1 PLP::Tie::Headers
  10
  11 Makes a hash case insensitive, and sets some headers. <_> equals <->, so C<$foo{CONTENT_TYPE}> is
  12 the same as C<$foo{'Content-Type'}>.
  13
  14         tie %somehash, 'PLP::Tie::Headers';
  15
  16 This module is part of the PLP internals and probably not of much use to others.
  17
  18 =cut
  19
  20 sub TIEHASH {
  21         return bless [ # Defaults
  22                 {
  23                         'Content-Type'  => 'text/html',
  24                         'X-PLP-Version' => $PLP::VERSION,
  25                 },
  26                 {
  27                         'content-type'  => 'Content-Type',
  28                         'x-plp-version' => 'X-PLP-Version',
  29                 }
  30         ], $_[0];
  31 }
  32
  33 sub FETCH {
  34         my ($self, $key) = @_;
  35         $key =~ tr/_/-/;
  36         return $self->[0]->{ $self->[1]->{lc $key} };
  37 }
  38
  39 sub STORE {
  40         my ($self, $key, $value) = @_;
  41         $key =~ tr/_/-/;
  42         if ($PLP::sentheaders) {
  43                 my @caller = caller;
  44                 die "Can't set headers after sending them at " .
  45                     "$caller[1] line $caller[2].\n(Output started at " .
  46                     "$PLP::sentheaders->[0] line $PLP::sentheaders->[1].)\n"
  47         }
  48         if (defined $self->[1]->{lc $key}){
  49                 $key = $self->[1]->{lc $key};
  50         } else {
  51                 $self->[1]->{lc $key} = $key;
  52         }
  53         return ($self->[0]->{$key} = $value);
  54 }
  55
  56 sub DELETE {
  57         my ($self, $key) = @_;
  58         $key =~ tr/_/-/;
  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         $key =~ tr/_/-/;
  71         return exists $self->[1]->{lc $key};
  72 }
  73
  74 sub FIRSTKEY {
  75         my $self = $_[0];
  76         keys %{$self->[0]};
  77         return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong.
  78 }
  79
  80 sub NEXTKEY {
  81         return each %{ $_[0]->[0] };
  82 }
  83
  84 1;
  85