view release on metacpan or  search on metacpan

lib/APR/HTTP/Headers/Compat/MagicHash.pm  view on Meta::CPAN

package APR::HTTP::Headers::Compat::MagicHash;

use strict;
use warnings;

use APR::HTTP::Headers::Compat::MagicArray;
use APR::Table;
use Carp qw( confess );
use HTTP::Headers;
use Storable qw( dclone );

=head1 NAME

APR::HTTP::Headers::Compat::MagicHash - Tie a hash to an APR::Table

=cut

sub TIEHASH {
  my ( $class, $table, %args ) = @_;

  my $self = bless { table => $table }, $class;

  while ( my ( $k, $v ) = each %args ) {
    $self->STORE( $k, $v );
  }

  return $self;
}

=head2 C<< table >>

Get the table object.

=cut

sub table { shift->{table} }

sub _nicename {
  my ( $self, @names ) = @_;

  my $hdr    = HTTP::Headers->new( map { $_ => 1 } @names );
  my @nice   = $hdr->header_field_names;
  my %lookup = map { lc $_ => $_ } @nice;
  my @r = map { $lookup{$_} or confess "No mapping for $_" } @names;
  return wantarray ? @r : $r[0];
}

sub _nicefor {
  my ( $self, $name ) = @_;
  return $1 if $name =~ /^:(.+)/;
  return $self->{namemap}{$name} ||= $self->_nicename( $name );
}

sub FETCH {
  my ( $self, $key ) = @_;
  my $nkey = $self->_nicefor( $key );
  my @vals = $self->table->get( $nkey );
  return $vals[0] if @vals < 2;
  tie my @r, 'APR::HTTP::Headers::Compat::MagicArray', $nkey, $self,
   @vals;
  return \@r;
  #  return $self->{hash}{$nkey};
}

sub STORE {
  my ( $self, $key, $value ) = @_;
  my $nkey = $self->_nicefor( $key );
  $self->{rmap}{$nkey} = $key;

  my $table = $self->table;
  my @vals = 'ARRAY' eq ref $value ? @$value : $value;
  $table->set( $nkey, shift @vals );
  $table->add( $nkey, $_ ) for @vals;
  $self->_changed;
}

sub DELETE {
  my ( $self, $key ) = @_;
  my $nkey = $self->_nicefor( $key );
  my $rv   = $self->FETCH( $key );
  $self->table->unset( $nkey );