# This file documents the revision history for Perl extension Catalyst.
5.7013
+ - Fix subdirs for scripts that run in subdirs more than one level deep.
- Added test and updated docs for handling the Authorization header
under mod_fastcgi/mod_cgi.
+ - Fixed bug in HTTP engine where the connection was not closed properly if the
+ client disconnected before sending any headers. (Ton Voon)
5.7012 2007-12-16 23:44:00
- Fix uri_for()'s and uri_with()'s handling of multibyte chars
--- /dev/null
+
+ - Add Class::Accessor compats
+ * Catalyst::Request
+ * Catalyst::Response
+ * Catalyst::Dispatcher
+ * Catalyst::Request::Upload
+ * Catalyst::Action
+ * Catalyst::ActionChain
+ * Catalyst::ActionContainer
+
+ - Make classes immutable at setup() time
+
}
# For on-demand data
- $c->request->{_context} = $c;
- $c->response->{_context} = $c;
- weaken( $c->request->{_context} );
- weaken( $c->response->{_context} );
+ $c->request->_context($c);
+ $c->response->_context($c);
# Allow engine to direct the prepare flow (for POE)
if ( $c->engine->can('prepare') ) {
package Catalyst::Action;
-use strict;
-use base qw/Class::Accessor::Fast/;
-
-
=head1 NAME
Catalyst::Action - Catalyst Action
=cut
-__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/);
+use Moose;
+
+has class => (is => 'rw');
+has namespace => (is => 'rw');
+has 'reverse' => (is => 'rw');
+has attributes => (is => 'rw');
+has name => (is => 'rw');
+has code => (is => 'rw');
+
+no Moose;
+
+no warnings 'recursion';
+
+#__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/);
use overload (
# Stringify to reverse for debug output etc.
- q{""} => sub { shift->{reverse} },
+ q{""} => sub { shift->reverse() },
# Codulate to execute to invoke the encapsulated action coderef
'&{}' => sub { my $self = shift; sub { $self->execute(@_); }; },
sub execute {
my $self = shift;
- $self->{code}->(@_);
+ $self->code->(@_);
}
sub match {
returns the sub name of this action.
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHOR
Matt S. Trout
package Catalyst::ActionChain;
-use strict;
-use base qw/Catalyst::Action/;
+use Moose;
+extends qw(Catalyst::Action);
+has chain => (is => 'rw');
=head1 NAME
=cut
-__PACKAGE__->mk_accessors(qw/chain/);
-
use overload (
# Stringify to reverse for debug output etc.
Takes a list of Catalyst::Action objects and constructs and returns a
Catalyst::ActionChain object representing a chain of these actions
-=cut
+=head2 meta
+
+Provided by Moose
=head1 AUTHOR
package Catalyst::ActionContainer;
-use strict;
-use base qw/Class::Accessor::Fast/;
-
=head1 NAME
Catalyst::ActionContainer - Catalyst Action Container
=cut
-__PACKAGE__->mk_accessors(qw/part actions/);
-
-use overload (
-
- # Stringify to path part for tree search
- q{""} => sub { shift->{part} },
+use Moose;
-);
-
-sub new {
- my ( $class, $fields ) = @_;
-
- $fields = { part => $fields, actions => {} } unless ref $fields;
-
- $class->SUPER::new($fields);
-}
+has part => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
+has actions => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
+around 'new' => sub {
+ my $next = shift;
+ my ($self, $params) = @_;
+ $params = { part => $params } unless ref $params;
+ $next->($self, $params);
+};
+no Moose;
sub get_action {
my ( $self, $name ) = @_;
Accessor to the path part this container resolves to. Also what the container
stringifies to.
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHOR
Matt S. Trout
package Catalyst::Dispatcher;
-use strict;
-use base 'Class::Accessor::Fast';
+use Moose;
+
use Catalyst::Exception;
use Catalyst::Utils;
use Catalyst::Action;
# Stringify to class
use overload '""' => sub { return ref shift }, fallback => 1;
-__PACKAGE__->mk_accessors(
- qw/tree dispatch_types registered_dispatch_types
- method_action_class action_container_class
- preload_dispatch_types postload_dispatch_types
- action_hash container_hash
- /
-);
# Preload these action types
our @PRELOAD = qw/Index Path Regex/;
# Postload these action types
our @POSTLOAD = qw/Default/;
+has _tree => (is => 'rw');
+has _dispatch_types => (is => 'rw');
+has _registered_dispatch_types => (is => 'rw');
+has _method_action_class => (is => 'rw');
+has _action_container_class => (is => 'rw');
+has preload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@PRELOAD] });
+has postload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@POSTLOAD] });
+has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
+has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
+
+no Moose;
+
=head1 NAME
Catalyst::Dispatcher - The Catalyst Dispatcher
=cut
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
-
- my $obj = $class->SUPER::new(@_);
+sub BUILD {
+ my ($self, $params) = @_;
- # set the default pre- and and postloads
- $obj->preload_dispatch_types( \@PRELOAD );
- $obj->postload_dispatch_types( \@POSTLOAD );
- $obj->action_hash( {} );
- $obj->container_hash( {} );
+ my $container =
+ Catalyst::ActionContainer->new( { part => '/', actions => {} } );
- # Create the root node of the tree
- my $container =
- Catalyst::ActionContainer->new( { part => '/', actions => {} } );
- $obj->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
-
- return $obj;
+ $self->_tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) );
}
=head2 $self->preload_dispatch_types
#push @$args, @_;
+ no warnings 'recursion';
+
local $c->request->{arguments} = \@args;
$action->dispatch( $c );
my $class = $self->_find_component_class( $c, $component ) || return 0;
if ( my $code = $class->can($method) ) {
- return $self->method_action_class->new(
+ return $self->_method_action_class->new(
{
name => $method,
code => $code,
# Check out dispatch types to see if any will handle the path at
# this level
- foreach my $type ( @{ $self->dispatch_types } ) {
+ foreach my $type ( @{ $self->_dispatch_types } ) {
last DESCEND if $type->match( $c, $path );
}
$namespace = join( "/", grep { length } split '/', $namespace || "" );
- return $self->action_hash->{"$namespace/$name"};
+ return $self->_action_hash->{"$namespace/$name"};
}
=head2 $self->get_action_by_path( $path );
my ( $self, $path ) = @_;
$path =~ s/^\///;
$path = "/$path" unless $path =~ /\//;
- $self->action_hash->{$path};
+ $self->_action_hash->{$path};
}
=head2 $self->get_actions( $c, $action, $namespace )
if ( length $namespace ) {
do {
- push @containers, $self->container_hash->{$namespace};
+ push @containers, $self->_container_hash->{$namespace};
} while ( $namespace =~ s#/[^/]+$## );
}
- return reverse grep { defined } @containers, $self->container_hash->{''};
+ return reverse grep { defined } @containers, $self->_container_hash->{''};
my @parts = split '/', $namespace;
}
sub uri_for_action {
my ( $self, $action, $captures) = @_;
$captures ||= [];
- foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
+ foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
my $uri = $dispatch_type->uri_for_action( $action, $captures );
return( $uri eq '' ? '/' : $uri )
if defined($uri);
sub register {
my ( $self, $c, $action ) = @_;
- my $registered = $self->registered_dispatch_types;
+ my $registered = $self->_registered_dispatch_types;
my $priv = 0;
foreach my $key ( keys %{ $action->attributes } ) {
my $class = "Catalyst::DispatchType::$key";
unless ( $registered->{$class} ) {
eval "require $class";
- push( @{ $self->dispatch_types }, $class->new ) unless $@;
+ push( @{ $self->_dispatch_types }, $class->new ) unless $@;
$registered->{$class} = 1;
}
}
# Pass the action to our dispatch types so they can register it if reqd.
- foreach my $type ( @{ $self->dispatch_types } ) {
+ foreach my $type ( @{ $self->_dispatch_types } ) {
$type->register( $c, $action );
}
# Set the method value
$container->add_action($action);
- $self->action_hash->{"$namespace/$name"} = $action;
- $self->container_hash->{$namespace} = $container;
+ $self->_action_hash->{"$namespace/$name"} = $action;
+ $self->_container_hash->{$namespace} = $container;
}
sub _find_or_create_action_container {
my ( $self, $namespace ) = @_;
- my $tree ||= $self->tree;
+ my $tree ||= $self->_tree;
return $tree->getNodeValue unless $namespace;
sub setup_actions {
my ( $self, $c ) = @_;
- $self->dispatch_types( [] );
- $self->registered_dispatch_types( {} );
- $self->method_action_class('Catalyst::Action');
- $self->action_container_class('Catalyst::ActionContainer');
+ $self->_dispatch_types( [] );
+ $self->_registered_dispatch_types( {} );
+ $self->_method_action_class('Catalyst::Action');
+ $self->_action_container_class('Catalyst::ActionContainer');
my @classes =
$self->_load_dispatch_types( @{ $self->preload_dispatch_types } );
- @{ $self->registered_dispatch_types }{@classes} = (1) x @classes;
+ @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes;
foreach my $comp ( values %{ $c->components } ) {
$comp->register_actions($c) if $comp->can('register_actions');
$walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
};
- $walker->( $walker, $self->tree, '' );
+ $walker->( $walker, $self->_tree, '' );
$c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" )
if $has_private;
# List all public actions
- $_->list($c) for @{ $self->dispatch_types };
+ $_->list($c) for @{ $self->_dispatch_types };
}
sub _load_dispatch_types {
eval "require $class";
Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ )
if $@;
- push @{ $self->dispatch_types }, $class->new;
+ push @{ $self->_dispatch_types }, $class->new;
push @loaded, $class;
}
return @loaded;
}
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHOR
Sebastian Riedel, C<sri@cpan.org>
if ( !$self->_read_headers ) {
# Error reading, give up
+ close Remote;
next LISTEN;
}
my ( $method, $uri, $protocol ) = $self->_parse_request_line;
+
+ next unless $method;
DEBUG && warn "Parsed request: $method $uri $protocol\n";
-
- next unless $method;
unless ( uc($method) eq 'RESTART' ) {
while (1) {
my $read = sysread Remote, my $buf, CHUNKSIZE;
-
- if ( !$read ) {
- DEBUG && warn "EOF or error: $!\n";
+
+ if ( !defined $read ) {
+ next if $! == EWOULDBLOCK;
+ DEBUG && warn "Error reading headers: $!\n";
+ return;
+ }
+ elsif ( $read == 0 ) {
+ DEBUG && warn "EOF\n";
return;
}
package Catalyst::Request;
-use strict;
-use base 'Class::Accessor::Fast';
-
use IO::Socket qw[AF_INET inet_aton];
use Carp;
use utf8;
use URI::https;
use URI::QueryParam;
-__PACKAGE__->mk_accessors(
- qw/action address arguments cookies headers query_keywords match method
- protocol query_parameters secure captures uri user/
+use Moose;
+
+has action => (is => 'rw');
+has address => (is => 'rw');
+has arguments => (is => 'rw', default => sub { [] });
+has cookies => (is => 'rw', default => sub { {} });
+has query_keywords => (is => 'rw');
+has match => (is => 'rw');
+has method => (is => 'rw');
+has protocol => (is => 'rw');
+has query_parameters => (is => 'rw', default => sub { {} });
+has secure => (is => 'rw', default => 0);
+has captures => (is => 'rw', default => sub { [] });
+has uri => (is => 'rw');
+has user => (is => 'rw');
+has headers => (
+ is => 'rw',
+ isa => 'HTTP::Headers',
+ handles => [qw(content_encoding content_length content_type header referer user_agent)],
+);
+
+has _context => (
+ is => 'rw',
+ weak_ref => 1,
+);
+
+has body_parameters => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub { {} },
);
-*args = \&arguments;
-*body_params = \&body_parameters;
-*input = \&body;
-*params = \¶meters;
-*query_params = \&query_parameters;
-*path_info = \&path;
-*snippets = \&captures;
-
-sub content_encoding { shift->headers->content_encoding(@_) }
-sub content_length { shift->headers->content_length(@_) }
-sub content_type { shift->headers->content_type(@_) }
-sub header { shift->headers->header(@_) }
-sub referer { shift->headers->referer(@_) }
-sub user_agent { shift->headers->user_agent(@_) }
+before body_parameters => sub {
+ my ($self) = @_;
+ $self->_context->prepare_body();
+};
+
+has uploads => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub { {} },
+);
+
+before uploads => sub {
+ my ($self) = @_;
+ $self->_context->prepare_body;
+};
+
+has parameters => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub { {} },
+);
+
+before parameters => sub {
+ my ($self, $params) = @_;
+ $self->_context->prepare_body();
+ if ( $params && !ref $params ) {
+ $self->_context->log->warn(
+ "Attempt to retrieve '$params' with req->params(), " .
+ "you probably meant to call req->param('$params')" );
+ $params = undef;
+ }
+
+};
+
+has base => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ if( $self->uri ){
+ return $self->path;
+ }
+ },
+);
+
+has body => (
+ is => 'rw'
+);
+
+before body => sub {
+ my ($self) = @_;
+ $self->_context->prepare_body();
+};
+
+has hostname => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+ gethostbyaddr( inet_aton( $self->address ), AF_INET )
+ },
+);
+
+no Moose;
+
+sub args { shift->arguments(@_) }
+sub body_params { shift->body_parameters(@_) }
+sub input { shift->body(@_) }
+sub params { shift->parameters(@_) }
+sub query_params { shift->query_parameters(@_) }
+sub path_info { shift->path(@_) }
+sub snippets { shift->captures(@_) }
=head1 NAME
If your application was queried with the URI
C<http://localhost:3000/some/path> then C<base> is C<http://localhost:3000/>.
-=cut
-
-sub base {
- my ( $self, $base ) = @_;
-
- return $self->{base} unless $base;
-
- $self->{base} = $base;
-
- # set the value in path for backwards-compat
- if ( $self->uri ) {
- $self->path;
- }
-
- return $self->{base};
-}
-
=head2 $req->body
Returns the message body of the request, unless Content-Type is
C<application/x-www-form-urlencoded> or C<multipart/form-data>.
-=cut
-
-sub body {
- my $self = shift;
- $self->{_context}->prepare_body;
-
- return unless $self->{_body};
-
- return $self->{_body}->body;
-}
-
=head2 $req->body_parameters
Returns a reference to a hash containing body (POST) parameters. Values can
Shortcut for body_parameters.
-=cut
-
-sub body_parameters {
- my ( $self, $params ) = @_;
- $self->{_context}->prepare_body;
- $self->{body_parameters} = $params if $params;
- return $self->{body_parameters};
-}
-
=head2 $req->content_encoding
Shortcut for $req->headers->content_encoding.
Returns the hostname of the client.
-=cut
-
-sub hostname {
- my $self = shift;
-
- if ( @_ == 0 && not $self->{hostname} ) {
- $self->{hostname} =
- gethostbyaddr( inet_aton( $self->address ), AF_INET );
- }
-
- if ( @_ == 1 ) {
- $self->{hostname} = shift;
- }
-
- return $self->{hostname};
-}
-
=head2 $req->input
Alias for $req->body.
Shortcut for $req->parameters.
-=cut
-
-sub parameters {
- my ( $self, $params ) = @_;
- $self->{_context}->prepare_body;
- if ( $params ) {
- if ( ref $params ) {
- $self->{parameters} = $params;
- }
- else {
- $self->{_context}->log->warn(
- "Attempt to retrieve '$params' with req->params(), " .
- "you probably meant to call req->param('$params')" );
- }
- }
- return $self->{parameters};
-}
-
=head2 $req->path
Returns the path, i.e. the part of the URI after $req->base, for the current request.
=cut
-sub read { shift->{_context}->read(@_); }
+sub read { shift->_context->read(@_); }
=head2 $req->referer
my $upload = $c->request->uploads->{field};
my $upload = $c->request->uploads->{field}->[0];
-=cut
-
-sub uploads {
- my ( $self, $uploads ) = @_;
- $self->{_context}->prepare_body;
- $self->{uploads} = $uploads if $uploads;
- return $self->{uploads};
-}
-
=head2 $req->uri
Returns a URI object for the current request. Stringifies to the URI text.
Shortcut to $req->headers->user_agent. Returns the user agent (browser)
version string.
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHORS
Sebastian Riedel, C<sri@cpan.org>
package Catalyst::Request::Upload;
use strict;
-use base 'Class::Accessor::Fast';
use Catalyst::Exception;
use File::Copy ();
use IO::File ();
use File::Spec::Unix;
-__PACKAGE__->mk_accessors(qw/filename headers size tempname type basename/);
+use Moose;
-sub new { shift->SUPER::new( ref( $_[0] ) ? $_[0] : {@_} ) }
+has filename => (is => 'rw');
+has headers => (is => 'rw');
+has size => (is => 'rw');
+has tempname => (is => 'rw');
+has type => (is => 'rw');
+has basename => (is => 'rw');
+
+has fh => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+
+ my $fh = IO::File->new($self->tempname, IO::File::O_RDONLY);
+ unless ( defined $fh ) {
+ my $filename = $self->tempname;
+ Catalyst::Exception->throw(
+ message => qq/Can't open '$filename': '$!'/ );
+ }
+
+ return $fh;
+ },
+);
+
+no Moose;
=head1 NAME
Opens a temporary file (see tempname below) and returns an L<IO::File> handle.
-=cut
-
-sub fh {
- my $self = shift;
-
- my $fh = IO::File->new( $self->tempname, IO::File::O_RDONLY );
-
- unless ( defined $fh ) {
-
- my $filename = $self->tempname;
-
- Catalyst::Exception->throw(
- message => qq/Can't open '$filename': '$!'/ );
- }
-
- return $fh;
-}
-
=head2 $upload->filename
Returns the client-supplied filename.
Returns the client-supplied Content-Type.
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHORS
Sebastian Riedel, C<sri@cpan.org>
package Catalyst::Response;
-use strict;
-use base 'Class::Accessor::Fast';
+use Moose;
-__PACKAGE__->mk_accessors(qw/cookies body headers location status/);
+has cookies => (is => 'rw');
+has body => (is => 'rw');
+has location => (is => 'rw');
+has status => (is => 'rw');
+has headers => (
+ is => 'rw',
+ handles => [qw(content_encoding content_length content_type header)],
+);
-*output = \&body;
+has _context => (
+ is => 'rw',
+ weak_ref => 1,
+);
-sub content_encoding { shift->headers->content_encoding(@_) }
-sub content_length { shift->headers->content_length(@_) }
-sub content_type { shift->headers->content_type(@_) }
-sub header { shift->headers->header(@_) }
+sub output { shift->body(@_) }
+
+no Moose;
=head1 NAME
return $self->location;
}
+=head2 $res->location
+
+Sets or returns the HTTP 'Location'.
+
=head2 $res->status
Sets or returns the HTTP status.
=cut
-sub write { shift->{_context}->write(@_); }
+sub write { shift->_context->write(@_); }
+
+=head2 meta
+
+Provided by Moose
=head1 AUTHORS
# clean up relative path:
# MyApp/script/.. -> MyApp
- my ($lastdir) = $home->dir_list( -1, 1 );
- if ( $lastdir eq '..' ) {
+ my $dir;
+ my @dir_list = $home->dir_list();
+ while (($dir = pop(@dir_list)) && $dir eq '..') {
$home = dir($home)->parent->parent;
}
plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD} || -e 'inc/.author';
-all_pod_coverage_ok();
+all_pod_coverage_ok(
+ {
+ also_private => ['BUILD']
+ }
+);
--- /dev/null
+use Test::More tests=>7;
+
+use strict;
+use warnings;
+
+# simulates an entire testapp rooted at t/something
+# except without bothering creating it since its
+# only the -e check on the Makefile.PL that matters
+
+BEGIN { use_ok 'Catalyst::Utils' }
+use FindBin;
+
+$INC{'TestApp.pm'} = "$FindBin::Bin/something/script/foo/../../lib/TestApp.pm";
+my $home = Catalyst::Utils::home('TestApp');
+like($home, qr/t\/something/, "has path TestApp/t/something");
+unlike($home, qr/\/script\/foo/, "doesn't have path /script/foo");
+
+$INC{'TestApp.pm'} = "$FindBin::Bin/something/script/foo/bar/../../../lib/TestApp.pm";
+$home = Catalyst::Utils::home('TestApp');
+like($home, qr/t\/something/, "has path TestApp/t/something");
+unlike($home, qr/\/script\/foo\/bar/, "doesn't have path /script/foo");
+
+$INC{'TestApp.pm'} = "$FindBin::Bin/something/script/../lib/TestApp.pm";
+$home = Catalyst::Utils::home('TestApp');
+like($home, qr/t\/something/, "has path TestApp/t/something");
+unlike($home, qr/\/script\/foo/, "doesn't have path /script/foo");