File Coverage

blib/lib/CGI/Header.pm

Criterion	Covered	Total	%
statement	82	83	98.8
branch	13	14	92.8
condition	6	8	75.0
subroutine	22	22	100.0
pod	9	10	90.0
total	132	137	96.3

package CGI::Header;
use 5.008_009;
use strict;
use warnings;
use Carp qw/croak/;

our $VERSION = '0.63';

sub new {
    my $class = shift;
    my %args = @_ == 1 ? %{$_[0]} : @_;
    ( bless \%args => $class )->_rehash;
}

sub header {
    $_[0]->{header} ||= {};
}

sub query {
    my $self = shift;
    $self->{query} ||= $self->_build_query;
}

sub _build_query {
    require CGI;
    CGI::self_or_default();
}

sub _alias {
    my $self = shift;
    $self->{alias} ||= $self->_build_alias;
}

sub _build_alias {
    +{
        'content-type' => 'type',
        'cookie'       => 'cookies',
    };
}

sub _normalize {
    my ( $self, $key ) = @_;
    my $alias = $self->_alias;
    my $prop = lc $key;
    $prop =~ s/^-//;
    $prop =~ tr/_/-/;
    $prop = $alias->{$prop} if exists $alias->{$prop};
    $prop;
}

sub _rehash {
    my $self   = shift;
    my $header = $self->header;

    for my $key ( keys %$header ) {
        my $prop = $self->_normalize( $key );
        next if $key eq $prop; # $key is normalized
        croak "Property '$prop' already exists" if exists $header->{$prop};
        $header->{$prop} = delete $header->{$key}; # rename $key to $prop
    }

    $self;
}

sub get {
    my ( $self, @keys ) = @_;
    my @props = map { $self->_normalize($_) } @keys;
    @{ $self->header }{ @props };
}

sub set {
    my ( $self, @pairs ) = @_;
    my $header = $self->header;

    croak 'Odd number of arguments passed to set()' if @pairs % 2;

    my @values;
    while ( my ($key, $value) = splice @pairs, 0, 2 ) {
        my $prop = $self->_normalize( $key );
        push @values, $header->{$prop} = $value;
    }

    wantarray ? @values : $values[-1];
}

sub exists {
    my ( $self, $key ) = @_;
    my $prop = $self->_normalize( $key );
    exists $self->header->{$prop};
}

sub delete {
    my ( $self, @keys ) = @_;
    my @props = map { $self->_normalize($_) } @keys;
    delete @{ $self->header }{ @props };
}

sub clear {
    my $self = shift;
    undef %{ $self->header };
    $self;
}

# See also Moose::Meta::Method::Accessor::Native::Hash

BEGIN {
    for my $method (qw/
        attachment
        charset
        cookies
        expires
        nph
        p3p
        status
        target
        type
    /) {
        my $body = sub {
            my $self = shift;
            return $self->header->{$method} unless @_;
            $self->header->{$method} = shift;
            $self;
        };

        no strict 'refs';
        *$method = $body;
    }
}

sub finalize {
    my $self  = shift;
    my $query = $self->query;
    my $args  = $self->header;

    $query->print( $query->header($args) );

    return;
}

sub clone {
    my $self = shift;
    my %header = %{ $self->header };
    ref( $self )->new( %$self, header => \%header );
}

1;

__END__