From f9a6b47b3b916585d710eac141003fb8261d9c3c Mon Sep 17 00:00:00 2001 From: Simon Cozens Date: Wed, 8 Dec 2004 23:29:01 +0000 Subject: [PATCH] + Use HTTP::Headers for input/output headers. Add appropriate unit tests. + Make it easier to override classmetadata via template_args + Maypole::Application now creates a per-instance config() making it easier to run multiple Maypole apps in a persitant environment like mod_perl + Add missing items from Changes + Add beerdb.db to MANIFEST.SKIP git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@308 48953598-375a-da11-a14b-00016c27c3ee --- Changes | 10 +++- MANIFEST | 7 ++- MANIFEST.SKIP | 1 + Makefile.PL | 1 + lib/Apache/MVC.pm | 18 ++++-- lib/CGI/Maypole.pm | 37 ++++++++---- lib/Maypole.pm | 12 +++- lib/Maypole/Application.pm | 4 ++ lib/Maypole/CLI.pm | 1 + lib/Maypole/Headers.pm | 116 +++++++++++++++++++++++++++++++++++++ lib/Maypole/View/Base.pm | 28 ++++----- t/cgi_maypole.t | 33 ++++++++++- t/headers.t | 59 +++++++++++++++++++ t/maypole.t | 13 +++-- 14 files changed, 299 insertions(+), 41 deletions(-) create mode 100644 lib/Maypole/Headers.pm create mode 100755 t/headers.t diff --git a/Changes b/Changes index 3f4cbd9..d0280c9 100644 --- a/Changes +++ b/Changes @@ -14,8 +14,16 @@ Revision history for Perl extension Maypole - Check if has_a actually points to a Maypole::Model (Dave Howorth) - Only show buttons for public actions. (Dagfinn Ilmari Mannsåker) - - Added support for extra_headers + - Added $r->headers_in & $r->headers_out (request & response headers) - Split the meat of the view template off to a view_item macro. + - Prefix warn() in M::V::Base with error description + - #7651 - minor POD improvements in M::M::CDBI (Dave Howorth) + - #7834 - minor POD update in M::M::CDBI (Kevin Connor) + - default search action removes empty fields from search parameters + - Maypole::Application will create a separate Maypole::Config for each + application (instead of the current workaround for multiple apps under + mod_perl) + - classmetadata template variables can now be overriden individually 2.04 Tue Oct 27 14:00:00 2004 diff --git a/MANIFEST b/MANIFEST index fe6945f..b085f36 100644 --- a/MANIFEST +++ b/MANIFEST @@ -7,6 +7,7 @@ lib/Maypole/Application.pm lib/Maypole/CLI.pm lib/Maypole/Config.pm lib/Maypole/Constants.pm +lib/Maypole/Headers.pm lib/Maypole/Manual.pod lib/Maypole/Manual/About.pod lib/Maypole/Manual/Beer.pod @@ -27,6 +28,11 @@ MANIFEST MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) README +t/constants.t +t/maypole.t +t/apache_mvc.t +t/cgi_maypole.t +t/headers.t t/01basics.t t/02pod.t t/03podcoverage.t @@ -49,4 +55,3 @@ templates/factory/search_form templates/factory/title templates/factory/view templates/maypole.css -TODO diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 12fcb95..3bbaf94 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -1 +1,2 @@ \.svn +t\/beerdb\.db diff --git a/Makefile.PL b/Makefile.PL index c623c12..345bf6b 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -21,6 +21,7 @@ WriteMakefile( UNIVERSAL::require => 0, URI::QueryParam => 0, CGI::Simple => 0, + HTTP::Headers => 0, Template => 0, Template::Plugin::Class => 0, Test::MockModule => 0, diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index 0921412..7dbb241 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -7,6 +7,7 @@ use warnings; use base 'Maypole'; use mod_perl; +use Maypole::Headers; use constant APACHE2 => $mod_perl::VERSION >= 1.99; @@ -27,6 +28,14 @@ sub get_request { sub parse_location { my $self = shift; + + # Reconstruct the request headers + $self->headers_in(HTTP::Headers->new); + my %headers = $self->{ar}->headers_in; + for (keys %headers) { + $self->headers_in->set($_, $headers{$_}); + } + $self->{path} = $self->{ar}->uri; my $loc = $self->{ar}->location; no warnings 'uninitialized'; @@ -52,11 +61,12 @@ sub send_output { $r->{ar}->headers_out->set( "Content-Length" => do { use bytes; length $r->{output} } ); - foreach my $header (keys %{$r->{extra_headers}}) { - $r->{ar}->headers_out->set( - "$header" => $r->{extra_headers}{$header} - ); + + foreach ($r->headers_out->field_names) { + next if /^Content-/; + $r->{ar}->headers_out->set($_ => $r->headers_out->get($_)); } + APACHE2 || $r->{ar}->send_http_header; $r->{ar}->print( $r->{output} ); } diff --git a/lib/CGI/Maypole.pm b/lib/CGI/Maypole.pm index 88abc3c..94fd27b 100644 --- a/lib/CGI/Maypole.pm +++ b/lib/CGI/Maypole.pm @@ -4,6 +4,7 @@ use base 'Maypole'; use strict; use warnings; use CGI::Simple; +use Maypole::Headers; our $VERSION = '2.05'; @@ -16,10 +17,20 @@ sub get_request { shift->{cgi} = CGI::Simple->new(); } + sub parse_location { my $self = shift; - $self->{path} = $self->{cgi}->url( -absolute => 1, -path_info => 1 ); - my $loc = $self->{cgi}->url( -absolute => 1 ); + my $cgi = $self->{cgi}; + + # Reconstruct the request headers (as far as this is possible) + $self->headers_in(Maypole::Headers->new); + for my $http_header ($cgi->http) { + (my $field_name = $http_header) =~ s/^HTTPS?_//; + $self->headers_in->set($field_name => $cgi->http($http_header)); + } + + $self->{path} = $cgi->url( -absolute => 1, -path_info => 1 ); + my $loc = $cgi->url( -absolute => 1 ); no warnings 'uninitialized'; $self->{path} .= '/' if $self->{path} eq $loc; $self->{path} =~ s/^($loc)?\///; @@ -40,17 +51,19 @@ sub parse_args { sub send_output { my $r = shift; - my %processed = map { "-".$_,$r->{extra_headers}{$_} } - keys %{$r->{extra_headers}}; - print $r->{cgi}->header( - -type => $r->{content_type}, - -charset => $r->{document_encoding}, - -content_length => do { use bytes; length $r->{output} }, - %processed - ? %processed - : {} + + # Collect HTTP headers + my %headers = ( + -type => $r->{content_type}, + -charset => $r->{document_encoding}, + -content_length => do { use bytes; length $r->{output} }, ); - print $r->{output}; + foreach ($r->headers_out->header_field_names) { + next if /^Content-/; + $headers{"-$_"} = $r->headers_out->get($_); + } + + print $r->{cgi}->header(%headers), $r->{output}; } sub get_template_root { diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 1665ca7..3215b84 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -5,6 +5,7 @@ use strict; use warnings; use Maypole::Config; use Maypole::Constants; +use Maypole::Headers; our $VERSION = '2.05'; @@ -12,7 +13,7 @@ __PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); __PACKAGE__->mk_accessors( qw( ar params query objects model_class template_args output path args action template error document_encoding content_type table - extra_headers ) + headers_in headers_out ) ); __PACKAGE__->config( Maypole::Config->new() ); __PACKAGE__->init_done(0); @@ -62,6 +63,7 @@ sub handler { my ( $class, $req ) = @_; $class->init unless $class->init_done; my $r = bless { template_args => {}, config => $class->config }, $class; + $r->headers_out(Maypole::Headers->new); $r->get_request($req); $r->parse_location(); my $status = $r->handler_guts(); @@ -277,9 +279,13 @@ A list of remaining parts of the request path after table and action have been removed -=head3 extra_headers +=head3 headers_in -A hash containing extra headers to be set on a request. +A L object containing HTTP headers for the request + +=head3 headers_out + +A L object that contains HTTP headers for the output =head3 parse_args diff --git a/lib/Maypole/Application.pm b/lib/Maypole/Application.pm index 584b0e4..c10221a 100644 --- a/lib/Maypole/Application.pm +++ b/lib/Maypole/Application.pm @@ -4,8 +4,10 @@ use strict; use warnings; use UNIVERSAL::require; use Maypole; +use Maypole::Config; our @ISA; +our $VERSION = '2.05'; sub import { my ( $self, @plugins ) = @_; @@ -30,6 +32,8 @@ sub import { } } } + + $caller->config(Maypole::Config->new); $caller->setup() if $autosetup; } diff --git a/lib/Maypole/CLI.pm b/lib/Maypole/CLI.pm index 81a2fd5..504d0b4 100644 --- a/lib/Maypole/CLI.pm +++ b/lib/Maypole/CLI.pm @@ -31,6 +31,7 @@ sub parse_location { my $url = URI->new( shift @ARGV ); my $root = URI->new( $self->config->uri_base )->path; $self->{path} = $url->path; + $self->{path} .= '/' if $self->{path} eq $root; $self->{path} =~ s/^$root//i if $root; $self->parse_path; $self->parse_args($url); diff --git a/lib/Maypole/Headers.pm b/lib/Maypole/Headers.pm new file mode 100644 index 0000000..a72f01c --- /dev/null +++ b/lib/Maypole/Headers.pm @@ -0,0 +1,116 @@ +package Maypole::Headers; +use base 'HTTP::Headers'; + +use strict; +use warnings; + +our $VERSION = "1." . sprintf "%04d", q$Rev$ =~ /: (\d+)/; + +sub get { + shift->header(shift); +} + +sub set { + shift->header(@_); +} + +sub push { + shift->push_header(@_); +} + +sub init { + shift->init_header(@_); +} + +sub remove { + shift->remove_header(@_); +} + +sub field_names { + shift->header_field_names(@_); +} + +1; + +=pod + +=head1 NAME + +Maypole::Headers - Convenience wrapper around HTTP::Headers + +=head1 SYNOPSIS + + use Maypole::Headers; + + $r->headers_out(Maypole::Headers->new); + $r->headers_out->set('Content-Base' => 'http://localhost/maypole'); + $r->headers_out->push('Set-Cookie' => $cookie->as_string); + $r->headers_out->push('Set-Cookie' => $cookie2->as_string); + + print $r->headers_out->as_string; + +=head1 DESCRIPTION + +A convenience wrapper around C. Additional methods are provided +to make the mutators less repetitive and wordy. For example: + + $r->headers->header(Content_Base => $r->config->uri_base); + +can be written as: + + $r->headers->set(Content_Base => $r->config->uri_base); + +=head1 METHODS + +All the standard L methods, plus the following: + +=over + +=item get($header) + +Get the value of a header field. + +An alias to Cheader> + +=item set($header =C $value, ...) + +Set the value of one or more header fields + +An alias to Cheader> + +=item push($header =C $value) + +Add a value to the field named C<$header>. Previous values are maintained. + +An alias to Cpush_header> + +=item init($header =C $value) + +Set the value for the field named C<$header>, but only if that header is +currently undefined. + +An alias to Cinit_header> + +=item remove($header, ...) + +Remove one of more headers + +An alias to Cremove_header> + +=item field_names() + +Returns a list of distinct header names + +An alias to Cheader_field_names> + +=back + +=head1 SEE ALSO + +L + +=head1 AUTHORS + +Simon Flack + +=cut diff --git a/lib/Maypole/View/Base.pm b/lib/Maypole/View/Base.pm index 95c8d9d..edba625 100644 --- a/lib/Maypole/View/Base.pm +++ b/lib/Maypole/View/Base.pm @@ -34,17 +34,17 @@ sub vars { # ... ); if ($class) { - $args{classmetadata} = { - name => $class, - table => $class->table, - columns => [ $class->display_columns ], - list_columns => [ $class->list_columns ], - colnames => { $class->column_names }, - related_accessors => [ $class->related($r) ], - moniker => $class->moniker, - plural => $class->plural_moniker, - cgi => { $class->to_cgi }, - }; + my $classmeta = $args{classmetadata} ||= {}; + $classmeta->{name} ||= $class; + $classmeta->{description} ||= $class->description; + $classmeta->{table} ||= $class->table; + $classmeta->{columns} ||= [ $class->display_columns ]; + $classmeta->{list_columns} ||= [ $class->list_columns ]; + $classmeta->{colnames} ||= { $class->column_names }; + $classmeta->{related_accessors} ||= [ $class->related($r) ]; + $classmeta->{moniker} ||= $class->moniker; + $classmeta->{plural} ||= $class->plural_moniker; + $classmeta->{cgi} ||= { $class->to_cgi }; # User-friendliness facility for custom template writers. if ( @{ $r->objects || [] } > 1 ) { @@ -56,6 +56,7 @@ sub vars { } # Overrides + local $r->{template_args}{classmetadata}; # already overrides %args = ( %args, %{ $r->{template_args} || {} } ); %args; } @@ -70,8 +71,9 @@ sub process { } sub error { - my ( $self, $r ) = @_; - warn $r->{error}; + my ( $self, $r, $desc ) = @_; + $desc = $desc ? "$desc: " : ""; + warn $desc . $r->{error} ."\n"; if ( $r->{error} =~ /not found$/ ) { # This is a rough test to see whether or not we're a template or diff --git a/t/cgi_maypole.t b/t/cgi_maypole.t index f4d4e82..d8a5ccf 100644 --- a/t/cgi_maypole.t +++ b/t/cgi_maypole.t @@ -1,11 +1,12 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 26; +use Test::More tests => 30; use Test::MockModule; require_ok('CGI::Maypole'); ok($CGI::Maypole::VERSION, 'defines $VERSION'); ok($INC{'CGI/Simple.pm'}, 'requires CGI::Simple'); +ok($INC{'Maypole/Headers.pm'}, 'requires Maypole::Headers'); ok(CGI::Maypole->isa('Maypole'), '@ISA = Maypole'); my %calls; @@ -26,12 +27,16 @@ is_deeply($calls{handler}, ['CGI::Maypole'], is($status, 'X', '... and returns its status'); my $r = bless {}, 'CGI::Maypole'; +$r->headers_out(Maypole::Headers->new); $ENV{HTTP_HOST} = 'localhost'; $ENV{SCRIPT_NAME} = '/maypole/index.cgi'; $ENV{PATH_INFO} = '/'; $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'beer=1;beer=2;pub=red+lion;handpump'; $ENV{DOCUMENT_ROOT} = '/var/tmp/maypole'; +for (keys %ENV) { + delete $ENV{$_} if /^HTTPS?/; +} # get_request() can_ok($r => 'get_request'); @@ -41,7 +46,13 @@ is($cgi, $r->{cgi}, '... and stores it in the "cgi" slot'); # parse_location() can_ok($r => 'parse_location'); +$ENV{HTTP_REFERER} = 'http://maypole.perl.org/'; +$ENV{HTTP_USER_AGENT} = 'tty'; $r->parse_location; +is($r->headers_in->get('Referer'), 'http://maypole.perl.org/', + '... sets headers_in() from HTTP variables'); +is_deeply([$r->headers_in->field_names], [qw(Referer User-Agent)], + '... loads only those HTTP variables'); is($r->path, 'frontpage', '... sets "path" to frontpage if undefined'); #delete $r->{cgi}{'.path_info'}; @@ -79,12 +90,28 @@ SKIP: { $r->content_type('text/plain'); $r->document_encoding('iso8859-1'); $r->output('Hello World!'); - my $stdout; - IO::CaptureOutput::capture(sub {$r->send_output}, \$stdout); + my $stdout; + eval { + IO::CaptureOutput::capture(sub {$r->send_output}, \$stdout); + }; + diag $@ if $@; my $compare = join "\cM\cJ", 'Content-length: 12', 'Content-Type: text/plain; charset=iso8859-1', '', 'Hello World!'; is($stdout, $compare, '... prints output, including content-type header'); + + # test custom output headers + $r->headers_out->set(X_Bender => 'kiss my shiny metal ass'); + eval { + IO::CaptureOutput::capture(sub {$r->send_output}, \$stdout); + }; + diag $@ if $@; + + $compare = join "\cM\cJ", 'Content-length: 12', + 'X-bender: kiss my shiny metal ass', + 'Content-Type: text/plain; charset=iso8859-1', + '', 'Hello World!'; + is($stdout, $compare, '... prints output, including custom headers'); } # get_template_root() diff --git a/t/headers.t b/t/headers.t new file mode 100755 index 0000000..d51eb55 --- /dev/null +++ b/t/headers.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl -w +use strict; +use Test::More tests => 22; + +require_ok('Maypole::Headers'); +ok($Maypole::Headers::VERSION, 'defines $VERSION'); +ok($INC{'HTTP/Headers.pm'}, 'requires HTTP::Headers'); +ok(Maypole::Headers->isa('HTTP::Headers'), '@ISA = HTTP::Headers'); +ok(Maypole::Headers->can('new'), 'can new()'); +my $h = Maypole::Headers->new; +isa_ok($h, 'Maypole::Headers'); + +# set() +can_ok($h => 'set'); +$h->set(hello_world => 1); +$h->set(JAPH => [qw(Just Another Perl Hacker!)]); +$h->set(Content_Type => 'text/plain', Referer => 'http://localhost/'); + +# get() +can_ok($h => 'get'); +is($h->get('Hello-World'), 1, '... name is normalised, fetches value'); +ok($h->get('Content_Type') eq 'text/plain' + && $h->get('Referer') eq 'http://localhost/', + '... fetches values set() in the same call'); +is($h->get('JAPH'), 'Just, Another, Perl, Hacker!', + '... fetches comma-separated multiple values'); +is($h->get('non-existant'), undef, + '... returns undef for non-existant header'); + +# push() +can_ok($h, 'push'); +$h->push(japh => 'TMTOWTDI'); +is($h->get('JAPH'), 'Just, Another, Perl, Hacker!, TMTOWTDI', + '... appends to a header'); +$h->push(H2G2 => 42); +is($h->get('H2G2'), 42, + "...can be used like in place of set() if the field doesn't already exist"); + +# push() +can_ok($h, 'init'); +$h->init(X_Server_Software => 'Maypole'); +is($h->get('X-Server-Software'), 'Maypole', + "... Sets a value if it doesn't already exist"); +$h->init(X_Server_Software => 'Maypole-XP'); +is($h->get('X-Server-Software'), 'Maypole', + "... subsequent init()s don't replace previous values"); + +# remove() +can_ok($h, 'remove'); +$h->remove('H2G2'); +is($h->get('H2G2'), undef, 'removes a previously defined field'); + +# field_names() +can_ok($h, 'field_names'); +is_deeply([$h->field_names], + [qw(Referer Content-Type Hello-World JAPH X-Server-Software)], + '... returns a list of field names'); + +# print $h->as_string; diff --git a/t/maypole.t b/t/maypole.t index a537732..4da0de6 100755 --- a/t/maypole.t +++ b/t/maypole.t @@ -1,7 +1,7 @@ #!/usr/bin/perl use strict; use warnings; -use Test::More tests => 103; +use Test::More tests => 107; use Test::MockModule; # module compilation @@ -14,6 +14,7 @@ ok($Maypole::VERSION, 'defines $VERSION'); ok($INC{'Maypole/Config.pm'}, 'loads Maypole::Config'); ok($INC{'UNIVERSAL/require.pm'}, 'loads UNIVERSAL::require'); ok($INC{'Maypole/Constants.pm'}, 'loads Maypole::Constants'); +ok($INC{'Maypole/Headers.pm'}, 'loads Maypole::Headers'); ok($INC{'Class/Accessor/Fast.pm'}, 'loads Class::Accessor::Fast'); ok($INC{'Class/Data/Inheritable.pm'}, 'loads Class::Data::Inheritable'); ok(Maypole->can('config'), 'defines a config attribute'); @@ -37,6 +38,8 @@ ok(Maypole->can('error'), 'defines an "error" accessor'); ok(Maypole->can('document_encoding'), 'defines a "document_encoding" accessor'); ok(Maypole->can('content_type'), 'defines a "content_type" accessor'); ok(Maypole->can('table'), 'defines a "table" accessor'); +ok(Maypole->can('headers_in'), 'defines a "headers_in" accessor'); +ok(Maypole->can('headers_out'), 'defines a "headers_out" accessor'); # simple test class that inherits from Maypole package MyDriver; @@ -127,11 +130,13 @@ my ($r, $req); # request objects my $rv = $driver_class->handler(); ok($r && $r->isa($driver_class), '... created $r'); ok($called{get_request}, '... calls get_request()'); - ok($called{get_request}, '... calls parse_location'); - ok($called{get_request}, '... calls handler_guts()'); - ok($called{get_request}, '... call send_output'); + ok($called{parse_location}, '... calls parse_location'); + ok($called{handler_guts}, '... calls handler_guts()'); + ok($called{send_output}, '... call send_output'); is($rv, 0, '... return status (should be ok?)'); ok(!$init, "... doesn't call init() if init_done()"); + ok($r->headers_out && $r->headers_out->isa('Maypole::Headers'), + '... populates headers_out() with a Maypole::Headers object'); # call again, testing other branches $driver_class->init_done(0); $status = -1; -- 2.39.2