File Coverage

lib/Egg/Response/Headers.pm

Criterion	Covered	Total	%
statement	10	26	38.4
branch	0	2	0.0
condition	0	6	0.0
subroutine	4	8	50.0
pod			n/a
total	14	42	33.3

package Egg::Response::Headers;
#
# Masatoshi Mizuno E<lt>lusheE<64>cpan.orgE<gt>
#
# $Id: Headers.pm 337 2008-05-14 12:30:09Z lushe $
#
use strict;
use Carp qw/croak/;

our $VERSION = '3.00';

sub new {
	my $class= shift;
	tie my %headers, 'Egg::Response::Headers::TieHash', @_;
	bless \%headers, $class;
}
sub header {
	my $self= shift;
	my $key = shift || croak q{ I want key. };
	return $self->{$key} unless @_;
	$self->{$key}= shift;
}
sub remove {
	my $self= shift;
	my $key = shift || croak q{ I want key. };
	CORE::delete($self->{$key});
}
*delete= \&remove;
sub clear {
	my $self= shift;
	%{$self}= ();
	1;
}

package Egg::Response::Headers::TieHash;
use strict;
use Tie::Hash::Indexed;
use Tie::Hash;

our @ISA = 'Tie::ExtraHash';

my $ForwardRegex= qr{^(?:content_type|content_language|location|status)$};

sub TIEHASH {
	my($class, $response)= @_;
	tie my %param, 'Tie::Hash::Indexed';
	bless [\%param, $response], $class;
}
sub FETCH {
	my($self, $key, $org)= &_getkey;
	return $self->[1]->$key if $key=~m{$ForwardRegex};
	$self->[0]{$key};
}
sub STORE {
	my($self, $key, $org, $value)= &_getkey;
	return $self->[1]->$key($value) if $key=~m{$ForwardRegex};
	if ($value eq "") {
		delete($self->[0]{$key}) if exists($self->[0]{$key});
	} else {
		if ($self->[0]{$key}) {
			ref($self->[0]{$key}[0]) eq 'ARRAY'
			  ? do { push @{$self->[0]{$key}}, [$org, $value] }
			  : do { $self->[0]{$key}= [$self->[0]{$key}, [$org, $value]] };
		} else {
			$self->[0]{$key}= [$org, $value];
		}
	}
}
sub DELETE {
	my($self, $key)= &_getkey;
	delete($self->[0]{$key});
}
sub EXISTS {
	my($self, $key)= &_getkey;
	exists($self->[0]{$key});
}
sub _getkey {
	my($self, $org)= splice @_, 0, 2;
	   $org=~s{_} [-]g;
	my $key= lc($org);
	   $key=~s{-} [_]g;
	($self, $key, $org, @_);
}

1;

__END__

=head1 NAME

Egg::Response::Headers - Response header class for Egg.

=head1 SYNOPSIS

  # The response header is set.
  $e->response->headers->{'X-Header'}= 'hoge';

  # The response header is set.
  $e->response->headers->header( 'X-Header' => 'hoge' );

  # The response header is deleted.
  $e->response->headers->remove('X-Header');

  # All the response headers are clear.
  $e->response->headers->clear;

=head1 DESCRIPTION

It is make a response a header class only for L<Egg::Response>.

=head1 METHODS

=head2 new

Constructor.
L<Egg::Response::Headers::TieHash> The object is returned drinking.

  my $headers= $e->response->headers;

The value becomes ARRAY reference of the following content.

=over 4

=item * Original name. Because lc is done as for the key, former name is preserved.

=item * Value of header.

=back

=head2 header ([KEY], [VALUE])

KEY is always necessary.

The value is set when VALUE is given, and the content corresponding to KEY is
returned when omitting it.

  my $hoge= $headers->header('X-Hoge');

  $headers->header( 'X-Hoge' => 'foo' );

=head2 remove ([KEY])

The header corresponding to KEY is deleted.

  $headers->remove('X-Hoge');

=over 4

=item * Alias = delete

=back

=head2 clear

All set headers are cleared.

  $headers->clear;

=head1 SEE ALSO

L<Egg::Release>,
L<Egg::Request>,
L<Tie::Hash>,
L<Tie::Hash::Indexed>,
L<Carp>,

=head1 AUTHOR

Masatoshi Mizuno, E<lt>lusheE<64>cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008 Bee Flag, Corp. E<lt>L<http://egg.bomcity.com/>E<gt>.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.

=cut