Permalink
Browse files

add examples

  • Loading branch information...
1 parent 6119d8c commit 2e90bd5917aaa318028cece1151356ba20a0bbf6 Ryo Anazawa committed Jun 15, 2013
View
@@ -17,6 +17,8 @@ test_requires 'Test::Output';
test_requires 'CGI::Simple';
test_requires 'base';
+no_index directory => 'examples';
+
tests 't/*.t xt/*.t';
WriteAll;
@@ -0,0 +1,178 @@
+package CGI::Header::Adapter;
+use strict;
+use warnings;
+use parent 'CGI::Header';
+use Carp qw/croak/;
+
+sub crlf {
+ $CGI::CRLF;
+}
+
+sub finalize {
+ croak 'call to abstract method ', __PACKAGE__, '::finalize';
+}
+
+sub as_string {
+ my $self = shift;
+ my $query = $self->query;
+ my $crlf = $self->crlf;
+ my $headers = $self->as_arrayref;
+
+ my @lines;
+
+ # add Status-Line required by NPH scripts
+ if ( $self->nph or $query->nph ) {
+ my $protocol = $query->server_protocol;
+ my $status = $self->process_newline( {@$headers}->{'Status'} || '200 OK' );
+ push @lines, "$protocol $status$crlf";
+ }
+
+ # add response headers
+ for ( my $i = 0; $i < @$headers; $i += 2 ) {
+ my $field = $headers->[$i];
+ my $value = $self->process_newline( $headers->[$i+1] );
+ push @lines, "$field: $value$crlf";
+ }
+
+ push @lines, $crlf; # add an empty line
+
+ join q{}, @lines;
+}
+
+sub process_newline {
+ my $self = shift;
+ my $value = shift;
+ my $crlf = $self->crlf;
+
+ # CR escaping for values, per RFC 822:
+ # > Unfolding is accomplished by regarding CRLF immediately
+ # > followed by a LWSP-char as equivalent to the LWSP-char.
+ $value =~ s/$crlf(\s)/$1/g;
+
+ # All other uses of newlines are invalid input.
+ if ( $value =~ /$crlf|\015|\012/ ) {
+ # shorten very long values in the diagnostic
+ $value = substr($value, 0, 72) . '...' if length $value > 72;
+ croak "Invalid header value contains a newline not followed by whitespace: $value";
+ }
+
+ $value;
+}
+
+sub as_arrayref {
+ my $self = shift;
+ my $query = $self->query;
+ my %header = %{ $self->header };
+
+ my ( $attachment, $charset, $cookies, $expires, $nph, $p3p, $status, $target, $type )
+ = delete @header{qw/attachment charset cookies expires nph p3p status target type/};
+
+ my @headers;
+
+ $nph ||= $query->nph;
+
+ push @headers, 'Server', $query->server_software if $nph;
+ push @headers, 'Status', $status if $status;
+ push @headers, 'Window-Target', $target if $target;
+
+ if ( $p3p ) {
+ my $tags = ref $p3p eq 'ARRAY' ? join ' ', @{$p3p} : $p3p;
+ push @headers, 'P3P', qq{policyref="/w3c/p3p.xml", CP="$tags"};
+ }
+
+ my @cookies = ref $cookies eq 'ARRAY' ? @{$cookies} : $cookies;
+ @cookies = map { $self->_bake_cookie($_) || () } @cookies;
+
+ push @headers, map { ('Set-Cookie', $_) } @cookies;
+ push @headers, 'Expires', $self->_date($expires) if $expires;
+ push @headers, 'Date', $self->_date if $expires or @cookies or $nph;
+ push @headers, 'Pragma', 'no-cache' if $query->cache;
+
+ if ( $attachment ) {
+ my $value = qq{attachment; filename="$attachment"};
+ push @headers, 'Content-Disposition', $value;
+ }
+
+ push @headers, map { ucfirst $_, $header{$_} } keys %header;
+
+ unless ( defined $type and $type eq q{} ) {
+ my $value = $type || 'text/html';
+ $charset = $query->charset if !defined $charset;
+ $value .= "; charset=$charset" if $charset && $value !~ /\bcharset\b/;
+ push @headers, 'Content-Type', $value;
+ }
+
+ \@headers;
+}
+
+sub _bake_cookie {
+ my ( $self, $cookie ) = @_;
+ ref $cookie eq 'CGI::Cookie' ? $cookie->as_string : $cookie;
+}
+
+sub _date {
+ my ( $self, $expires ) = @_;
+ CGI::Util::expires( $expires, 'http' );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Header::Adapter - Base class for adapters
+
+=head1 SYNOPSIS
+
+ use parent 'CGI::Header::Adapter';
+
+ sub finalize {
+ ...
+ }
+
+=head1 DESCRIPTION
+
+This module inherits from L<CGI::Header>, and also adds the following methods
+to the class:
+
+=over 4
+
+=item $headers = $header->as_arrayref
+
+Returns an arrayref which contains key-value pairs of HTTP headers.
+
+ $header->as_arrayref;
+ # => [
+ # 'Content-length' => '3002',
+ # 'Content-Type' => 'text/plain',
+ # ]
+
+This method helps you write an adapter for L<mod_perl> or a L<PSGI>
+application which wraps your CGI.pm-based application without parsing
+the return value of CGI.pm's C<header> method.
+
+=item $header->as_string
+
+Returns the header fields as a formatted MIME header.
+If the C<nph> property is set to true, the Status-Line is inserted to
+the beginning of the response headers.
+
+=item $header->crlf
+
+Returns the system specific line ending sequence.
+
+=item $header->process_newline
+
+=back
+
+=head1 AUTHOR
+
+Ryo Anazawa (anazawa@cpan.org)
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+=cut
@@ -0,0 +1,11 @@
+package CGI::Simple::Header;
+use strict;
+use warnings;
+use parent 'CGI::Header';
+
+sub _build_query {
+ require CGI::Simple::Standard;
+ CGI::Simple::Standard->loader('_cgi_object');
+}
+
+1;
@@ -0,0 +1,40 @@
+package CGI::Simple::Header::Adapter;
+use strict;
+use warnings;
+use parent 'CGI::Header::Adapter';
+use CGI::Simple::Util qw//;
+
+sub _build_query {
+ require CGI::Simple::Standard;
+ CGI::Simple::Standard->loader('_cgi_object');
+}
+
+sub crlf {
+ $_[0]->query->crlf;
+}
+
+sub as_arrayref {
+ my $self = shift;
+ my $query = $self->query;
+
+ if ( $query->no_cache ) {
+ $self = $self->clone->expires('now');
+ unless ( $query->cache or $self->exists('Pragma') ) {
+ $self->set( 'Pragma' => 'no-cache' );
+ }
+ }
+
+ $self->SUPER::as_arrayref;
+}
+
+sub _bake_cookie {
+ my ( $self, $cookie ) = @_;
+ ref $cookie eq 'CGI::Simple::Cookie' ? $cookie->as_string : $cookie;
+}
+
+sub _date {
+ my ( $self, $expires ) = @_;
+ CGI::Simple::Util::expires( $expires, 'http' );
+}
+
+1;
@@ -0,0 +1,11 @@
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+BEGIN {
+ use_ok 'CGI::Simple::Header';
+}
+
+my $header = CGI::Simple::Header->new;
+
+isa_ok $header->query, 'CGI::Simple';
@@ -0,0 +1,23 @@
+use strict;
+use warnings;
+use Test::MockTime qw/set_fixed_time/;
+use Test::More tests => 3;
+
+set_fixed_time( 1341637509 );
+
+BEGIN {
+ use_ok 'CGI::Simple::Header::Adapter';
+}
+
+my $header = CGI::Simple::Header::Adapter->new;
+
+$header->query->no_cache(1);
+
+is_deeply $header->as_arrayref, [
+ 'Expires', 'Sat, 07 Jul 2012 05:05:09 GMT',
+ 'Date', 'Sat, 07 Jul 2012 05:05:09 GMT',
+ 'Pragma', 'no-cache',
+ 'Content-Type', 'text/html; charset=ISO-8859-1',
+];
+
+is $header->as_string, $header->query->header;

0 comments on commit 2e90bd5

Please sign in to comment.