Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial commit

  • Loading branch information...
commit a2823551f0e354cbfd5445f94c5ccfac4d11490f 0 parents
Ryo Anazawa authored
4 Changes
@@ -0,0 +1,4 @@
+Revision history for Perl extension CGI::Header.
+
+0.01 Sep 23rd, 2012
+ - Forked from Blosxom::Header
30 Makefile.PL
@@ -0,0 +1,30 @@
+use inc::Module::Install;
+
+all_from 'lib/CGI/Header.pm';
+
+repository 'https://github.com/anazawa/p5-CGI-Header';
+
+requires 'overload' => '1.06';
+requires 'parent' => '0.225';
+requires 'Carp' => '1.10';
+requires 'CGI::Cookie' => '1.29';
+requires 'CGI::Util' => '1.5';
+requires 'Exporter' => '5.63';
+requires 'List::Util' => '1.19';
+requires 'Scalar::Util' => '1.19';
+requires 'Storable' => '2.18';
+
+requires 'HTTP::Date' => '6.02';
+requires 'HTTP::Headers::Util' => '6.03';
+requires 'HTTP::Status' => '6.03';
+
+test_requires 'Test::Base' => '0.60';
+test_requires 'Test::Exception' => '0.31';
+test_requires 'Test::More' => '0.98';
+test_requires 'Test::Pod' => '1.45';
+test_requires 'Test::Warn' => '0.24';
+test_requires 'CGI' => '3.49';
+
+tests 't/*.t xt/*.t';
+
+WriteAll;
28 README
@@ -0,0 +1,28 @@
+This is Perl module CGI::Header.
+
+INSTALLATION
+
+CGI::Header installation is straightforward.
+If your CPAN shell is set up, you should just be able to do
+
+ % cpan CGI::Header
+
+Download it, unpack it, then build it as per the usual:
+
+ % perl Makefile.PL
+ % make && make test
+
+Then install it:
+
+ % make install
+
+DOCUMENTATION
+
+CGI::Header documentation is available as in POD.
+So you can do:
+
+ % perldoc CGI::Header
+
+to read the documentation online with your favorite pager.
+
+Ryo Anazawa
237 lib/CGI/Header.pm
@@ -0,0 +1,237 @@
+package CGI::Header;
+use strict;
+use warnings;
+use overload '%{}' => 'as_hashref', 'fallback' => 1;
+use parent 'CGI::Header::Entity';
+use Carp qw/carp croak/;
+use Scalar::Util qw/refaddr/;
+
+my %header_of;
+
+sub new {
+ my $class = shift;
+ my $header = ref $_[0] eq 'HASH' ? shift : { @_ };
+ my $self = $class->SUPER::new( $header );
+ tie my %header => 'CGI::Header::Entity' => $header;
+ $header_of{ refaddr $self } = \%header;
+ $self;
+}
+
+sub get {
+ my ( $self, @fields ) = @_;
+ my @values = map { $self->FETCH($_) } @fields;
+ wantarray ? @values : $values[-1];
+}
+
+sub set {
+ my ( $self, @headers ) = @_;
+
+ if ( @headers % 2 == 0 ) {
+ while ( my ($field, $value) = splice @headers, 0, 2 ) {
+ $self->STORE( $field => $value );
+ }
+ }
+ else {
+ croak 'Odd number of elements passed to set()';
+ }
+
+ return;
+}
+
+sub delete {
+ my ( $self, @fields ) = @_;
+
+ if ( wantarray ) {
+ return map { $self->DELETE($_) } @fields;
+ }
+ elsif ( defined wantarray ) {
+ my $deleted = @fields && $self->DELETE( pop @fields );
+ $self->DELETE( $_ ) for @fields;
+ return $deleted;
+ }
+ else {
+ $self->DELETE( $_ ) for @fields;
+ }
+
+ return;
+}
+
+sub clear { shift->CLEAR }
+sub exists { shift->EXISTS( @_ ) }
+sub is_empty { not shift->SCALAR }
+
+sub flatten {
+ my $self = shift;
+ map { $_, $self->FETCH($_) } $self->field_names;
+}
+
+sub each {
+ my ( $self, $callback ) = @_;
+
+ if ( ref $callback eq 'CODE' ) {
+ for my $field ( $self->field_names ) {
+ $callback->( $field, $self->FETCH($field) );
+ }
+ }
+ else {
+ croak 'Must provide a code reference to each()';
+ }
+
+ return;
+}
+
+sub as_hashref { $header_of{ refaddr shift } }
+
+sub charset {
+ my $self = shift;
+
+ require HTTP::Headers::Util;
+
+ my %param = do {
+ my $type = $self->FETCH( 'Content-Type' );
+ my ( $params ) = HTTP::Headers::Util::split_header_words( $type );
+ return unless $params;
+ splice @{ $params }, 0, 2;
+ @{ $params };
+ };
+
+ if ( my $charset = $param{charset} ) {
+ $charset =~ s/^\s+//;
+ $charset =~ s/\s+$//;
+ return uc $charset;
+ }
+
+ return;
+}
+
+sub content_type {
+ my $self = shift;
+
+ if ( @_ ) {
+ my $content_type = shift;
+ $self->STORE( 'Content-Type' => $content_type );
+ return;
+ }
+
+ my ( $media_type, $rest ) = do {
+ my $content_type = $self->FETCH( 'Content-Type' );
+ return q{} unless defined $content_type;
+ split /;\s*/, $content_type, 2;
+ };
+
+ $media_type =~ s/\s+//g;
+ $media_type = lc $media_type;
+
+ wantarray ? ($media_type, $rest) : $media_type;
+}
+
+BEGIN { *type = \&content_type }
+
+sub date { shift->_date_header( 'Date', @_ ) }
+
+sub _date_header {
+ my ( $self, $field, $time ) = @_;
+
+ require HTTP::Date;
+
+ if ( defined $time ) {
+ $self->STORE( $field => HTTP::Date::time2str($time) );
+ }
+ elsif ( my $date = $self->FETCH($field) ) {
+ return HTTP::Date::str2time( $date );
+ }
+
+ return;
+}
+
+sub set_cookie {
+ my ( $self, $name, $value ) = @_;
+
+ require CGI::Cookie;
+
+ my $cookies = $self->FETCH( 'Set-Cookie' );
+
+ unless ( ref $cookies eq 'ARRAY' ) {
+ $cookies = $cookies ? [ $cookies ] : [];
+ $self->STORE( 'Set-Cookie' => $cookies );
+ }
+
+ my $new_cookie = CGI::Cookie->new(do {
+ my %args = ref $value eq 'HASH' ? %{ $value } : ( value => $value );
+ $args{name} = $name;
+ \%args;
+ });
+
+ for my $cookie ( @{$cookies} ) {
+ next unless ref $cookie eq 'CGI::Cookie';
+ next unless $cookie->name eq $name;
+ $cookie = $new_cookie;
+ undef $new_cookie;
+ last;
+ }
+
+ push @{ $cookies }, $new_cookie if $new_cookie;
+
+ return;
+}
+
+sub get_cookie {
+ my ( $self, $name ) = @_;
+
+ my @cookies = do {
+ my $cookies = $self->FETCH( 'Set-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 status {
+ my $self = shift;
+
+ require HTTP::Status;
+
+ if ( @_ ) {
+ my $code = shift;
+ my $message = HTTP::Status::status_message( $code );
+ return $self->STORE( Status => "$code $message" ) if $message;
+ carp "Unknown status code '$code' passed to status()";
+ }
+ elsif ( my $status = $self->FETCH('Status') ) {
+ return substr( $status, 0, 3 );
+ }
+ #else {
+ # return 200;
+ #}
+
+ return;
+}
+
+sub target {
+ my $self = shift;
+ return $self->STORE( 'Window-Target' => shift ) if @_;
+ $self->FETCH( 'Window-Target' );
+}
+
+sub STORABLE_thaw {
+ my $self = shift->SUPER::STORABLE_thaw( @_ );
+ tie my %header => 'CGI::Header::Entity' => $self->header;
+ $header_of{ refaddr $self } = \%header;
+ $self;
+}
+
+sub DESTROY {
+ my $self = shift;
+ delete $header_of{ refaddr $self };
+ $self->SUPER::DESTROY;
+}
+
+1;
328 lib/CGI/Header/Entity.pm
@@ -0,0 +1,328 @@
+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 : { -type => q{} };
+ 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};
+
+ # not ordered
+ my $type = delete @header{qw/-charset -type/};
+ 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;
+
+ # CGI::header() automatically adds the Date header
+ 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 _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;
7 t/00_compile.t
@@ -0,0 +1,7 @@
+use strict;
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok 'CGI::Header::Entity';
+ use_ok 'CGI::Header';
+}
66 t/10_normalization.t
@@ -0,0 +1,66 @@
+use strict;
+use warnings;
+use CGI::Header::Entity;
+use Test::Base;
+
+plan tests => 1 * blocks();
+
+my $header = 'CGI::Header::Entity';
+
+run {
+ my $block = shift;
+ is $header->_normalize( $block->input ), $block->expected;
+};
+
+__DATA__
+===
+--- input: foo
+--- expected: -foo
+===
+--- input: Foo
+--- expected: -foo
+===
+--- input: foo-bar
+--- expected: -foo_bar
+===
+--- input: Foo-bar
+--- expected: -foo_bar
+===
+--- input: Foo-Bar
+--- expected: -foo_bar
+===
+--- input: foo_bar
+--- expected: -foo_bar
+===
+--- input: Foo_bar
+--- expected: -foo_bar
+===
+--- input: Foo_Bar
+--- expected: -foo_bar
+===
+--- input: Set-Cookie
+--- expected: -cookie
+===
+--- input: Window-Target
+--- expected: -target
+===
+--- input: P3P
+--- expected: -p3p
+===
+--- input: cookie
+--- expected:
+===
+--- input: target
+--- expected:
+===
+--- input: attachment
+--- expected:
+===
+--- input: charset
+--- expected:
+===
+--- input: nph
+--- expected:
+===
+--- input: type
+--- expected:
35 t/11_denormalization.t
@@ -0,0 +1,35 @@
+use strict;
+use CGI::Header::Entity;
+use Test::Base;
+
+plan tests => 1 * blocks();
+
+my $header = 'CGI::Header::Entity';
+
+run {
+ my $block = shift;
+ is $header->_denormalize( $block->input ), $block->expected;
+};
+
+__DATA__
+===
+--- input: -foo
+--- expected: Foo
+===
+--- input: -foo_bar
+--- expected: Foo-bar
+===
+--- input: -cookie
+--- expected: Set-Cookie
+===
+--- input: -target
+--- expected: Window-Target
+===
+--- input: -p3p
+--- expected: P3P
+===
+--- input: -attachment
+--- expected: Content-Disposition
+===
+--- input: -type
+--- expected: Content-Type
112 t/12_adapter.t
@@ -0,0 +1,112 @@
+use strict;
+use warnings;
+use CGI::Header::Entity;
+use Test::More tests => 16;
+
+my $class = 'CGI::Header::Entity';
+
+can_ok $class, qw(
+ TIEHASH FETCH STORE DELETE EXISTS CLEAR SCALAR DESTROY
+ header field_names
+ p3p_tags expires nph attachment
+ _normalize _denormalize _date_header_is_fixed
+);
+
+subtest 'TIEHASH()' => sub {
+ my $got = $class->TIEHASH;
+ isa_ok $got, $class;
+ is_deeply $got->header, { -type => q{} };
+ my %adaptee;
+ $got = $class->TIEHASH( \%adaptee );
+ is $got->header, \%adaptee;
+};
+
+my %adaptee;
+my $adapter = tie my %adapter, $class, \%adaptee;
+
+# SCALAR
+%adaptee = ();
+ok %adapter;
+%adaptee = ( -type => q{} );
+ok !%adapter;
+
+# CLEAR
+%adaptee = ();
+%adapter = ();
+is_deeply \%adaptee, { -type => q{} };
+
+# EXISTS
+%adaptee = ( -foo => 'bar', -bar => q{} );
+ok exists $adapter{Foo};
+ok !exists $adapter{Bar};
+ok !exists $adapter{Baz};
+
+# DELETE
+%adaptee = ( -foo => 'bar', -bar => 'baz' );
+is delete $adapter{Foo}, 'bar';
+is_deeply \%adaptee, { -bar => 'baz' };
+
+# FETCH
+%adaptee = ( -foo => 'bar' );
+is $adapter{Foo}, 'bar';
+is $adapter{Bar}, undef;
+
+# STORE
+%adaptee = ();
+$adapter{Foo} = 'bar';
+is_deeply \%adaptee, { -foo => 'bar' };
+
+subtest 'nph()' => sub {
+ %adaptee = ();
+
+ $adapter->nph( 1 );
+ ok $adapter->nph;
+ ok $adaptee{-nph} == 1;
+
+ $adapter->nph( 0 );
+ ok !$adapter->nph;
+ ok $adaptee{-nph} == 0;
+
+ %adaptee = ( -date => 'Sat, 07 Jul 2012 05:05:09 GMT' );
+ $adapter->nph( 1 );
+ is_deeply \%adaptee, { -nph => 1 }, '-date should be deleted';
+};
+
+subtest 'field_names()' => sub {
+ %adaptee = ( -type => q{} );
+ is_deeply [ $adapter->field_names ], [], 'should return null array';
+
+ %adaptee = (
+ -nph => 1,
+ -status => 1,
+ -target => 1,
+ -p3p => 1,
+ -cookie => 1,
+ -expires => 1,
+ -attachment => 1,
+ -foo_bar => 1,
+ -foo => q{},
+ -bar => undef,
+ );
+
+ my @got = $adapter->field_names;
+
+ my @expected = qw(
+ Status
+ Window-Target
+ P3P
+ Set-Cookie
+ Expires
+ Date
+ Content-Disposition
+ Foo-bar
+ Content-Type
+ );
+
+ is_deeply \@got, \@expected;
+};
+
+subtest 'DESTROY()' => sub {
+ $adapter->DESTROY;
+ ok !$adapter->header;
+};
105 t/13_content_type.t
@@ -0,0 +1,105 @@
+use strict;
+use warnings;
+use CGI::Header::Entity;
+use Test::More tests => 28;
+
+my %adaptee;
+my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
+
+%adaptee = ( -type => q{} );
+is $adapter{Content_Type}, undef;
+ok !exists $adapter{Content_Type};
+is delete $adapter{Content_Type}, undef;
+
+%adaptee = ();
+is $adapter{Content_Type}, 'text/html; charset=ISO-8859-1';
+ok exists $adapter{Content_Type};
+is delete $adapter{Content_Type}, 'text/html; charset=ISO-8859-1';
+is_deeply \%adaptee, { -type => q{} };
+
+%adaptee = ( -type => 'text/plain' );
+is $adapter{Content_Type}, 'text/plain; charset=ISO-8859-1';
+ok exists $adapter{Content_Type};
+
+
+# FETCH
+
+%adaptee = ( -charset => 'utf-8' );
+is $adapter{Content_Type}, 'text/html; charset=utf-8';
+
+%adaptee = ( -type => 'text/plain', -charset => 'utf-8' );
+is $adapter{Content_Type}, 'text/plain; charset=utf-8';
+
+%adaptee = ( -type => q{}, -charset => 'utf-8' );
+is $adapter{Content_Type}, undef;
+
+%adaptee = ( -type => 'text/plain; charset=EUC-JP' );
+is $adapter{Content_Type}, 'text/plain; charset=EUC-JP';
+
+%adaptee = (
+ -type => 'text/plain; charset=euc-jp',
+ -charset => 'utf-8',
+);
+is $adapter{Content_Type}, 'text/plain; charset=euc-jp';
+
+%adaptee = ( -charset => q{} );
+is $adapter{Content_Type}, 'text/html';
+
+%adaptee = ( -type => 'text/plain; Foo=1', -charset => 'utf-8' );
+is $adapter{Content_Type}, 'text/plain; Foo=1; charset=utf-8';
+
+
+# STORE
+
+%adaptee = ();
+$adapter{Content_Type} = 'text/plain; charset=utf-8';
+is_deeply \%adaptee, {
+ -type => 'text/plain; charset=utf-8',
+ -charset => q{}
+};
+
+%adaptee = ();
+$adapter{Content_Type} = 'text/plain';
+is_deeply \%adaptee, { -type => 'text/plain', -charset => q{} };
+
+%adaptee = ( -charset => 'euc-jp' );
+$adapter{Content_Type} = 'text/plain; charset=utf-8';
+is_deeply \%adaptee, {
+ -type => 'text/plain; charset=utf-8',
+ -charset => q{},
+};
+
+SKIP: {
+ skip 'obsolete', 2;
+
+ %adaptee = ();
+ $adapter{Content_Type} = 'text/html; charSet=utf-8';
+ is_deeply \%adaptee, {
+ -type => 'text/html',
+ -charset => 'utf-8',
+ };
+
+ %adaptee = ();
+ $adapter{Content_Type} = 'text/html; charSet="CHARSET"; Foo="CHARSET"';
+ is_deeply \%adaptee, {
+ -type => 'text/html; foo=CHARSET',
+ -charset => 'CHARSET',
+ };
+}
+
+
+%adaptee = ( -type => undef );
+is $adapter{Content_Type}, 'text/html; charset=ISO-8859-1';
+ok exists $adapter{Content_Type};
+ok %adapter;
+
+%adaptee = ( -type => undef, -charset => 'utf-8' );
+is $adapter{Content_Type}, 'text/html; charset=utf-8';
+
+%adaptee = ( -type => 'text/plain', -charset => 'utf-8' );
+is delete $adapter{Content_Type}, 'text/plain; charset=utf-8';
+is_deeply \%adaptee, { -type => q{} };
+
+# feature
+%adaptee = ( -type => 'text/plain; charSet=utf-8' );
+is $adapter{Content_Type}, 'text/plain; charSet=utf-8; charset=ISO-8859-1';
57 t/14_date.t
@@ -0,0 +1,57 @@
+use strict;
+use warnings;
+use CGI::Header::Entity;
+use HTTP::Date;
+use Test::More tests => 11;
+use Test::Warn;
+
+my %adaptee;
+my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
+
+%adaptee = ( -nph => 1 );
+is $adapter{Date}, time2str( time );
+ok $adapter->_date_header_is_fixed;
+
+%adaptee = ( -nph => 0 );
+is $adapter{Date}, undef;
+ok !$adapter->_date_header_is_fixed;
+
+%adaptee = ( -cookie => 1 );
+is $adapter{Date}, time2str( time );
+ok $adapter->_date_header_is_fixed;
+
+%adaptee = ( -cookie => q{} );
+is $adapter{Date}, undef;
+ok !$adapter->_date_header_is_fixed;
+
+%adaptee = ( -date => 'Sat, 07 Jul 2012 05:05:09 GMT' );
+$adapter{Set_Cookie} = 'ID=123456; path=/';
+is_deeply \%adaptee, { -cookie => 'ID=123456; path=/' };
+
+subtest 'Date' => sub {
+ %adaptee = ( -date => 'Sat, 07 Jul 2012 05:05:09 GMT' );
+ ok exists $adapter{Date};
+
+ %adaptee = ();
+ $adapter{Date} = 'Sat, 07 Jul 2012 05:05:09 GMT';
+ is $adaptee{-date}, 'Sat, 07 Jul 2012 05:05:09 GMT';
+ is $adapter{Date}, 'Sat, 07 Jul 2012 05:05:09 GMT';
+};
+
+subtest 'Expires' => sub {
+ %adaptee = ( -expires => 1341637509 );
+ is $adapter{Expires}, 'Sat, 07 Jul 2012 05:05:09 GMT';
+ #is $adapter->expires, 'Sat, 07 Jul 2012 05:05:09 GMT';
+ ok $adapter->_date_header_is_fixed;
+ is $adapter{Date}, time2str( time );
+ warning_is { delete $adapter{Date} } 'The Date header is fixed';
+ warning_is { $adapter{Date} = 'foo' } 'The Date header is fixed';
+
+ %adaptee = ( -expires => q{} );
+ #is $adapter{Expires}, q{};
+ is $adapter{Expires}, q{};
+ ok !$adapter->_date_header_is_fixed;
+
+ warning_is { $adapter{Expires} = '+3M' }
+ "Can't assign to '-expires' directly, use accessors instead";
+};
34 t/15_p3p.t
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+use CGI::Header::Entity;
+use Test::More tests => 11;
+use Test::Warn;
+
+my %adaptee;
+my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
+
+%adaptee = ( -p3p => [qw/CAO DSP LAW CURa/] );
+is $adapter{P3P}, 'policyref="/w3c/p3p.xml", CP="CAO DSP LAW CURa"';
+is $adapter->p3p_tags, 'CAO';
+is_deeply [ $adapter->p3p_tags ], [qw/CAO DSP LAW CURa/];
+
+%adaptee = ();
+$adapter->p3p_tags( 'CAO' );
+is $adapter->p3p_tags, 'CAO';
+is_deeply \%adaptee, { -p3p => 'CAO' };
+is delete $adapter{P3P}, 'policyref="/w3c/p3p.xml", CP="CAO"';
+
+%adaptee = ();
+$adapter->p3p_tags( 'CAO DSP LAW CURa' );
+is_deeply \%adaptee, { -p3p => 'CAO DSP LAW CURa' };
+
+%adaptee = ();
+$adapter->p3p_tags( qw/CAO DSP LAW CURa/ );
+is_deeply \%adaptee, { -p3p => [qw/CAO DSP LAW CURa/] };
+
+%adaptee = ( -p3p => 'CAO DSP LAW CURa' );
+is $adapter->p3p_tags, 'CAO';
+is_deeply [ $adapter->p3p_tags ], [qw/CAO DSP LAW CURa/];
+
+warning_is { $adapter{P3P} = 'CAO DSP LAW CURa' }
+ "Can't assign to '-p3p' directly, use accessors instead";
40 t/16_content_disposition.t
@@ -0,0 +1,40 @@
+use strict;
+use CGI::Header::Entity;
+use Test::More tests => 18;
+
+my %adaptee;
+my $adapter = tie my %adapter, 'CGI::Header::Entity', \%adaptee;
+
+%adaptee = ( -attachment => 'genome.jpg' );
+is $adapter{Content_Disposition}, 'attachment; filename="genome.jpg"';
+ok exists $adapter{Content_Disposition};
+is delete $adapter{Content_Disposition}, 'attachment; filename="genome.jpg"';
+is_deeply \%adaptee, {};
+
+%adaptee = ( -attachment => q{} );
+is $adapter{Content_Disposition}, undef;
+ok !exists $adapter{Content_Disposition};
+
+%adaptee = ( -attachment => undef );
+is $adapter{Content_Disposition}, undef;
+ok !exists $adapter{Content_Disposition};
+
+%adaptee = ();
+is $adapter{Content_Disposition}, undef;
+ok !exists $adapter{Content_Disposition};
+
+%adaptee = ( -content_disposition => 'inline' );
+is $adapter{Content_Disposition}, 'inline';
+ok exists $adapter{Content_Disposition};
+is delete $adapter{Content_Disposition}, 'inline';
+is_deeply \%adaptee, {};
+
+%adaptee = ( -attachment => 'foo' );
+$adapter{Content_Disposition} = 'inline';
+is_deeply \%adaptee, { -content_disposition => 'inline' };
+
+%adaptee = ();
+is $adapter->attachment, undef;
+$adapter->attachment( 'genome.jpg' );
+is $adapter->attachment, 'genome.jpg';
+is $adaptee{-attachment}, 'genome.jpg';
225 t/20_entity.t
@@ -0,0 +1,225 @@
+use strict;
+use warnings;
+use CGI::Header;
+use CGI::Cookie;
+use CGI::Util 'expires';
+use Test::More tests => 20;
+use Test::Warn;
+use Test::Exception;
+
+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 type charset date status
+ DESTROY
+);
+
+subtest 'new()' => sub {
+ my $header = $class->new;
+ #is_deeply $header->header, { -type => q{} };
+ is_deeply $header->header, {};
+ my %header;
+ $header = $class->new( \%header );
+ is $header->header, \%header;
+ $header = $class->new( -foo => 'bar' );
+ is_deeply $header->header, { -foo => 'bar' };
+};
+
+# initialize
+my %header;
+my $header = $class->new( \%header );
+
+# exists()
+%header = ( -foo => 'bar' );
+ok $header->exists('Foo'), 'should return true';
+ok !$header->exists('Bar'), 'should return false';
+
+# get()
+%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' ];
+
+# 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;
+
+ %header = ();
+
+ $header->set(
+ Foo => 'bar',
+ Bar => 'baz',
+ Baz => 'qux',
+ );
+
+ my %expected = (
+ -foo => 'bar',
+ -bar => 'baz',
+ -baz => 'qux',
+ );
+
+ is_deeply \%header, \%expected, 'set() multiple elements';
+};
+
+subtest 'delete()' => sub {
+ %header = ();
+ is $header->delete('Foo'), undef;
+
+ %header = ( -foo => 'bar' );
+ is $header->delete('Foo'), 'bar';
+ is_deeply \%header, {};
+
+ %header = (
+ -foo => 'bar',
+ -bar => 'baz',
+ );
+
+ is_deeply [ $header->delete('Foo', 'Bar') ], [ 'bar', 'baz' ];
+ is_deeply \%header, {};
+
+ %header = (
+ -foo => 'bar',
+ -bar => 'baz',
+ );
+
+ ok $header->delete('Foo', 'Bar') eq 'baz';
+ is_deeply \%header, {};
+};
+
+subtest 'each()' => sub {
+ my $expected = qr{^Must provide a code reference to each\(\)};
+ throws_ok { $header->each } $expected;
+
+ %header = (
+ -status => '304 Not Modified',
+ -content_length => 12345,
+ );
+
+ my @got;
+ $header->each(sub {
+ my ( $field, $value ) = @_;
+ push @got, $field, $value;
+ });
+
+ my @expected = (
+ 'Status', '304 Not Modified',
+ 'Content-length', '12345',
+ 'Content-Type', 'text/html; charset=ISO-8859-1',
+ );
+
+ is_deeply \@got, \@expected;
+};
+
+subtest 'is_empty()' => sub {
+ %header = ();
+ ok !$header->is_empty;
+ %header = ( -type => q{} );
+ ok $header->is_empty;
+};
+
+subtest 'flatten()' => sub {
+ my $cookie1 = CGI::Cookie->new(
+ -name => 'foo',
+ -value => 'bar',
+ );
+
+ my $cookie2 = CGI::Cookie->new(
+ -name => 'bar',
+ -value => 'baz',
+ );
+
+ %header = (
+ -status => '304 Not Modified',
+ -content_length => 12345,
+ -cookie => [ $cookie1, $cookie2 ],
+ );
+
+ my @got = $header->flatten;
+
+ my @expected = (
+ 'Status', '304 Not Modified',
+ 'Set-Cookie', [ $cookie1, $cookie2 ],
+ 'Date', expires(0, 'http'),
+ 'Content-length', '12345',
+ 'Content-Type', 'text/html; charset=ISO-8859-1',
+ );
+
+ is_deeply \@got, \@expected;
+};
+
+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 = ( -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' );
+ is delete $header->{Foo}, 'bar';
+ is_deeply \%header, {}, 'delete';
+
+ %header = ( -foo => 'bar' );
+ %{ $header } = ();
+ is_deeply \%header, { -type => q{} }, 'clear';
+};
+
+subtest 'status()' => sub {
+ %header = ();
+ is $header->status, undef;
+
+ $header->status( 304 );
+ is $header{-status}, '304 Not Modified';
+ is $header->status, '304';
+
+ my $expected = q{Unknown status code '999' passed to status()};
+ warning_is { $header->status( 999 ) } $expected;
+};
+
+subtest 'target()' => sub {
+ %header = ();
+ is $header->target, undef;
+ $header->target( 'ResultsWindow' );
+ is $header->target, 'ResultsWindow';
+ is_deeply \%header, { -target => 'ResultsWindow' };
+};
+
+subtest 'clone()' => sub {
+ my $orig = $class->new( -foo => 'bar' );
+ my $clone = $orig->clone;
+ isnt $clone, $orig;
+ isnt $clone->header, $orig->header;
+ is_deeply $clone->header, $orig->header;
+};
+
+#subtest 'UNTIE()' => sub {
+# my $h = $class->new;
+# $h->UNTIE;
+# ok !$h->as_hashref;
+# ok $h->header;
+#};
+
+subtest 'DESTROY()' => sub {
+ my $h = $class->new;
+ $h->DESTROY;
+ ok !$h->as_hashref;
+ ok !$h->header;
+};
66 t/21_content_type.t
@@ -0,0 +1,66 @@
+use strict;
+use warnings;
+use CGI::Header;
+use Test::More tests => 2;
+
+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';
+ my @got = $adapter->content_type;
+ my @expected = ( 'text/html', 'charset=ISO-8859-1' );
+ is_deeply \@got, \@expected;
+
+ %adaptee = ( -type => 'text/plain; charset=EUC-JP; Foo=1' );
+ is $adapter->content_type, 'text/plain';
+ @got = $adapter->content_type;
+ @expected = ( 'text/plain', 'charset=EUC-JP; Foo=1' );
+ is_deeply \@got, \@expected;
+
+ %adaptee = ();
+ $adapter->content_type( 'text/plain; charset=EUC-JP' );
+ is_deeply \%adaptee, {
+ -type => 'text/plain; charset=EUC-JP',
+ -charset => q{},
+ };
+
+ %adaptee = ( -type => q{} );
+ is $adapter->content_type, q{};
+
+ %adaptee = ( -type => ' TEXT / HTML ' );
+ is $adapter->content_type, 'text/html';
+};
35 t/22_date.t
@@ -0,0 +1,35 @@
+use strict;
+use warnings;
+use CGI::Header;
+use Test::More tests => 2;
+
+my %header;
+my $header = CGI::Header->new( \%header );
+
+subtest 'date()' => sub {
+ %header = ();
+ is $header->date, undef;
+ my $now = 1341637509;
+ $header->date( $now );
+ is $header->date, $now;
+ is $header{-date}, 'Sat, 07 Jul 2012 05:05:09 GMT';
+};
+
+subtest 'expires()' => sub {
+ %header = ();
+ is $header->expires, undef;
+
+ %header = ( -date => 'Sat, 07 Jul 2012 05:05:09 GMT' );
+ $header->expires( '+3M' );
+ is_deeply \%header, { -expires => '+3M' };
+
+ my $now = 1341637509;
+ $header->expires( $now );
+ 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';
+};
66 t/23_set_cookie.t
@@ -0,0 +1,66 @@
+use strict;
+use CGI::Header;
+use CGI::Cookie;
+use Test::More tests => 2;
+
+my %header;
+my $header = CGI::Header->new( \%header );
+
+subtest 'get_cookie()' => sub {
+ my $cookie1 = CGI::Cookie->new(
+ -name => 'foo',
+ -value => 'bar',
+ );
+
+ my $cookie2 = CGI::Cookie->new(
+ -name => 'bar',
+ -value => 'baz',
+ );
+
+ %header = ( -cookie => $cookie1 );
+ is $header->get_cookie('foo'), $cookie1;
+ is $header->get_cookie('bar'), undef;
+
+ %header = ( -cookie => [$cookie1, $cookie2] );
+ is $header->get_cookie('foo'), $cookie1;
+ is $header->get_cookie('bar'), $cookie2;
+ is $header->get_cookie('baz'), undef;
+};
+
+subtest 'set_cookie()' => sub {
+ %header = ();
+ $header->set_cookie( foo => 'bar' );
+ my $got = $header{-cookie}[0];
+ isa_ok $got, 'CGI::Cookie';
+ is $got->value, 'bar';
+
+ %header = ();
+ $header->set_cookie( foo => { value => 'bar' } );
+ #$got = $header{-cookie};
+ $got = $header{-cookie}[0];
+ isa_ok $got, 'CGI::Cookie';
+ is $got->value, 'bar';
+
+ my $cookie = CGI::Cookie->new(
+ -name => 'foo',
+ -value => 'bar',
+ );
+
+ %header = ( -cookie => $cookie );
+ $header->set_cookie( foo => 'baz' );
+ $got = $header{-cookie}[0];
+ isa_ok $got, 'CGI::Cookie';
+ is $got->value, 'baz';
+
+ $cookie = CGI::Cookie->new(
+ -name => 'foo',
+ -value => 'bar',
+ );
+
+ %header = ( -cookie => $cookie );
+ $header->set_cookie( foo => { value => 'baz' } );
+ $got = $header{-cookie}[0];
+ isa_ok $got, 'CGI::Cookie';
+ is $got->value, 'baz';
+};
+
63 t/40_cgi_header.t
@@ -0,0 +1,63 @@
+use strict;
+use warnings;
+use CGI;
+use Test::More tests => 1;
+use CGI::Header;
+
+package CGI::Header;
+use overload q{""} => 'as_string', fallback => 1;
+use Carp qw/croak/;
+
+my $CRLF = $CGI::CRLF;
+
+sub as_string {
+ my $self = shift;
+
+ my @lines;
+
+ if ( $self->nph ) {
+ my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
+ my $software = $ENV{SERVER_SOFTWARE} || 'cmdline';
+ my $status = $self->{Status} || '200 OK';
+ push @lines, "$protocol $status";
+ push @lines, "Server: $software";
+ }
+
+ $self->each(sub {
+ my ( $field, $value ) = @_;
+ my @values = ref $value eq 'ARRAY' ? @{ $value } : $value;
+ push @lines, "$field: $_" for @values;
+ });
+
+ # CR escaping for values, per RFC 822
+ for my $line ( @lines ) {
+ $line =~ s/$CRLF(\s)/$1/g;
+ next unless $line =~ m/$CRLF|\015|\012/;
+ $line = substr $line, 0, 72 if length $line > 72;
+ croak "Invalid header value contains a new line ",
+ "not followed by whitespace: $line";
+ }
+
+ join $CRLF, @lines, $CRLF;
+}
+
+package main;
+
+my $header = CGI::Header->new( -nph => 1 );
+
+$header->set(
+ 'Content-Type' => 'text/plain; charset=utf-8',
+ 'Window-Target' => 'ResultsWindow',
+);
+
+$header->attachment( 'genome.jpg' );
+$header->status( 304 );
+$header->expires( '+3M' );
+$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);
+
+is $header, CGI::header( $header->header );
Please sign in to comment.
Something went wrong with that request. Please try again.