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                 1  # = content-type untouched
  31         ], $_[0];
  32 }
  33
  34 sub FETCH {
  35         my ($self, $key) = @_;
  36         if ($self->[2] and defined $self->[0]->{'Content-Type'}) {
  37                 my $utf8 = eval { grep {$_ eq "utf8"}  PerlIO::get_layers(*STDOUT) };
  38                 $self->[0]->{'Content-Type'} .= '; charset=utf-8' if $utf8;
  39                 $self->[2] = 0;
  40         }
  41         $key =~ tr/_/-/;
  42         return $self->[0]->{ $self->[1]->{lc $key} };
  43 }
  44
  45 sub STORE {
  46         my ($self, $key, $value) = @_;
  47         $key =~ tr/_/-/;
  48         if ($PLP::sentheaders) {
  49                 my @caller = caller;
  50                 die "Can't set headers after sending them at " .
  51                     "$caller[1] line $caller[2].\n(Output started at " .
  52                     "$PLP::sentheaders->[0] line $PLP::sentheaders->[1].)\n"
  53         }
  54         if (defined $self->[1]->{lc $key}){
  55                 $key = $self->[1]->{lc $key};
  56         } else {
  57                 $self->[1]->{lc $key} = $key;
  58         }
  59         $self->[2] = 0 if $key eq 'Content-Type';
  60         return ($self->[0]->{$key} = $value);
  61 }
  62
  63 sub DELETE {
  64         my ($self, $key) = @_;
  65         $key =~ tr/_/-/;
  66         delete $self->[0]->{$key};
  67         return delete $self->[1]->{lc $key};
  68 }
  69
  70 sub CLEAR {
  71         my $self = $_[0];
  72         return (@$self = ());
  73 }
  74
  75 sub EXISTS {
  76         my ($self, $key) = @_;
  77         $key =~ tr/_/-/;
  78         return exists $self->[1]->{lc $key};
  79 }
  80
  81 sub FIRSTKEY {
  82         my $self = $_[0];
  83         keys %{$self->[0]};
  84         return each %{ $self->[0] }; # Key only, Tie::Hash doc is wrong.
  85 }
  86
  87 sub NEXTKEY {
  88         return each %{ $_[0]->[0] };
  89 }
  90
  91 1;
  92