Permalink
Browse files

doesn't provide hash slices

  • Loading branch information...
1 parent e64f8ef commit 2343ffb2fa5c895a8bf89a56634155ffcd41f802 Ryo Anazawa committed Sep 24, 2012
Showing with 437 additions and 535 deletions.
  1. +370 −63 lib/CGI/Header.pm
  2. +0 −375 lib/CGI/Header/Entity.pm
  3. +2 −2 t/00_compile.t
  4. +2 −2 t/10_normalization.t
  5. +2 −2 t/11_denormalization.t
  6. +2 −2 t/12_entity.t
  7. +2 −2 t/13_content_type.t
  8. +2 −2 t/14_date.t
  9. +2 −2 t/15_p3p.t
  10. +2 −2 t/16_content_disposition.t
  11. +42 −42 t/20_basic.t
  12. +1 −33 t/21_content_type.t
  13. +4 −4 t/22_date.t
  14. +4 −2 t/24_as_string.t
View
433 lib/CGI/Header.pm
@@ -2,75 +2,243 @@ package CGI::Header;
use 5.008_009;
use strict;
use warnings;
-use overload '%{}' => 'as_hashref', q{""} => 'as_string', fallback => 1;
-use parent 'CGI::Header::Entity';
+use overload q{""} => 'as_string', fallback => 1;
use Carp qw/carp croak/;
use Scalar::Util qw/refaddr/;
+use List::Util qw/first/;
our $VERSION = '0.01';
my %header_of;
sub new {
- my $class = shift;
+ my $class = shift;
my $header = ref $_[0] eq 'HASH' ? shift : { @_ };
- $class->SUPER::new( $header );
+ my $self = bless \do { my $anon_scalar }, $class;
+ my $this = refaddr $self;
+
+ $header_of{ $this } = $header;
+
+ $self;
}
sub get {
- my ( $self, @fields ) = @_;
- my @values = map { $self->FETCH($_) } @fields;
- wantarray ? @values : $values[-1];
+ my $self = shift;
+ my $norm = $self->_normalize( shift );
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+
+ if ( $norm eq '-content_type' ) {
+ my $type = $header->{-type};
+ my $charset = $header->{-charset};
+
+ if ( defined $type and $type eq q{} ) {
+ undef $charset;
+ undef $type;
+ }
+ else {
+ $type ||= 'text/html';
+
+ if ( $type =~ /\bcharset\b/ ) {
+ undef $charset;
+ }
+ elsif ( !defined $charset ) {
+ $charset = 'ISO-8859-1';
+ }
+ }
+
+ return $charset ? "$type; charset=$charset" : $type;
+ }
+ elsif ( $norm eq '-content_disposition' ) {
+ if ( my $filename = $header->{-attachment} ) {
+ return qq{attachment; filename="$filename"};
+ }
+ }
+ elsif ( $norm eq '-date' ) {
+ if ( $self->_date_header_is_fixed ) {
+ require HTTP::Date;
+ return HTTP::Date::time2str( time );
+ }
+ }
+ elsif ( $norm eq '-expires' ) {
+ if ( my $expires = $header->{-expires} ) {
+ require CGI::Util;
+ return CGI::Util::expires( $expires );
+ }
+ }
+ elsif ( $norm eq '-p3p' ) {
+ if ( my $p3p = $header->{-p3p} ) {
+ my $tags = ref $p3p eq 'ARRAY' ? join ' ', @{ $p3p } : $p3p;
+ return qq{policyref="/w3c/p3p.xml", CP="$tags"};
+ }
+ }
+
+ $header->{ $norm };
}
sub set {
- my ( $self, @headers ) = @_;
-
- if ( @headers % 2 == 0 ) {
- while ( my ($field, $value) = splice @headers, 0, 2 ) {
- $self->STORE( $field => $value );
+ my $self = shift;
+ my $norm = $self->_normalize( shift );
+ my $value = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+
+ if ( $norm eq '-date' ) {
+ if ( $self->_date_header_is_fixed ) {
+ return carp 'The Date header is fixed';
}
}
- else {
- croak 'Odd number of elements passed to set()';
+ elsif ( $norm eq '-content_type' ) {
+ $header->{-type} = $value;
+ $header->{-charset} = q{};
+ delete $header->{ $norm };
+ return;
+ }
+ elsif ( $norm eq '-content_disposition' ) {
+ delete $header->{-attachment};
+ }
+ elsif ( $norm eq '-cookie' ) {
+ delete $header->{-date};
+ }
+ elsif ( $norm eq '-p3p' or $norm eq '-expires' ) {
+ carp "Can't assign to '$norm' directly, use accessors instead";
+ return;
}
+ $header->{ $norm } = $value;
+
return;
}
sub delete {
- my ( $self, @fields ) = @_;
+ my $self = shift;
+ my $field = shift;
+ my $norm = $self->_normalize( $field );
+ my $value = defined wantarray && $self->get( $field );
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+
+ if ( $norm eq '-date' ) {
+ if ( $self->_date_header_is_fixed ) {
+ return carp 'The Date header is fixed';
+ }
+ }
+ elsif ( $norm eq '-content_type' ) {
+ delete $header->{-charset};
+ $header->{-type} = q{};
+ }
+ elsif ( $norm eq '-content_disposition' ) {
+ delete $header->{-attachment};
+ }
+
+ delete $header->{ $norm };
+
+ $value;
+}
+
+sub clear {
+ my $self = shift;
+ my $this = refaddr $self;
+ %{ $header_of{$this} } = ( -type => q{} );
+ return;
+}
+
+sub exists {
+ my $self = shift;
+ my $norm = $self->_normalize( shift );
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
- if ( wantarray ) {
- return map { $self->DELETE($_) } @fields;
+ if ( $norm eq '-content_type' ) {
+ return !defined $header->{-type} || $header->{-type} ne q{};
}
- elsif ( defined wantarray ) {
- my $deleted = @fields && $self->DELETE( pop @fields );
- $self->DELETE( $_ ) for @fields;
- return $deleted;
+ elsif ( $norm eq '-content_disposition' ) {
+ return 1 if $header->{-attachment};
}
- else {
- $self->DELETE( $_ ) for @fields;
+ elsif ( $norm eq '-date' ) {
+ return 1 if first { $header->{$_} } qw(-nph -expires -cookie);
}
+ $header->{ $norm };
+}
+
+sub DESTROY {
+ my $self = shift;
+ my $this = refaddr $self;
+ delete $header_of{ $this };
return;
}
-sub clear { shift->CLEAR }
-sub exists { shift->EXISTS( @_ ) }
-sub is_empty { not shift->SCALAR }
+sub header {
+ my $self = shift;
+ my $this = refaddr $self;
+ $header_of{ $this };
+}
+
+BEGIN {
+ *TIEHASH = \&new;
+ *STORE = \&set;
+ *FETCH = \&get;
+ *CLEAR = \&clear;
+ *EXISTS = \&exists;
+ *DELETE = \&delete;
+}
+
+sub SCALAR {
+ my $self = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+ !defined $header->{-type} || first { $_ } values %{ $header };
+}
+
+sub is_empty { not shift->SCALAR }
+
+BEGIN {
+ require Storable;
+ *clone = \&Storable::dclone;
+}
+
+sub field_names {
+ my $self = shift;
+ my $this = refaddr $self;
+ my %header = %{ $header_of{$this} }; # copy
+
+ my @fields;
+
+ push @fields, 'Status' if delete $header{-status};
+ push @fields, 'Window-Target' if delete $header{-target};
+ push @fields, 'P3P' if delete $header{-p3p};
+
+ push @fields, 'Set-Cookie' if my $cookie = delete $header{-cookie};
+ push @fields, 'Expires' if my $expires = delete $header{-expires};
+ push @fields, 'Date' if delete $header{-nph} or $cookie or $expires;
+
+ push @fields, 'Content-Disposition' if delete $header{-attachment};
+
+ my $type = delete @header{ '-charset', '-type' };
+
+ # not ordered
+ while ( my ($norm, $value) = each %header ) {
+ next unless $value;
+ push @fields, $self->_denormalize( $norm );
+ }
+
+ push @fields, 'Content-Type' if !defined $type or $type ne q{};
+
+ @fields;
+}
sub flatten {
my $self = shift;
- map { $_, $self->FETCH($_) } $self->field_names;
+ map { $_, $self->get($_) } $self->field_names;
}
sub each {
my ( $self, $callback ) = @_;
if ( ref $callback eq 'CODE' ) {
for my $field ( $self->field_names ) {
- $callback->( $field, $self->FETCH($field) );
+ $callback->( $field, $self->get($field) );
}
}
else {
@@ -80,25 +248,129 @@ sub each {
return;
}
-sub as_hashref {
+sub attachment {
+ my $self = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+
+ if ( @_ ) {
+ my $filename = shift;
+ delete $header->{-content_disposition};
+ $header->{-attachment} = $filename;
+ return;
+ }
+
+ $header->{-attachment};
+}
+
+sub expires {
+ my $self = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+
+ if ( @_ ) {
+ my $expires = shift;
+ delete $header->{-date}; # if $expires;
+ $header->{-expires} = $expires;
+ return;
+ }
+
+ $header->{-expires};
+}
+
+sub nph {
+ my $self = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+
+ if ( @_ ) {
+ my $nph = shift;
+ delete $header->{-date} if $nph;
+ $header->{-nph} = $nph;
+ return;
+ }
+
+ $header->{-nph};
+}
+
+sub p3p_tags {
+ my $self = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+
+ if ( @_ ) {
+ $header->{-p3p} = @_ > 1 ? [ @_ ] : shift;
+ }
+ elsif ( my $tags = $header->{-p3p} ) {
+ my @tags = ref $tags eq 'ARRAY' ? @{ $tags } : split ' ', $tags;
+ return wantarray ? @tags : $tags[0];
+ }
+
+ return;
+}
+
+sub target {
my $self = shift;
my $this = refaddr $self;
+ my $header = $header_of{ $this };
+ $header->{-target} = shift if @_;
+ $header->{-target};
+}
- unless ( exists $header_of{$this} ) {
- tie my %header => 'CGI::Header::Entity' => $self->header;
- $header_of{ $this } = \%header;
+sub get_cookie {
+ my $self = shift;
+ my $name = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+
+ my @cookies = do {
+ my $cookies = $header->{-cookie};
+ return unless $cookies;
+ ref $cookies eq 'ARRAY' ? @{ $cookies } : $cookies;
+ };
+
+ my @values;
+ for my $cookie ( @cookies ) {
+ next unless ref $cookie eq 'CGI::Cookie';
+ next unless $cookie->name eq $name;
+ push @values, $cookie;
}
- $header_of{ $this };
+ wantarray ? @values : $values[0];
+}
+
+sub dump {
+ my $self = shift;
+ my $this = refaddr $self;
+
+ require Data::Dumper;
+
+ local $Data::Dumper::Indent = 1;
+
+ my %dump = (
+ __PACKAGE__, {
+ header => $header_of{ $this },
+ },
+ @_,
+ );
+
+ Data::Dumper::Dumper( \%dump );
+}
+
+sub _date_header_is_fixed {
+ my $self = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
+ $header->{-expires} || $header->{-cookie} || $header->{-nph};
}
sub content_type {
my $self = shift;
- return $self->STORE( 'Content-Type' => shift ) if @_;
+ return $self->set( 'Content-Type' => shift ) if @_;
my ( $media_type, $rest ) = do {
- my $content_type = $self->FETCH( 'Content-Type' );
+ my $content_type = $self->get( 'Content-Type' );
return q{} unless defined $content_type;
split /;\s*/, $content_type, 2;
};
@@ -115,9 +387,9 @@ sub date {
require HTTP::Date;
if ( defined $time ) {
- $self->STORE( Date => HTTP::Date::time2str($time) );
+ $self->set( Date => HTTP::Date::time2str($time) );
}
- elsif ( my $date = $self->FETCH('Date') ) {
+ elsif ( my $date = $self->get('Date') ) {
return HTTP::Date::str2time( $date );
}
@@ -135,13 +407,13 @@ sub set_cookie {
\%args;
});
- my $cookies = $self->FETCH( 'Set-Cookie' );
+ my $cookies = $self->get( 'Set-Cookie' );
if ( !$cookies ) {
- return $self->STORE( 'Set-Cookie' => [ $new_cookie ] );
+ return $self->set( 'Set-Cookie' => [ $new_cookie ] );
}
elsif ( ref $cookies ne 'ARRAY' ) {
- $self->STORE( 'Set-Cookie' => $cookies = [ $cookies ] );
+ $self->set( 'Set-Cookie' => $cookies = [ $cookies ] );
}
my $set;
@@ -159,36 +431,40 @@ sub set_cookie {
}
sub status {
- my $self = shift;
+ my $self = shift;
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
require HTTP::Status;
if ( @_ ) {
my $code = shift;
my $message = HTTP::Status::status_message( $code );
- return $self->STORE( Status => "$code $message" ) if $message;
+ return $header->{-status} = "$code $message" if $message;
carp "Unknown status code '$code' passed to status()";
}
- elsif ( my $status = $self->FETCH('Status') ) {
+ elsif ( my $status = $header->{-status} ) {
return substr( $status, 0, 3 );
}
else {
- return 200;
+ return '200';
}
return;
}
sub as_string {
- my $self = shift;
- my $eol = defined $_[0] ? shift : "\n";
+ my $self = shift;
+ my $eol = defined $_[0] ? shift : "\n";
+ my $this = refaddr $self;
+ my $header = $header_of{ $this };
my @lines;
- if ( $self->nph ) {
- my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
- my $software = $ENV{SERVER_SOFTWARE} || 'cmdline';
- my $status = $self->FETCH('Status') || '200 OK';
+ if ( $header->{-nph} ) {
+ my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
+ my $software = $ENV{SERVER_SOFTWARE} || 'cmdline';
+ my $status = $header->{-status} || '200 OK';
push @lines, "$protocol $status";
push @lines, "Server: $software";
}
@@ -211,22 +487,53 @@ sub as_string {
join $eol, @lines, q{};
}
-sub dump {
- my $self = shift;
- my $package = __PACKAGE__;
+sub STORABLE_freeze {
+ my ( $self, $cloning ) = @_;
+ ( q{}, $header_of{ refaddr $self } );
+}
- $self->SUPER::dump(
- $package => {
- header => { $self->flatten },
- },
- @_,
- );
+sub STORABLE_thaw {
+ my ( $self, $serialized, $cloning, $header ) = @_;
+ $header_of{ refaddr $self } = $header;
+ $self;
}
-sub DESTROY {
- my $self = shift;
- delete $header_of{ refaddr $self };
- $self->SUPER::DESTROY;
+my %norm_of = (
+ -attachment => q{}, -charset => q{},
+ -cookie => q{}, -nph => q{},
+ -set_cookie => q{-cookie}, -target => q{},
+ -type => q{}, -window_target => q{-target},
+);
+
+sub _normalize {
+ my $class = shift;
+ my $field = lc shift;
+
+ # transliterate dashes into underscores
+ $field =~ tr{-}{_};
+
+ # add an initial dash
+ $field = "-$field";
+
+ exists $norm_of{$field} ? $norm_of{ $field } : $field;
+}
+
+my %field_name_of = (
+ -attachment => 'Content-Disposition', -cookie => 'Set-Cookie',
+ -p3p => 'P3P', -target => 'Window-Target',
+ -type => 'Content-Type',
+);
+
+sub _denormalize {
+ my ( $class, $norm ) = @_;
+
+ unless ( exists $field_name_of{$norm} ) {
+ ( my $field = $norm ) =~ s/^-//;
+ $field =~ tr/_/-/;
+ $field_name_of{ $norm } = ucfirst $field;
+ }
+
+ $field_name_of{ $norm };
}
1;
View
375 lib/CGI/Header/Entity.pm
@@ -1,375 +0,0 @@
-package CGI::Header::Entity;
-use strict;
-use warnings;
-use Carp qw/carp croak/;
-use List::Util qw/first/;
-use Scalar::Util qw/refaddr/;
-
-my %header_of;
-
-sub TIEHASH {
- my $class = shift;
- my $header = ref $_[0] eq 'HASH' ? shift : {};
- my $self = bless \do { my $anon_scalar }, $class;
- $header_of{ refaddr $self } = $header;
- $self;
-}
-
-BEGIN { *new = \&TIEHASH }
-
-sub FETCH {
- my $self = shift;
- my $norm = $self->_normalize( shift );
- my $header = $header_of{ refaddr $self };
-
- if ( $norm eq '-content_type' ) {
- my $type = $header->{-type};
- my $charset = $header->{-charset};
-
- if ( defined $type and $type eq q{} ) {
- undef $charset;
- undef $type;
- }
- else {
- $type ||= 'text/html';
-
- if ( $type =~ /\bcharset\b/ ) {
- undef $charset;
- }
- elsif ( !defined $charset ) {
- $charset = 'ISO-8859-1';
- }
- }
-
- return $charset ? "$type; charset=$charset" : $type;
- }
- elsif ( $norm eq '-content_disposition' ) {
- if ( my $filename = $header->{-attachment} ) {
- return qq{attachment; filename="$filename"};
- }
- }
- elsif ( $norm eq '-date' ) {
- if ( $self->_date_header_is_fixed ) {
- require HTTP::Date;
- return HTTP::Date::time2str( time );
- }
- }
- elsif ( $norm eq '-expires' ) {
- if ( my $expires = $header->{-expires} ) {
- require CGI::Util;
- return CGI::Util::expires( $expires );
- }
- }
- elsif ( $norm eq '-p3p' ) {
- if ( my $p3p = $header->{-p3p} ) {
- my $tags = ref $p3p eq 'ARRAY' ? join ' ', @{ $p3p } : $p3p;
- return qq{policyref="/w3c/p3p.xml", CP="$tags"};
- }
- }
-
- $header->{ $norm };
-}
-
-sub STORE {
- my $self = shift;
- my $norm = $self->_normalize( shift );
- my $value = shift;
- my $header = $header_of{ refaddr $self };
-
- if ( $norm eq '-date' ) {
- if ( $self->_date_header_is_fixed ) {
- return carp 'The Date header is fixed';
- }
- }
- elsif ( $norm eq '-content_type' ) {
- $header->{-charset} = q{};
- $header->{-type} = $value;
- return;
- }
- elsif ( $norm eq '-content_disposition' ) {
- delete $header->{-attachment};
- }
- elsif ( $norm eq '-cookie' ) {
- delete $header->{-date};
- }
- elsif ( $norm eq '-p3p' or $norm eq '-expires' ) {
- carp "Can't assign to '$norm' directly, use accessors instead";
- return;
- }
-
- $header->{ $norm } = $value;
-
- return;
-}
-
-sub DELETE {
- my $self = shift;
- my $field = shift;
- my $norm = $self->_normalize( $field );
- my $deleted = defined wantarray && $self->FETCH( $field );
- my $header = $header_of{ refaddr $self };
-
- if ( $norm eq '-date' ) {
- if ( $self->_date_header_is_fixed ) {
- return carp 'The Date header is fixed';
- }
- }
- elsif ( $norm eq '-content_type' ) {
- delete $header->{-charset};
- $header->{-type} = q{};
- }
- elsif ( $norm eq '-content_disposition' ) {
- delete $header->{-attachment};
- }
-
- delete $header->{ $norm };
-
- $deleted;
-}
-
-sub CLEAR {
- my $self = shift;
- my $this = refaddr $self;
- %{ $header_of{$this} } = ( -type => q{} );
- return;
-}
-
-sub EXISTS {
- my $self = shift;
- my $norm = $self->_normalize( shift );
- my $header = $header_of{ refaddr $self };
-
- if ( $norm eq '-content_type' ) {
- return !defined $header->{-type} || $header->{-type} ne q{};
- }
- elsif ( $norm eq '-content_disposition' ) {
- return 1 if $header->{-attachment};
- }
- elsif ( $norm eq '-date' ) {
- return 1 if first { $header->{$_} } qw(-nph -expires -cookie);
- }
-
- $header->{ $norm };
-}
-
-sub SCALAR {
- my $self = shift;
- my $header = $header_of{ refaddr $self };
- !defined $header->{-type} || first { $_ } values %{ $header };
-}
-
-sub DESTROY {
- my $self = shift;
- delete $header_of{ refaddr $self };
- return;
-}
-
-sub header { $header_of{ refaddr shift } }
-
-BEGIN {
- require Storable;
- *clone = \&Storable::dclone;
-}
-
-sub field_names {
- my $self = shift;
- my $this = refaddr $self;
- my %header = %{ $header_of{$this} }; # copy
-
- my @fields;
-
- push @fields, 'Status' if delete $header{-status};
- push @fields, 'Window-Target' if delete $header{-target};
- push @fields, 'P3P' if delete $header{-p3p};
-
- push @fields, 'Set-Cookie' if my $cookie = delete $header{-cookie};
- push @fields, 'Expires' if my $expires = delete $header{-expires};
- push @fields, 'Date' if delete $header{-nph} or $cookie or $expires;
-
- push @fields, 'Content-Disposition' if delete $header{-attachment};
-
- my $type = delete @header{ '-charset', '-type' };
-
- # not ordered
- while ( my ($norm, $value) = each %header ) {
- push @fields, $self->_denormalize( $norm ) if $value;
- }
-
- push @fields, 'Content-Type' if !defined $type or $type ne q{};
-
- @fields;
-}
-
-sub attachment {
- my $self = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
-
- if ( @_ ) {
- my $filename = shift;
- delete $header->{-content_disposition};
- $header->{-attachment} = $filename;
- }
- else {
- return $header->{-attachment};
- }
-
- return;
-}
-
-sub expires {
- my $self = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
-
- if ( @_ ) {
- my $expires = shift;
- delete $header->{-date};
- $header->{-expires} = $expires;
- }
- elsif ( my $expires = $self->FETCH('Expires') ) {
- require HTTP::Date;
- return HTTP::Date::str2time( $expires );
- }
-
- return;
-}
-
-sub nph {
- my $self = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
-
- if ( @_ ) {
- my $nph = shift;
- delete $header->{-date} if $nph;
- $header->{-nph} = $nph;
- }
- else {
- return $header->{-nph};
- }
-
- return;
-}
-
-sub p3p_tags {
- my $self = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
-
- if ( @_ ) {
- $header->{-p3p} = @_ > 1 ? [ @_ ] : shift;
- }
- elsif ( my $tags = $header->{-p3p} ) {
- my @tags = ref $tags eq 'ARRAY' ? @{ $tags } : split ' ', $tags;
- return wantarray ? @tags : $tags[0];
- }
-
- return;
-}
-
-sub target {
- my $self = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
- $header->{-target} = shift if @_;
- $header->{-target};
-}
-
-sub get_cookie {
- my $self = shift;
- my $name = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
-
- my @cookies = do {
- my $cookies = $header->{-cookie};
- return unless $cookies;
- ref $cookies eq 'ARRAY' ? @{ $cookies } : $cookies;
- };
-
- my @values;
- for my $cookie ( @cookies ) {
- next unless ref $cookie eq 'CGI::Cookie';
- next unless $cookie->name eq $name;
- push @values, $cookie;
- }
-
- wantarray ? @values : $values[0];
-}
-
-sub dump {
- my $self = shift;
- my $this = refaddr $self;
- my $package = __PACKAGE__;
-
- require Data::Dumper;
-
- local $Data::Dumper::Indent = 1;
-
- my %dump = (
- $package => {
- header => $header_of{ $this },
- },
- @_,
- );
-
- Data::Dumper::Dumper( \%dump );
-}
-
-sub _date_header_is_fixed {
- my $self = shift;
- my $header = $header_of{ refaddr $self };
- $header->{-expires} || $header->{-cookie} || $header->{-nph};
-}
-
-sub STORABLE_freeze {
- my ( $self, $cloning ) = @_;
- ( q{}, $header_of{ refaddr $self } );
-}
-
-sub STORABLE_thaw {
- my ( $self, $serialized, $cloning, $header ) = @_;
- $header_of{ refaddr $self } = $header;
- $self;
-}
-
-my %norm_of = (
- -attachment => q{}, -charset => q{},
- -cookie => q{}, -nph => q{},
- -set_cookie => q{-cookie}, -target => q{},
- -type => q{}, -window_target => q{-target},
-);
-
-sub _normalize {
- my $class = shift;
- my $field = lc shift;
-
- # transliterate dashes into underscores
- $field =~ tr{-}{_};
-
- # add an initial dash
- $field = "-$field";
-
- exists $norm_of{$field} ? $norm_of{ $field } : $field;
-}
-
-my %field_name_of = (
- -attachment => 'Content-Disposition', -cookie => 'Set-Cookie',
- -p3p => 'P3P', -target => 'Window-Target',
- -type => 'Content-Type',
-);
-
-sub _denormalize {
- my ( $class, $norm ) = @_;
-
- unless ( exists $field_name_of{$norm} ) {
- ( my $field = $norm ) =~ s/^-//;
- $field =~ tr/_/-/;
- $field_name_of{ $norm } = ucfirst $field;
- }
-
- $field_name_of{ $norm };
-}
-
-1;
View
4 t/00_compile.t
@@ -1,7 +1,7 @@
use strict;
-use Test::More tests => 2;
+use Test::More tests => 1;
BEGIN {
- use_ok 'CGI::Header::Entity';
+ #use_ok 'CGI::Header::Entity';
use_ok 'CGI::Header';
}
View
4 t/10_normalization.t
@@ -1,11 +1,11 @@
use strict;
use warnings;
-use CGI::Header::Entity;
+use CGI::Header;
use Test::Base;
plan tests => 1 * blocks();
-my $header = 'CGI::Header::Entity';
+my $header = 'CGI::Header';
run {
my $block = shift;
View
4 t/11_denormalization.t
@@ -1,10 +1,10 @@
use strict;
-use CGI::Header::Entity;
+use CGI::Header;
use Test::Base;
plan tests => 1 * blocks();
-my $header = 'CGI::Header::Entity';
+my $header = 'CGI::Header';
run {
my $block = shift;
View
4 t/12_entity.t
@@ -1,9 +1,9 @@
use strict;
use warnings;
-use CGI::Header::Entity;
+use CGI::Header;
use Test::More tests => 16;
-my $class = 'CGI::Header::Entity';
+my $class = 'CGI::Header';
can_ok $class, qw(
TIEHASH FETCH STORE DELETE EXISTS CLEAR SCALAR DESTROY
View
4 t/13_content_type.t
@@ -1,10 +1,10 @@
use strict;
use warnings;
-use CGI::Header::Entity;
+use CGI::Header;
use Test::More tests => 28;
my %adaptee;
-my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
+my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
%adaptee = ( -type => q{} );
is $adapter{Content_Type}, undef;
View
4 t/14_date.t
@@ -1,12 +1,12 @@
use strict;
use warnings;
-use CGI::Header::Entity;
+use CGI::Header;
use HTTP::Date;
use Test::More tests => 11;
use Test::Warn;
my %adaptee;
-my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
+my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
%adaptee = ( -nph => 1 );
is $adapter{Date}, time2str( time );
View
4 t/15_p3p.t
@@ -1,11 +1,11 @@
use strict;
use warnings;
-use CGI::Header::Entity;
+use CGI::Header;
use Test::More tests => 11;
use Test::Warn;
my %adaptee;
-my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
+my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
%adaptee = ( -p3p => [qw/CAO DSP LAW CURa/] );
is $adapter{P3P}, 'policyref="/w3c/p3p.xml", CP="CAO DSP LAW CURa"';
View
4 t/16_content_disposition.t
@@ -1,9 +1,9 @@
use strict;
-use CGI::Header::Entity;
+use CGI::Header;
use Test::More tests => 18;
my %adaptee;
-my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
+my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
%adaptee = ( -attachment => 'genome.jpg' );
is $adapter{Content_Disposition}, 'attachment; filename="genome.jpg"';
View
84 t/20_basic.t
@@ -3,7 +3,7 @@ use warnings;
use CGI::Header;
use CGI::Cookie;
use CGI::Util 'expires';
-use Test::More tests => 20;
+use Test::More tests => 17;
use Test::Warn;
use Test::Exception;
@@ -12,8 +12,8 @@ my $class = 'CGI::Header';
ok $class->isa( 'CGI::Header' );
can_ok $class, qw(
- new clone clear delete exists get set is_empty as_hashref each flatten
- content_type date status
+ new clone clear delete exists get set is_empty each flatten
+ date status
DESTROY
);
@@ -48,30 +48,30 @@ ok !$header->exists('Bar'), 'should return false';
%header = ( -foo => 'bar', -bar => 'baz' );
is $header->get('Foo'), 'bar';
is $header->get('Baz'), undef;
-is $header->get('Foo', 'Bar'), 'baz';
-is_deeply [ $header->get('Foo', 'Bar') ], [ 'bar', 'baz' ];
+#is $header->get('Foo', 'Bar'), 'baz';
+#is_deeply [ $header->get('Foo', 'Bar') ], [ 'bar', 'baz' ];
# clear()
%header = ( -foo => 'bar' );
$header->clear;
is_deeply \%header, { -type => q{} }, 'should be empty';
subtest 'set()' => sub {
- my $expected = qr{^Odd number of elements passed to set\(\)};
- throws_ok { $header->set('Foo') } $expected;
+ #my $expected = qr{^Odd number of elements passed to set\(\)};
+ #throws_ok { $header->set('Foo') } $expected;
%header = ();
$header->set(
Foo => 'bar',
- Bar => 'baz',
- Baz => 'qux',
+ #Bar => 'baz',
+ #Baz => 'qux',
);
my %expected = (
-foo => 'bar',
- -bar => 'baz',
- -baz => 'qux',
+ #-bar => 'baz',
+ #-baz => 'qux',
);
is_deeply \%header, \%expected, 'set() multiple elements';
@@ -85,21 +85,21 @@ subtest 'delete()' => sub {
is $header->delete('Foo'), 'bar';
is_deeply \%header, {};
- %header = (
- -foo => 'bar',
- -bar => 'baz',
- );
+#%header = (
+# -foo => 'bar',
+# -bar => 'baz',
+# );
- is_deeply [ $header->delete('Foo', 'Bar') ], [ 'bar', 'baz' ];
- is_deeply \%header, {};
+# is_deeply [ $header->delete('Foo', 'Bar') ], [ 'bar', 'baz' ];
+# is_deeply \%header, {};
- %header = (
- -foo => 'bar',
- -bar => 'baz',
- );
+# %header = (
+# -foo => 'bar',
+# -bar => 'baz',
+# );
- ok $header->delete('Foo', 'Bar') eq 'baz';
- is_deeply \%header, {};
+# ok $header->delete('Foo', 'Bar') eq 'baz';
+# is_deeply \%header, {};
};
subtest 'each()' => sub {
@@ -163,31 +163,31 @@ subtest 'flatten()' => sub {
is_deeply \@got, \@expected;
};
-subtest 'as_hashref()' => sub {
- my $got = $header->as_hashref;
- ok ref $got eq 'HASH';
+#subtest 'as_hashref()' => sub {
+# my $got = $header->as_hashref;
+# ok ref $got eq 'HASH';
#ok tied %{ $got } eq $header;
- %header = ();
- $header->{Foo} = 'bar';
- is_deeply \%header, { -foo => 'bar' }, 'store';
+# %header = ();
+# $header->{Foo} = 'bar';
+# is_deeply \%header, { -foo => 'bar' }, 'store';
- %header = ( -foo => 'bar' );
- is $header->{Foo}, 'bar', 'fetch';
- is $header->{Bar}, undef;
+# %header = ( -foo => 'bar' );
+# is $header->{Foo}, 'bar', 'fetch';
+# is $header->{Bar}, undef;
- %header = ( -foo => 'bar' );
- ok exists $header->{Foo}, 'exists';
- ok !exists $header->{Bar};
+# %header = ( -foo => 'bar' );
+# ok exists $header->{Foo}, 'exists';
+# ok !exists $header->{Bar};
- %header = ( -foo => 'bar' );
- is delete $header->{Foo}, 'bar';
- is_deeply \%header, {}, 'delete';
+# %header = ( -foo => 'bar' );
+# is delete $header->{Foo}, 'bar';
+# is_deeply \%header, {}, 'delete';
- %header = ( -foo => 'bar' );
- %{ $header } = ();
- is_deeply \%header, { -type => q{} }, 'clear';
-};
+# %header = ( -foo => 'bar' );
+# %{ $header } = ();
+# is_deeply \%header, { -type => q{} }, 'clear';
+#};
subtest 'status()' => sub {
%header = ();
View
34 t/21_content_type.t
@@ -1,43 +1,11 @@
use strict;
use warnings;
use CGI::Header;
-use Test::More tests => 2;
+use Test::More tests => 1;
my %adaptee;
my $adapter = CGI::Header->new( \%adaptee );
-#subtest 'charset()' => sub {
-# %adaptee = ();
-# is $adapter->charset, 'ISO-8859-1';
-
-# %adaptee = ( -charset => q{} );
-# is $adapter->charset, undef;
-
-# %adaptee = ( -type => q{} );
-# is $adapter->charset, undef;
-
-# %adaptee = ( -type => 'text/html; charset=euc-jp' );
-# is $adapter->charset, 'EUC-JP';
-
-# %adaptee = ( -type => 'text/html; charset=iso-8859-1; Foo=1' );
-# is $adapter->charset, 'ISO-8859-1';
-
-# %adaptee = ( -type => 'text/html; charset="iso-8859-1"; Foo=1' );
-# is $adapter->charset, 'ISO-8859-1';
-
-# %adaptee = ( -type => 'text/html; charset = "iso-8859-1"; Foo=1' );
-# is $adapter->charset, 'ISO-8859-1';
-
-# %adaptee = ( -type => 'text/html;\r\n charset = "iso-8859-1"; Foo=1' );
-# is $adapter->charset, 'ISO-8859-1';
-
-# %adaptee = ( -type => 'text/html;\r\n charset = iso-8859-1 ; Foo=1' );
-# is $adapter->charset, 'ISO-8859-1';
-
-# %adaptee = ( -type => 'text/html;\r\n charset = iso-8859-1 ' );
-# is $adapter->charset, 'ISO-8859-1';
-#};
-
subtest 'content_type()' => sub {
%adaptee = ();
is $adapter->content_type, 'text/html';
View
8 t/22_date.t
@@ -28,8 +28,8 @@ subtest 'expires()' => sub {
is $header->expires, $now, 'get expires()';
is $header{-expires}, $now;
- $now++;
- $header->expires( 'Sat, 07 Jul 2012 05:05:10 GMT' );
- is $header->expires, $now, 'get expires()';
- is $header{-expires}, 'Sat, 07 Jul 2012 05:05:10 GMT';
+ #$now++;
+ #$header->expires( 'Sat, 07 Jul 2012 05:05:10 GMT' );
+ #is $header->expires, $now, 'get expires()';
+ #is $header{-expires}, 'Sat, 07 Jul 2012 05:05:10 GMT';
};
View
6 t/24_as_string.t
@@ -9,7 +9,7 @@ my $header = CGI::Header->new( -nph => 1 );
$header->set(
'Content-Type' => 'text/plain; charset=utf-8',
- 'Window-Target' => 'ResultsWindow',
+ #'Window-Target' => 'ResultsWindow',
);
$header->attachment( 'genome.jpg' );
@@ -20,9 +20,11 @@ $header->p3p_tags( qw/CAO DSP LAW CURa/ );
$header->set_cookie( foo => 'bar' );
$header->set_cookie( bar => 'baz' );
-$header->{Ingredients} = join "$CRLF ", qw(ham eggs bacon);
+$header->set( Ingredients => join "$CRLF ", qw(ham eggs bacon) );
my $got = $header->as_string( $CRLF ) . $CRLF;
my $expected = CGI::header( $header->header );
is $got, $expected;
+
+#warn $header->dump;

0 comments on commit 2343ffb

Please sign in to comment.