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