- 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
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
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
templates/factory/title
templates/factory/view
templates/maypole.css
-TODO
UNIVERSAL::require => 0,
URI::QueryParam => 0,
CGI::Simple => 0,
+ HTTP::Headers => 0,
Template => 0,
Template::Plugin::Class => 0,
Test::MockModule => 0,
use base 'Maypole';
use mod_perl;
+use Maypole::Headers;
use constant APACHE2 => $mod_perl::VERSION >= 1.99;
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';
$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} );
}
use strict;
use warnings;
use CGI::Simple;
+use Maypole::Headers;
our $VERSION = '2.05';
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)?\///;
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 {
use warnings;
use Maypole::Config;
use Maypole::Constants;
+use Maypole::Headers;
our $VERSION = '2.05';
__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);
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();
have been
removed
-=head3 extra_headers
+=head3 headers_in
-A hash containing extra headers to be set on a request.
+A L<Maypole::Headers> object containing HTTP headers for the request
+
+=head3 headers_out
+
+A L<HTTP::Headers> object that contains HTTP headers for the output
=head3 parse_args
use warnings;
use UNIVERSAL::require;
use Maypole;
+use Maypole::Config;
our @ISA;
+our $VERSION = '2.05';
sub import {
my ( $self, @plugins ) = @_;
}
}
}
+
+ $caller->config(Maypole::Config->new);
$caller->setup() if $autosetup;
}
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);
--- /dev/null
+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<HTTP::Headers>. 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<HTTP::Headers> methods, plus the following:
+
+=over
+
+=item get($header)
+
+Get the value of a header field.
+
+An alias to C<HTTP::Headers-E<gt>header>
+
+=item set($header =C<gt> $value, ...)
+
+Set the value of one or more header fields
+
+An alias to C<HTTP::Headers-E<gt>header>
+
+=item push($header =C<gt> $value)
+
+Add a value to the field named C<$header>. Previous values are maintained.
+
+An alias to C<HTTP::Headers-E<gt>push_header>
+
+=item init($header =C<gt> $value)
+
+Set the value for the field named C<$header>, but only if that header is
+currently undefined.
+
+An alias to C<HTTP::Headers-E<gt>init_header>
+
+=item remove($header, ...)
+
+Remove one of more headers
+
+An alias to C<HTTP::Headers-E<gt>remove_header>
+
+=item field_names()
+
+Returns a list of distinct header names
+
+An alias to C<HTTP::Headers-E<gt>header_field_names>
+
+=back
+
+=head1 SEE ALSO
+
+L<HTTP::Headers>
+
+=head1 AUTHORS
+
+Simon Flack
+
+=cut
# ...
);
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 ) {
}
# Overrides
+ local $r->{template_args}{classmetadata}; # already overrides
%args = ( %args, %{ $r->{template_args} || {} } );
%args;
}
}
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
#!/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;
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');
# 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'};
$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()
--- /dev/null
+#!/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;
#!/usr/bin/perl
use strict;
use warnings;
-use Test::More tests => 103;
+use Test::More tests => 107;
use Test::MockModule;
# module compilation
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');
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;
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;
projects / maypole.git / commitdiff