Permalink
Browse files

initial commit

  • Loading branch information...
0 parents commit a2823551f0e354cbfd5445f94c5ccfac4d11490f Ryo Anazawa committed Sep 23, 2012
Showing with 1,538 additions and 0 deletions.
  1. +4 −0 Changes
  2. +30 −0 Makefile.PL
  3. +28 −0 README
  4. +237 −0 lib/CGI/Header.pm
  5. +328 −0 lib/CGI/Header/Entity.pm
  6. +7 −0 t/00_compile.t
  7. +66 −0 t/10_normalization.t
  8. +35 −0 t/11_denormalization.t
  9. +112 −0 t/12_adapter.t
  10. +105 −0 t/13_content_type.t
  11. +57 −0 t/14_date.t
  12. +34 −0 t/15_p3p.t
  13. +40 −0 t/16_content_disposition.t
  14. +225 −0 t/20_entity.t
  15. +66 −0 t/21_content_type.t
  16. +35 −0 t/22_date.t
  17. +66 −0 t/23_set_cookie.t
  18. +63 −0 t/40_cgi_header.t
@@ -0,0 +1,4 @@
+Revision history for Perl extension CGI::Header.
+
+0.01 Sep 23rd, 2012
+ - Forked from Blosxom::Header
@@ -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
@@ -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;
Oops, something went wrong.

0 comments on commit a282355

Please sign in to comment.