Permalink
Browse files

add as_string()

  • Loading branch information...
Ryo Anazawa
Ryo Anazawa committed Sep 23, 2012
1 parent a282355 commit a2545944b5b2637d33ec8a3c2fb35d9e8ce46759
Showing with 254 additions and 182 deletions.
  1. +2 −4 Makefile.PL
  2. +130 −74 lib/CGI/Header.pm
  3. +33 −5 lib/CGI/Header/Entity.pm
  4. +1 −1 t/00_compile.t
  5. +12 −6 t/{12_adapter.t → 12_entity.t}
  6. +22 −6 t/{20_entity.t → 20_basic.t}
  7. +22 −22 t/21_content_type.t
  8. +0 −1 t/23_set_cookie.t
  9. +28 −0 t/24_as_string.t
  10. +0 −63 t/40_cgi_header.t
  11. +4 −0 xt/pod.t
View
@@ -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
@@ -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
@@ -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
@@ -1,5 +1,5 @@
use strict;
-use Test::More tests => 3;
+use Test::More tests => 2;
BEGIN {
use_ok 'CGI::Header::Entity';
Oops, something went wrong.

0 comments on commit a254594

Please sign in to comment.