Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

add as_string()

  • Loading branch information...
commit a2545944b5b2637d33ec8a3c2fb35d9e8ce46759 1 parent a282355
Ryo Anazawa authored
View
6 Makefile.PL
@@ -9,14 +9,12 @@ 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';
+requires 'HTTP::Date' => '6.02';
+requires 'HTTP::Status' => '6.03';
test_requires 'Test::Base' => '0.60';
test_requires 'Test::Exception' => '0.31';
View
204 lib/CGI/Header.pm
@@ -1,20 +1,20 @@
package CGI::Header;
+use 5.008_009;
use strict;
use warnings;
-use overload '%{}' => 'as_hashref', 'fallback' => 1;
+use overload '%{}' => 'as_hashref', q{""} => 'as_string', fallback => 1;
use parent 'CGI::Header::Entity';
use Carp qw/carp croak/;
use Scalar::Util qw/refaddr/;
+our $VERSION = '0.01';
+
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;
+ $class->SUPER::new( $header );
}
sub get {
@@ -80,38 +80,22 @@ sub each {
return;
}
-sub as_hashref { $header_of{ refaddr shift } }
-
-sub charset {
+sub as_hashref {
my $self = shift;
+ my $this = refaddr $self;
- 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;
+ unless ( exists $header_of{$this} ) {
+ tie my %header => 'CGI::Header::Entity' => $self->header;
+ $header_of{ $this } = \%header;
}
- return;
+ $header_of{ $this };
}
sub content_type {
my $self = shift;
- if ( @_ ) {
- my $content_type = shift;
- $self->STORE( 'Content-Type' => $content_type );
- return;
- }
+ return $self->STORE( 'Content-Type' => shift ) if @_;
my ( $media_type, $rest ) = do {
my $content_type = $self->FETCH( 'Content-Type' );
@@ -125,19 +109,15 @@ sub content_type {
wantarray ? ($media_type, $rest) : $media_type;
}
-BEGIN { *type = \&content_type }
-
-sub date { shift->_date_header( 'Date', @_ ) }
-
-sub _date_header {
- my ( $self, $field, $time ) = @_;
+sub date {
+ my ( $self, $time ) = @_;
require HTTP::Date;
if ( defined $time ) {
- $self->STORE( $field => HTTP::Date::time2str($time) );
+ $self->STORE( Date => HTTP::Date::time2str($time) );
}
- elsif ( my $date = $self->FETCH($field) ) {
+ elsif ( my $date = $self->FETCH('Date') ) {
return HTTP::Date::str2time( $date );
}
@@ -149,51 +129,35 @@ sub set_cookie {
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;
});
+ my $cookies = $self->FETCH( 'Set-Cookie' );
+
+ if ( !$cookies ) {
+ return $self->STORE( 'Set-Cookie' => [ $new_cookie ] );
+ }
+ elsif ( ref $cookies ne 'ARRAY' ) {
+ $self->STORE( 'Set-Cookie' => $cookies = [ $cookies ] );
+ }
+
+ my $set;
for my $cookie ( @{$cookies} ) {
- next unless ref $cookie eq 'CGI::Cookie';
+ next unless ref $cookie eq 'CGI::Cookie';
next unless $cookie->name eq $name;
$cookie = $new_cookie;
- undef $new_cookie;
+ $set++;
last;
}
- push @{ $cookies }, $new_cookie if $new_cookie;
+ push @{ $cookies }, $new_cookie unless $set;
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;
@@ -215,17 +179,36 @@ sub status {
return;
}
-sub target {
+sub as_string {
my $self = shift;
- return $self->STORE( 'Window-Target' => shift ) if @_;
- $self->FETCH( 'Window-Target' );
-}
+ my $eol = defined $_[0] ? shift : "\n";
+
+ 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';
+ 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/$eol(\s)/$1/g;
+ next unless $line =~ m/$eol|\015|\012/;
+ $line = substr $line, 0, 72 if length $line > 72;
+ croak "Invalid header value contains a new line ",
+ "not followed by whitespace: $line";
+ }
-sub STORABLE_thaw {
- my $self = shift->SUPER::STORABLE_thaw( @_ );
- tie my %header => 'CGI::Header::Entity' => $self->header;
- $header_of{ refaddr $self } = \%header;
- $self;
+ join $eol, @lines, q{};
}
sub DESTROY {
@@ -235,3 +218,76 @@ sub DESTROY {
}
1;
+
+__END__
+
+=head1 NAME
+
+CGI::Header - Emulates CGI::header()
+
+=head1 SYNOPSIS
+
+ use CGI::Header;
+ use CGI::Cookie;
+
+ my $cookie = CGI::Cookie->new(
+ -name => 'ID',
+ -value => 123456,
+ );
+
+ my $header = CGI::Header->new(
+ -attachment => 'genome.jpg',
+ -charset => 'utf-8',
+ -cookie => $cookie,
+ -expires => '+3M',
+ -nph => 1,
+ -p3p => [qw/CAO DSP LAW CURa/],
+ -target => 'ResultsWindow',
+ -type => 'text/plain',
+ );
+
+ print $header->as_string;
+
+=head1 DESCRIPTION
+
+Accepts the same arguments as CGI::header() does.
+Generates the same HTTP response headers as the subroutine does.
+
+=head2 METHODS
+
+=over 4
+
+=item $header = CGI::Header->new( -type => 'text/plain', ... )
+
+=item $value = $eader->get( $field )
+
+=item $header->set( $field => $value )
+
+=item $bool = $header->exists( $field )
+
+=item $deleted = $header->delete( $field )
+
+=item $header->clear
+
+=item @fields = $header->field_names
+
+=item $header->each( \&callback )
+
+=item @headers = $header->flatten
+
+=item $bool = $header->is_empty
+
+=item $clone = $header->clone
+
+=back
+
+=head1 AUTHOR
+
+Ryo Anazawa (anazawa@cpan.org)
+
+=head1 LICENSE
+
+This module is free software; you can redistibute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=cut
View
38 lib/CGI/Header/Entity.pm
@@ -9,7 +9,7 @@ my %header_of;
sub TIEHASH {
my $class = shift;
- my $header = ref $_[0] eq 'HASH' ? shift : { -type => q{} };
+ my $header = ref $_[0] eq 'HASH' ? shift : {};
my $self = bless \do { my $anon_scalar }, $class;
$header_of{ refaddr $self } = $header;
$self;
@@ -188,8 +188,9 @@ sub field_names {
push @fields, 'Content-Disposition' if delete $header{-attachment};
+ my $type = delete @header{ '-charset', '-type' };
+
# not ordered
- my $type = delete @header{qw/-charset -type/};
while ( my ($norm, $value) = each %header ) {
push @fields, $self->_denormalize( $norm ) if $value;
}
@@ -223,10 +224,7 @@ sub expires {
if ( @_ ) {
my $expires = shift;
-
- # CGI::header() automatically adds the Date header
delete $header->{-date};
-
$header->{-expires} = $expires;
}
elsif ( my $expires = $self->FETCH('Expires') ) {
@@ -270,6 +268,36 @@ 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 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 _date_header_is_fixed {
my $self = shift;
my $header = $header_of{ refaddr $self };
View
2  t/00_compile.t
@@ -1,5 +1,5 @@
use strict;
-use Test::More tests => 3;
+use Test::More tests => 2;
BEGIN {
use_ok 'CGI::Header::Entity';
View
18 t/12_adapter.t → t/12_entity.t
@@ -13,12 +13,18 @@ can_ok $class, qw(
);
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 %header = ();
+ my $header = $class->TIEHASH( \%header );
+ is $header->header, \%header;
+ is_deeply $header->header, {};
+
+ %header = ( -foo => 'bar' );
+ $header = $class->TIEHASH( \%header );
+ is $header->header, \%header;
+ is_deeply $header->header, { -foo => 'bar' };
+
+ $header = $class->TIEHASH;
+ is_deeply $header->header, {};
};
my %adaptee;
View
28 t/20_entity.t → t/20_basic.t
@@ -13,17 +13,33 @@ 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
+ content_type date status
DESTROY
);
subtest 'new()' => sub {
- my $header = $class->new;
- #is_deeply $header->header, { -type => q{} };
+ my %header = ();
+ my $header = $class->new( \%header );
+ is $header->header, \%header;
+ is_deeply $header->header, {};
+
+ $header = $class->new;
is_deeply $header->header, {};
- my %header;
+
+ #$header = $class->new( Foo => 'bar' );
+ #is_deeply $header->header, { -foo => 'bar', -type => q{} };
+
+
+ #%header = ( Foo => 'bar' );
+ #$header = $class->new( \%header ); # <=> $class->new( Foo => 'bar' )
+ #isnt $header->header, \%header;
+ #is_deeply $header->header, { -foo => 'bar', -type => q{} };
+
+ %header = ( -foo => 'bar' );
$header = $class->new( \%header );
is $header->header, \%header;
+ is_deeply $header->header, { -foo => 'bar' };
+
$header = $class->new( -foo => 'bar' );
is_deeply $header->header, { -foo => 'bar' };
};
@@ -205,7 +221,7 @@ subtest 'target()' => sub {
subtest 'clone()' => sub {
my $orig = $class->new( -foo => 'bar' );
my $clone = $orig->clone;
- isnt $clone, $orig;
+ #isnt $clone, $orig;
isnt $clone->header, $orig->header;
is_deeply $clone->header, $orig->header;
};
@@ -220,6 +236,6 @@ subtest 'clone()' => sub {
subtest 'DESTROY()' => sub {
my $h = $class->new;
$h->DESTROY;
- ok !$h->as_hashref;
+ #ok !$h->as_hashref;
ok !$h->header;
};
View
44 t/21_content_type.t
@@ -6,37 +6,37 @@ use Test::More tests => 2;
my %adaptee;
my $adapter = CGI::Header->new( \%adaptee );
-subtest 'charset()' => sub {
- %adaptee = ();
- is $adapter->charset, 'ISO-8859-1';
+#subtest 'charset()' => sub {
+# %adaptee = ();
+# is $adapter->charset, 'ISO-8859-1';
- %adaptee = ( -charset => q{} );
- is $adapter->charset, undef;
+# %adaptee = ( -charset => q{} );
+# is $adapter->charset, undef;
- %adaptee = ( -type => 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=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; 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 ; 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';
-};
+# %adaptee = ( -type => 'text/html;\r\n charset = iso-8859-1 ' );
+# is $adapter->charset, 'ISO-8859-1';
+#};
subtest 'content_type()' => sub {
%adaptee = ();
View
1  t/23_set_cookie.t
@@ -36,7 +36,6 @@ subtest 'set_cookie()' => sub {
%header = ();
$header->set_cookie( foo => { value => 'bar' } );
- #$got = $header{-cookie};
$got = $header{-cookie}[0];
isa_ok $got, 'CGI::Cookie';
is $got->value, 'bar';
View
28 t/24_as_string.t
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+use CGI;
+use Test::More tests => 1;
+use CGI::Header;
+
+my $CRLF = $CGI::CRLF;
+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);
+
+my $got = $header->as_string( $CRLF ) . $CRLF;
+my $expected = CGI::header( $header->header );
+
+is $got, $expected;
View
63 t/40_cgi_header.t
@@ -1,63 +0,0 @@
-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 );
View
4 xt/pod.t
@@ -0,0 +1,4 @@
+use strict;
+use Test::Pod;
+
+all_pod_files_ok();
Please sign in to comment.
Something went wrong with that request. Please try again.