Browse files

remove set_cookie(), get_cookie(), status(), date(), content_type() a…

…nd target()
  • Loading branch information...
1 parent c490f27 commit 6b8eceb4fa98b60110e5e28ed689fafae5d4f106 Ryo Anazawa committed Sep 26, 2012
Showing with 71 additions and 198 deletions.
  1. +0 −5 Makefile.PL
  2. +32 −165 lib/CGI/Header.pm
  3. +22 −20 lib/CGI/Header/Dispatcher.pm
  4. +4 −1 t/12_basic.t
  5. +2 −0 t/20_content_type.t
  6. +5 −2 t/21_date.t
  7. +1 −1 t/22_p3p.t
  8. +2 −1 t/23_set_cookie.t
  9. +3 −3 t/30_as_string.t
View
5 Makefile.PL
@@ -5,17 +5,12 @@ 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 'List::Util' => '1.19';
requires 'Scalar::Util' => '1.19';
requires 'Storable' => '2.18';
-requires 'HTTP::Date' => '6.02';
-requires 'HTTP::Status' => '6.03';
-
test_requires 'Test::Base' => '0.60';
test_requires 'Test::Exception' => '0.31';
test_requires 'Test::More' => '0.98';
View
197 lib/CGI/Header.pm
@@ -5,7 +5,6 @@ use warnings;
use overload q{""} => 'as_string', fallback => 1;
use Carp qw/carp croak/;
use CGI::Header::Dispatcher;
-use HTTP::Date qw//;
use List::Util qw/first/;
use Scalar::Util qw/refaddr/;
use Storable qw//;
@@ -64,63 +63,14 @@ sub SCALAR {
sub is_empty { !shift->SCALAR }
-sub field_names {
- my $self = shift;
- my $this = refaddr $self;
- my %header = %{ $header_of{$this} }; # shallow 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) = CORE::each %header ) {
- push @fields, $self->_denormalize( $norm ) if $value;
- }
-
- push @fields, 'Content-Type' if !defined $type or $type ne q{};
-
- @fields;
-}
-
-sub flatten {
- my $self = shift;
- 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->get($field) );
- }
- }
- else {
- croak 'Must provide a code reference to each()';
- }
-
- return;
-}
-
sub attachment {
my $self = shift;
my $this = refaddr $self;
my $header = $header_of{ $this };
if ( @_ ) {
my $filename = shift;
- delete $header->{-content_disposition};
+ delete $header->{-content_disposition} if $filename;
$header->{-attachment} = $filename;
return;
}
@@ -159,32 +109,6 @@ sub p3p_tags {
return;
}
-sub target {
- my $self = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
- $header->{-target} = shift if @_;
- $header->{-target};
-}
-
-
-sub content_type {
- my $self = shift;
-
- return $self->set( 'Content-Type' => shift ) if @_;
-
- my ( $media_type, $rest ) = do {
- my $content_type = $self->get( '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;
-}
-
sub expires {
my $self = shift;
my $this = refaddr $self;
@@ -194,111 +118,56 @@ sub expires {
my $expires = shift;
delete $header->{-date} if $expires;
$header->{-expires} = $expires;
- }
- elsif ( my $expires = $self->get('Expires') ) {
- return HTTP::Date::str2time( $expires );
- }
-
- return;
-}
-
-sub date {
- my $self = shift;
- my $time = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
- my $is_fixed = first { $header->{$_} } qw(-nph -expires -cookie);
-
- if ( defined $time ) {
- return carp 'The Date header is fixed' if $is_fixed;
- $header->{-date} = HTTP::Date::time2str( $time );
- }
- elsif ( $is_fixed ) {
- return time;
- }
- elsif ( my $date = $header->{-date} ) {
- return HTTP::Date::str2time( $date );
+ return;
}
- return;
+ $header->{-expires};
}
-sub get_cookie {
+sub field_names {
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];
-}
+ my %header = %{ $header_of{$this} }; # shallow copy
-sub set_cookie {
- my ( $self, $name, $value ) = @_;
+ my @fields;
- require CGI::Cookie;
+ push @fields, 'Status' if delete $header{-status};
+ push @fields, 'Window-Target' if delete $header{-target};
+ push @fields, 'P3P' if delete $header{-p3p};
- my $new_cookie = CGI::Cookie->new(do {
- my %args = ref $value eq 'HASH' ? %{ $value } : ( value => $value );
- $args{name} = $name;
- \%args;
- });
+ 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;
- my $cookies = $self->get( 'Set-Cookie' );
+ push @fields, 'Content-Disposition' if delete $header{-attachment};
- if ( !$cookies ) {
- $self->set( 'Set-Cookie' => [ $new_cookie ] );
- return;
- }
- elsif ( ref $cookies ne 'ARRAY' ) {
- $cookies = [ $cookies ];
- $self->set( 'Set-Cookie' => $cookies );
- }
+ my $type = delete @header{ '-charset', '-type' };
- my $set;
- for my $cookie ( @{$cookies} ) {
- next unless ref $cookie eq 'CGI::Cookie';
- next unless $cookie->name eq $name;
- $cookie = $new_cookie;
- $set++;
- last;
+ # not ordered
+ while ( my ($norm, $value) = CORE::each %header ) {
+ push @fields, $self->_denormalize( $norm ) if $value;
}
- push @{ $cookies }, $new_cookie unless $set;
+ push @fields, 'Content-Type' if !defined $type or $type ne q{};
- return;
+ @fields;
}
-sub status {
- my $self = shift;
- my $this = refaddr $self;
- my $header = $header_of{ $this };
+sub flatten {
+ my $self = shift;
+ map { $_, $self->get($_) } $self->field_names;
+}
- require HTTP::Status;
+sub each {
+ my ( $self, $callback ) = @_;
- if ( @_ ) {
- my $code = shift;
- my $message = HTTP::Status::status_message( $code );
- return $header->{-status} = "$code $message" if $message;
- carp "Unknown status code '$code' passed to status()";
- }
- elsif ( my $status = $header->{-status} ) {
- return substr( $status, 0, 3 );
+ if ( ref $callback eq 'CODE' ) {
+ for my $field ( $self->field_names ) {
+ $callback->( $field, $self->get($field) );
+ }
}
else {
- return '200';
+ croak 'Must provide a code reference to each()';
}
return;
@@ -307,15 +176,13 @@ sub status {
sub as_string {
my $self = shift;
my $eol = defined $_[0] ? shift : "\n";
- my $this = refaddr $self;
- my $header = $header_of{ $this };
my @lines;
- if ( $header->{-nph} ) {
+ if ( $self->nph ) {
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
my $software = $ENV{SERVER_SOFTWARE} || 'cmdline';
- my $status = $header->{-status} || '200 OK';
+ my $status = $self->get('Status') || '200 OK';
push @lines, "$protocol $status";
push @lines, "Server: $software";
}
View
42 lib/CGI/Header/Dispatcher.pm
@@ -2,14 +2,12 @@ package CGI::Header::Dispatcher;
use strict;
use warnings;
use Exporter 'import';
-use List::Util qw/first/;
use CGI::Util qw/expires/;
-use HTTP::Date qw/time2str str2time/;
use Carp qw/carp croak/;
our @EXPORT = qw( dispatch );
-my %Content_Type = (
+my %content_type = (
get => sub {
my $header = shift;
my $type = $header->{-type};
@@ -33,9 +31,10 @@ my %Content_Type = (
$charset ? "$type; charset=$charset" : $type;
},
set => sub {
- my ( $header, $value ) = @_;
- $header->{-type} = $value;
+ my $header = shift;
+ $header->{-type} = shift;
$header->{-charset} = q{};
+ return;
},
exists => sub {
my $header = shift;
@@ -48,30 +47,30 @@ my %Content_Type = (
},
);
-my %Expires = (
+my %expires = (
get => sub {
my $header = shift;
my $expires = $header->{-expires};
$expires && expires( $expires );
},
set => sub {
- carp "Can't assign to '-expires' directly, use accessors instead";
+ carp "Can't assign to '-expires' directly, use expires() instead";
},
);
-my %P3P = (
+my %p3p = (
get => sub {
my $header = shift;
my $tags = $header->{-p3p};
$tags = join ' ', @{ $tags } if ref $tags eq 'ARRAY';
$tags && qq{policyref="/w3c/p3p.xml", CP="$tags"};
},
set => sub {
- carp "Can't assign to '-p3p' directly, use accessors instead";
+ carp "Can't assign to '-p3p' directly, use p3p_tags() instead";
},
);
-my %Content_Disposition = (
+my %content_disposition = (
get => sub {
my $header = shift;
my $filename = $header->{-attachment};
@@ -80,8 +79,9 @@ my %Content_Disposition = (
},
set => sub {
my ( $header, $value ) = @_;
- delete $header->{-attachment};
$header->{-content_disposition} = $value;
+ delete $header->{-attachment} if $value;
+ return;
},
exists => sub {
my $header = shift;
@@ -98,16 +98,17 @@ my $is_fixed = sub {
$header->{-nph} || $header->{-expires} || $header->{-cookie};
};
-my %Date = (
+my %date = (
get => sub {
my $header = shift;
- return time2str( time ) if $is_fixed->( $header );
+ return expires() if $is_fixed->( $header );
$header->{-date};
},
set => sub {
my ( $header, $value ) = @_;
return carp 'The Date header is fixed' if $is_fixed->( $header );
$header->{-date} = $value;
+ return;
},
exists => sub {
my $header = shift;
@@ -119,18 +120,19 @@ my %Date = (
},
);
-my %Set_Cookie = (
+my %cookie = (
set => sub {
my ( $header, $value ) = @_;
- delete $header->{-date};
+ delete $header->{-date} if $value;
$header->{-cookie} = $value;
+ return;
},
);
my %Handler = (
- -cookie => \%Set_Cookie, -content_disposition => \%Content_Disposition,
- -date => \%Date, -content_type => \%Content_Type,
- -expires => \%Expires, -p3p => \%P3P,
+ -cookie => \%cookie, -content_disposition => \%content_disposition,
+ -date => \%date, -content_type => \%content_type,
+ -expires => \%expires, -p3p => \%p3p,
);
my %Dispatcher = (
@@ -140,8 +142,8 @@ my %Dispatcher = (
},
set => sub {
my ( $self, $field, $norm, $handler, $value ) = @_;
- $handler->( $self->header, $value ) if $handler;
- $self->header->{ $norm } = $value unless $handler;
+ return $handler->( $self->header, $value ) if $handler;
+ $self->header->{ $norm } = $value;
return;
},
exists => sub {
View
5 t/12_basic.t
@@ -12,7 +12,7 @@ my $class = 'CGI::Header';
can_ok $class, qw(
new clone clear delete exists get set is_empty
header field_names each flatten DESTROY
- p3p_tags expires nph attachment date status
+ p3p_tags expires nph attachment
);
subtest 'new()' => sub {
@@ -126,6 +126,8 @@ subtest 'flatten()' => sub {
};
subtest 'status()' => sub {
+ plan skip_all => 'obsolete';
+
%header = ();
is $header->status, 200;
@@ -138,6 +140,7 @@ subtest 'status()' => sub {
};
subtest 'target()' => sub {
+ plan skip_all => 'obsolete';
%header = ();
is $header->target, undef;
$header->target( 'ResultsWindow' );
View
2 t/20_content_type.t
@@ -86,6 +86,8 @@ is_deeply \%adaptee, { -type => q{} };
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;
View
7 t/21_date.t
@@ -37,10 +37,12 @@ subtest 'Expires' => sub {
#ok !$adapter->_date_header_is_fixed;
warning_is { $adapter{Expires} = '+3M' }
- "Can't assign to '-expires' directly, use accessors instead";
+ "Can't assign to '-expires' directly, use expires() instead";
};
subtest 'date()' => sub {
+ plan skip_all => 'obsolete';
+
%adaptee = ();
is $adapter->date, undef;
my $now = 1341637509;
@@ -64,5 +66,6 @@ subtest 'expires()' => sub {
$now++;
$adapter->expires( 'Sat, 07 Jul 2012 05:05:10 GMT' );
- is $adapter->expires, $now, 'get expires()';
+ #is $adapter->expires, $now, 'get expires()';
+ is $adapter->expires, 'Sat, 07 Jul 2012 05:05:10 GMT';
};
View
2 t/22_p3p.t
@@ -31,4 +31,4 @@ 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";
+ "Can't assign to '-p3p' directly, use p3p_tags() instead";
View
3 t/23_set_cookie.t
@@ -1,7 +1,8 @@
use strict;
use CGI::Header;
use CGI::Cookie;
-use Test::More tests => 2;
+#use Test::More tests => 2;
+use Test::More skip_all => 'obsolete';
my %header;
my $header = CGI::Header->new( \%header );
View
6 t/30_as_string.t
@@ -13,12 +13,12 @@ $header->set(
);
$header->attachment( 'genome.jpg' );
-$header->status( 304 );
+#$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_cookie( foo => 'bar' );
+#$header->set_cookie( bar => 'baz' );
$header->set( Ingredients => join "$CRLF ", qw(ham eggs bacon) );

0 comments on commit 6b8eceb

Please sign in to comment.