Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

add tests

  • Loading branch information...
commit 8063e3cd2206184dff62cd2febe2f43e9ac98a4f 1 parent 04c6b4d
Ryo Anazawa authored
78 lib/CGI/Header.pm
View
@@ -10,21 +10,21 @@ use List::Util qw/first/;
our $VERSION = '0.01';
-my %header_of;
+my %header;
sub new {
my $class = shift;
my $header = ref $_[0] eq 'HASH' ? shift : { @_ };
my $self = bless \do { my $anon_scalar }, $class;
- $header_of{ refaddr $self } = $header;
+ $header{ refaddr $self } = $header;
$self;
}
-sub header { $header_of{ refaddr shift } }
+sub header { $header{ refaddr shift } }
sub DESTROY {
my $self = shift;
- delete $header_of{ refaddr $self };
+ delete $header{ refaddr $self };
return;
}
@@ -77,14 +77,15 @@ my %get = (
sub get {
my $self = shift;
my $norm = _normalize( shift ) || return;
- my $header = $header_of{ refaddr $self };
- exists $get{$norm} ? $get{$norm}->( $header, $norm ) : $header->{ $norm };
+ my $header = $header{ refaddr $self };
+ my $get = $get{ $norm };
+ $get ? $get->( $header, $norm ) : $header->{ $norm };
}
my %set = (
-content_disposition => sub {
my ( $header, $norm, $value ) = @_;
- delete $header->{-attachment} if $value;
+ delete $header->{-attachment};
$header->{ $norm } = $value;
},
-content_type => sub {
@@ -117,7 +118,7 @@ sub set {
my $self = shift;
my $norm = _normalize( shift ) || return;
my $value = shift;
- my $header = $header_of{ refaddr $self };
+ my $header = $header{ refaddr $self };
if ( my $set = $set{$norm} ) {
$set->( $header, $norm, $value );
@@ -135,60 +136,63 @@ my %exists = (
!defined $header->{-type} || $header->{-type} ne q{};
},
-content_disposition => sub {
- my ( $header, $exists ) = @_;
- $exists || exists $header->{-attachment};
+ my ( $header, $norm ) = @_;
+ exists $header->{ $norm } || $header->{-attachment};
},
-date => sub {
- my ( $header, $exists ) = @_;
- first { $header->{$_} } qw(-date -nph -expires -cookie );
+ my ( $header, $norm ) = @_;
+ exists $header->{ $norm }
+ || first { $header->{$_} } qw(-nph -expires -cookie );
},
-set_cookie => sub { exists shift->{-cookie} },
-window_target => sub { exists shift->{-target} },
);
-# FIXME: this method doesn't return a reliable value :(
sub exists {
my $self = shift;
my $norm = _normalize( shift ) || return;
- my $header = $header_of{ refaddr $self };
- my $exists = exists $header->{ $norm };
- do { $exists{$norm} || sub { $_[1] } }->( $header, $exists );
+ my $header = $header{ refaddr $self };
+ #my $exists = $exists{ $norm };
+ #$exists ? $exists->( $header, $norm ) : exists $header->{ $norm };
+ return $exists{$norm}->( $header, $norm ) if exists $exists{$norm};
+ exists $header->{ $norm };
}
my %delete = (
- -content_disposition => sub { delete $_[0]->{-attachment} },
+ -content_disposition => sub { delete shift->{-attachment} },
-content_type => sub {
my $header = shift;
delete $header->{-charset};
$header->{-type} = q{};
},
- -set_cookie => sub { delete @{ $_[0] }{qw/-cookie -cookies/} },
- -window_target => sub { delete $_[0]->{-target} },
+ -set_cookie => sub { delete shift->{-cookie} },
+ -window_target => sub { delete shift->{-target} },
);
sub delete {
my ( $self, $field ) = @_;
my $norm = _normalize( $field ) || return;
+ my $header = $header{ refaddr $self };
my $value = defined wantarray && $self->get( $field );
- my $header = $header_of{ refaddr $self };
do { $delete{$norm} || sub {} }->( $header );
delete $header->{ $norm };
$value;
}
my %is_ignored = map { $_ => 1 }
- qw( attachment charset cookie cookies nph target type );
+ qw( -attachment -charset -cookie -cookies -nph -target -type );
sub _normalize {
my $norm = lc shift;
$norm =~ tr/-/_/;
- $is_ignored{ $norm } ? undef : "-$norm";
+ $norm = "-$norm";
+ $is_ignored{ $norm } ? undef : $norm;
}
sub clone {
my $self = shift;
my $class = ref $self or croak "Can't clone non-object: $self";
- my $header = $header_of{ refaddr $self };
+ my $header = $header{ refaddr $self };
$class->new( %{ $header } );
}
@@ -196,7 +200,7 @@ sub is_empty { !shift->SCALAR }
sub clear {
my $self = shift;
- my $header = $header_of{ refaddr $self };
+ my $header = $header{ refaddr $self };
%{ $header } = ( -type => q{} );
return;
}
@@ -208,11 +212,11 @@ BEGIN {
expires => '-date',
);
- while ( my ($method, $conflict_with) = each %conflict_with ) {
+ while ( my ($method, $conflict_with) = CORE::each %conflict_with ) {
my $norm = "-$method";
my $code = sub {
my $self = shift;
- my $header = $header_of{ refaddr $self };
+ my $header = $header{ refaddr $self };
if ( @_ ) {
my $value = shift;
@@ -230,7 +234,7 @@ BEGIN {
sub p3p_tags {
my $self = shift;
- my $header = $header_of{ refaddr $self };
+ my $header = $header{ refaddr $self };
if ( @_ ) {
$header->{-p3p} = @_ > 1 ? [ @_ ] : shift;
@@ -245,7 +249,7 @@ sub p3p_tags {
sub field_names {
my $self = shift;
- my $header = $header_of{ refaddr $self };
+ my $header = $header{ refaddr $self };
my %header = %{ $header }; # copy
my @fields;
@@ -260,7 +264,7 @@ sub field_names {
push @fields, 'Content-Disposition' if delete $header{-attachment};
- my $type = delete @header{ '-charset', '-type' };
+ my $type = delete @header{qw/-charset -type/};
# not ordered
while ( my ($norm, $value) = CORE::each %header ) {
@@ -311,7 +315,7 @@ sub each {
sub as_string {
my $self = shift;
my $eol = defined $_[0] ? shift : "\015\012";
- my $header = $header_of{ refaddr $self };
+ my $header = $header{ refaddr $self };
my @lines;
@@ -333,12 +337,6 @@ sub as_string {
join $eol, @lines, q{};
}
-sub as_hashref {
- my $self = shift;
- tie my %header, ref $self, $header_of{ refaddr $self };
- \%header;
-}
-
sub dump {
my $self = shift;
my $this = refaddr $self;
@@ -349,7 +347,7 @@ sub dump {
my %dump = (
__PACKAGE__, {
- header => $header_of{ $this },
+ header => $header{ $this },
},
@_,
);
@@ -364,18 +362,18 @@ BEGIN {
sub SCALAR {
my $self = shift;
- my $header = $header_of{ refaddr $self };
+ my $header = $header{ refaddr $self };
!defined $header->{-type} || first { $_ } values %{ $header };
}
sub STORABLE_freeze {
my ( $self, $cloning ) = @_;
- ( q{}, $header_of{ refaddr $self } );
+ ( q{}, $header{ refaddr $self } );
}
sub STORABLE_thaw {
my ( $self, $serialized, $cloning, $header ) = @_;
- $header_of{ refaddr $self } = $header;
+ $header{ refaddr $self } = $header;
$self;
}
67 t/20_content_type.t
View
@@ -1,7 +1,7 @@
use strict;
use warnings;
use CGI::Header;
-use Test::More tests => 27;
+use Test::More tests => 26;
my %adaptee;
my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
@@ -21,15 +21,27 @@ is_deeply \%adaptee, { -type => q{} };
is $adapter{Content_Type}, 'text/plain; charset=ISO-8859-1';
ok exists $adapter{Content_Type};
+%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';
# 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;
@@ -69,47 +81,6 @@ is_deeply \%adaptee, {
-charset => q{},
};
-%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';
-
-subtest 'content_type()' => sub {
- plan skip_all => 'obsolete';
-
- %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';
-};
+%adaptee = ();
+$adapter{Content_Type} = q{};
+is_deeply \%adaptee, { -type => q{}, -charset => q{} };
68 t/21_date.t
View
@@ -2,57 +2,62 @@ use strict;
use warnings;
use CGI::Header;
use HTTP::Date;
-use Test::More tests => 5;
+use Test::More tests => 20;
use Test::Warn;
my %adaptee;
my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
+%adaptee = ();
+is $adapter{Date}, undef;
+ok !exists $adapter{Date};
+is delete $adapter{Date}, undef;
+is_deeply \%adaptee, {};
+
+%adaptee = ( -date => q{} );
+is $adapter{Date}, q{};
+ok exists $adapter{Date};
+is delete $adapter{Date}, q{};
+is_deeply \%adaptee, {};
+
%adaptee = ( -date => 'Sat, 07 Jul 2012 05:05:09 GMT' );
-$adapter{Set_Cookie} = 'ID=123456; path=/';
-is_deeply \%adaptee, { -cookie => 'ID=123456; path=/' };
+is $adapter{Date}, 'Sat, 07 Jul 2012 05:05:09 GMT';
+ok exists $adapter{Date};
+is delete $adapter{Date}, 'Sat, 07 Jul 2012 05:05:09 GMT';
+is_deeply \%adaptee, {};
-subtest 'Date' => sub {
- %adaptee = ( -date => 'Sat, 07 Jul 2012 05:05:09 GMT' );
- ok exists $adapter{Date};
+%adaptee = ( -nph => 1 );
+is $adapter{Date}, time2str();
+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';
-};
+%adaptee = ( -nph => 0 );
+is $adapter{Date}, undef;
+ok !exists $adapter{Date};
+
+%adaptee = ( -cookie => 'ID=123456; path=/' );
+is $adapter{Date}, time2str();
+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';
-subtest 'Expires' => sub {
+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->expires, 1341637509;
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}, undef;
- #ok !$adapter->_date_header_is_fixed;
#warning_is { $adapter{Expires} = '+3M' }
# "Can't assign to '-expires' directly, use expires() instead";
-};
-
-subtest 'date()' => sub {
- plan skip_all => 'obsolete';
-
- %adaptee = ();
- is $adapter->date, undef;
- my $now = 1341637509;
- $adapter->date( $now );
- is $adapter->date, $now;
- is $adaptee{-date}, 'Sat, 07 Jul 2012 05:05:09 GMT';
-};
-subtest 'expires()' => sub {
%adaptee = ();
+ is $adapter{Expires}, undef;
is $adapter->expires, undef;
%adaptee = ( -date => 'Sat, 07 Jul 2012 05:05:09 GMT' );
@@ -63,9 +68,4 @@ subtest 'expires()' => sub {
$adapter->expires( $now );
is $adapter->expires, $now, 'get expires()';
is $adaptee{-expires}, $now;
-
- $now++;
- $adapter->expires( 'Sat, 07 Jul 2012 05:05:10 GMT' );
- #is $adapter->expires, $now, 'get expires()';
- is $adapter->expires, 'Sat, 07 Jul 2012 05:05:10 GMT';
};
34 t/22_p3p.t
View
@@ -1,34 +1,44 @@
use strict;
use warnings;
use CGI::Header;
-use Test::More tests => 11;
+use Test::More tests => 22;
use Test::Warn;
my %adaptee;
my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
+%adaptee = ();
+is $adapter{P3P}, undef;
+ok !exists $adapter{P3P};
+is delete $adapter{P3P}, undef;
+is_deeply \%adaptee, {};
+
+%adaptee = ( -p3p => q{} );
+is $adapter{P3P}, q{};
+ok exists $adapter{P3P};
+is delete $adapter{P3P}, q{};
+is_deeply \%adaptee, {};
+
%adaptee = ( -p3p => [qw/CAO DSP LAW CURa/] );
is $adapter{P3P}, 'policyref="/w3c/p3p.xml", CP="CAO DSP LAW CURa"';
+ok exists $adapter{P3P};
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"';
+is delete $adapter{P3P}, 'policyref="/w3c/p3p.xml", CP="CAO DSP LAW CURa"';
+is_deeply \%adaptee, {};
%adaptee = ();
$adapter->p3p_tags( 'CAO DSP LAW CURa' );
is_deeply \%adaptee, { -p3p => 'CAO DSP LAW CURa' };
+ok exists $adapter{P3P};
+is $adapter->p3p_tags, 'CAO';
+is_deeply [ $adapter->p3p_tags ], [qw/CAO DSP LAW CURa/];
+is delete $adapter{P3P}, 'policyref="/w3c/p3p.xml", CP="CAO DSP LAW CURa"';
+is_deeply \%adaptee, {};
%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' }
+warning_is { $adapter{P3P} = '/path/to/p3p.xml' }
"Can't assign to '-p3p' directly, use p3p_tags() instead";
101 t/23_set_cookie.t
View
@@ -1,66 +1,39 @@
use strict;
-use CGI::Header;
use CGI::Cookie;
-#use Test::More tests => 2;
-use Test::More skip_all => 'obsolete';
-
-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}[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';
-};
-
+use CGI::Header;
+use Test::More tests => 13;
+
+my $cookie1 = CGI::Cookie->new(
+ -name => 'foo',
+ -value => 'bar',
+);
+
+my $cookie2 = CGI::Cookie->new(
+ -name => 'bar',
+ -value => 'baz',
+);
+
+my %adaptee;
+my $adapter = tie my %adapter, 'CGI::Header', \%adaptee;
+
+%adaptee = ();
+is $adapter{Set_Cookie}, undef;
+ok !exists $adapter{Set_Cookie};
+is delete $adapter{Set_Cookie}, undef;
+is_deeply \%adaptee, {};
+
+%adaptee = ( -cookie => $cookie1 );
+is $adapter{Set_Cookie}, 'foo=bar; path=/';
+ok exists $adapter{Set_Cookie};
+is delete $adapter{Set_Cookie}, 'foo=bar; path=/';
+is_deeply \%adaptee, {};
+
+%adaptee = ( -cookie => [$cookie1, $cookie2] );
+is_deeply $adapter{Set_Cookie}, [ $cookie1, $cookie2 ];
+ok exists $adapter{Set_Cookie};
+is_deeply delete $adapter{Set_Cookie}, [ $cookie1, $cookie2 ];
+is_deeply \%adaptee, {};
+
+%adaptee = ( -date => 'Sat, 07 Jul 2012 05:05:09 GMT' );
+$adapter{Set_Cookie} = $cookie1;
+is_deeply \%adaptee, { -cookie => $cookie1 };
49 t/24_content_disposition.t
View
@@ -1,27 +1,44 @@
use strict;
+use warnings;
use CGI::Header;
-use Test::More tests => 18;
+use Test::More tests => 31;
my %adaptee;
my $adapter = tie my %adapter, 'CGI::Header', \%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{} );
+%adaptee = ();
is $adapter{Content_Disposition}, undef;
-ok exists $adapter{Content_Disposition};
+ok !exists $adapter{Content_Disposition};
+is $adapter->attachment, undef;
+is delete $adapter{Content_Disposition}, undef;
+is_deeply \%adaptee, {};
%adaptee = ( -attachment => undef );
is $adapter{Content_Disposition}, undef;
-ok exists $adapter{Content_Disposition};
+ok !exists $adapter{Content_Disposition};
+is $adapter->attachment, undef;
+is delete $adapter{Content_Disposition}, undef;
+is_deeply \%adaptee, {};
-%adaptee = ();
+%adaptee = ( -attachment => q{} );
is $adapter{Content_Disposition}, undef;
ok !exists $adapter{Content_Disposition};
+is $adapter->attachment, q{};
+is delete $adapter{Content_Disposition}, undef;
+is_deeply \%adaptee, {};
+
+%adaptee = ( -attachment => 'genome.jpg' );
+is $adapter{Content_Disposition}, 'attachment; filename="genome.jpg"';
+ok exists $adapter{Content_Disposition};
+is $adapter->attachment, 'genome.jpg';
+is delete $adapter{Content_Disposition}, 'attachment; filename="genome.jpg"';
+is_deeply \%adaptee, {};
+
+%adaptee = ( -content_disposition => q{} );
+is $adapter{Content_Disposition}, q{};
+ok exists $adapter{Content_Disposition};
+is delete $adapter{Content_Disposition}, q{};
+is_deeply \%adaptee, {};
%adaptee = ( -content_disposition => 'inline' );
is $adapter{Content_Disposition}, 'inline';
@@ -29,12 +46,14 @@ ok exists $adapter{Content_Disposition};
is delete $adapter{Content_Disposition}, 'inline';
is_deeply \%adaptee, {};
-%adaptee = ( -attachment => 'foo' );
+%adaptee = ( -attachment => 'genome.jpg' );
$adapter{Content_Disposition} = 'inline';
is_deeply \%adaptee, { -content_disposition => 'inline' };
+%adaptee = ( -attachment => 'genome.jpg' );
+$adapter{Content_Disposition} = q{};
+is_deeply \%adaptee, { -content_disposition => q{} };
+
%adaptee = ();
-is $adapter->attachment, undef;
$adapter->attachment( 'genome.jpg' );
-is $adapter->attachment, 'genome.jpg';
-is $adaptee{-attachment}, 'genome.jpg';
+is_deeply \%adaptee, { -attachment => 'genome.jpg' };
59 t/30_as_string.t
View
@@ -1,9 +1,17 @@
use strict;
use warnings;
+
+use Test::MockTime qw/set_fixed_time/;
+
use CGI;
-use Test::More tests => 1;
-use CGI::Header;
use CGI::Cookie;
+use CGI::Header;
+use Test::More tests => 2;
+
+my $now = 1349043453;
+set_fixed_time( $now );
+
+my $CRLF = $CGI::CRLF;
my $cookie1 = CGI::Cookie->new(
-name => 'foo',
@@ -15,32 +23,33 @@ my $cookie2 = CGI::Cookie->new(
-value => 'baz',
);
+{
+ my $header = CGI::Header->new(
+ -attachment => 'genome.jpg',
+ -charset => 'utf-8',
+ -cookie => [ $cookie1, $cookie2 ],
+ -expires => '+3d',
+ -nph => 1,
+ -p3p => [qw/CAP DSP LAW CURa/],
+ -target => 'ResultsWindow',
+ -type => 'text/plain',
+ );
-my $CRLF = $CGI::CRLF;
-my $header = CGI::Header->new( -nph => 1 );
-
-$header->set(
- 'Content-Type' => 'text/plain; charset=utf-8',
- #'Window-Target' => 'ResultsWindow',
-);
-
-$header->set( 'Set-Cookie' => [$cookie1,$cookie2] );
-
-$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->set( 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->new->header( $header->header );
-#warn $header->dump;
+ is $got, $expected;
+}
-my $got = $header->as_string( $CRLF ) . $CRLF;
-my $expected = CGI::header( $header->header );
+{
+ local $ENV{SERVER_SOFTWARE} = 'Apache/1.3.27 (Unix)';
+ local $ENV{SERVER_PROTOCOL} = 'HTTP/1.1';
-is $got, $expected;
+ my $header = CGI::Header->new( -nph => 1 );
+ my $got = $header->as_string( $CRLF ) . $CRLF;
+ my $expected = CGI->new->header( $header->header );
-#warn $header->dump;
+ is $got, $expected;
+}
29 t/window_target.t
View
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+use CGI::Header;
+use Test::More tests => 13;
+
+my %adaptee;
+tie my %adapter, 'CGI::Header', \%adaptee;
+
+%adaptee = ();
+is $adapter{Window_Target}, undef;
+ok !exists $adapter{Window_Target};
+is delete $adapter{Window_Target}, undef;
+is_deeply \%adaptee, {};
+
+%adaptee = ( -target => q{} );
+is $adapter{Window_Target}, q{};
+ok exists $adapter{Window_Target};
+is delete $adapter{Window_Target}, q{};
+is_deeply \%adaptee, {};
+
+%adaptee = ( -target => 'ResultsWindow' );
+is $adapter{Window_Target}, 'ResultsWindow';
+ok exists $adapter{Window_Target};
+is delete $adapter{Window_Target}, 'ResultsWindow';
+is_deeply \%adaptee, {};
+
+%adaptee = ();
+$adapter{Window_Target} = 'ResultsWindow';
+is_deeply \%adaptee, { -target => 'ResultsWindow' };
Please sign in to comment.
Something went wrong with that request. Please try again.