# This file documents the revision history for Perl extension Catalyst.
+#
+
+ - Add allow_mutable_ancestors option when force inlining a constructor onto
+ applications with plugins defining their own (usually Class::Accessor::Fast)
+ new methods, to avoid warnings generated by upcoming Moose releases
+ as we can make a class (MyApp) immutable when not all of it's superclasses
+ (e.g. plugins not fully Moose converted, but using
+ MooseX::Emulate::Class::Accessor::Fast) are not immutable.
+
+5.80012 2009-09-09 19:09:09
+
+ Bug fixes:
+ - Fix t/optional_http-server.t test.
+ - Fix t/optional_http-server-restart.t test.
+ - Fix duplicate components being loaded at setup time, each component is
+ now loaded at most once + tests.
+ - Fix backward compatibility - hash key configured actions are stored in
+ is returned to 'actions'.
+ - Fix get_action_methods returning duplicate methods when a method is both
+ decorated with method attributes and set as an action in config.
+
+ Refactoring / cleanups:
+ - Reduce minimum supported perl version from 5.8.6 to 5.8.4 as there are
+ many people still running/testing this version with no known issues.
+
+ Tests:
+ - Make the optional_http_server.t test an author only test which must be
+ run by authors to stop it being broken again.
+ - Fix recursion warnings in the test suites.
+
+5.80011 2009-08-23 13:48:15
+
+ Bug fixes:
+ - Remove leftovers of the restarter engine. The removed code caused test
+ failures, which weren't apparent for anyone still having an old version
+ installed in @INC.
+
+5.80010 2009-08-21 23:32:15
+
+ Bug fixes:
+ - Fix and add tests for a regression introduced by 5.80008.
+ Catalyst::Engine is now able to send out data from filehandles larger
+ than the default chunksize of 64k again.
+
+5.80009 2009-08-21 22:21:08
+
+ Bug fixes:
+ - Fix and add tests for generating inner packages inside the COMPONENT
+ method, and those packages being correctly registered as components.
+ This fixes Catalyst::Model::DBIC among others.
+
+5.80008 2009-08-21 17:47:30
Bug fixes:
- Fix replace_constructor warning to actually work if you make your
in inner packages might not be registered. This especially affected
tests.
- Catalyst::Engine::FastCGI - relax the check for versions of Microsoft
- IIS. Provides compatibility with Windows 2008 R2 as well as
+ IIS. Provides compatibility with Windows 2008 R2 as well as
(hopefully) future versions.
+ - In tests which depend on the values of environment variables,
+ localise the environment, then delete only relevant environment
+ variables (RT#48555)
+ - Fix issue with Engine::HTTP not sending headers properly in some cases
+ (RT#48623)
+ - Make Catalyst::Engine write at least once when finalizing the response
+ body from a filehandle, even if the write is empty. This avoids fail
+ when trying to send out an empty response body from a filehandle.
+ - Catalyst::Engine::HTTP - Accept a fully qualified absolute URI in the
+ Request-URI of the Request-Line
Refactoring / cleanups:
- Deleted the Restarter engine and its Watcher code. Use the
new Catalyst::Restarter in a recent Catalyst::Devel instead.
- - New unit test for Catalyst::Action 'unit_core_action.t' (groditi)
+ - New unit test for Catalyst::Action 'unit_core_action.t'
+ - Bump minimum supported perl version from 5.8.1 to 5.8.6 as there are
+ known issues with 5.8.3.
+ - Debug output uses dynamic column sizing to create more readable output
+ when using a larger $ENV{COLUMNS} setting. (groditi)
New features:
- - private_path method for Catalyst::Action + docs + tests (groditi)
+ - Added private_path method for Catalyst::Action
+ - Allow uri_for($controller_instance) which will produce a URI
+ for the controller namespace
+ - Break setup_components into two more parts: locate_components and
+ expand_component_module (rjbs)
+ - Allow Components to return anon classed from their COMPONENT method
+ correctly, and have action registration work on Controllers returned
+ as such by adding a catalyst_component_name accessor for all components
+ which returns the component instance's name to be used when building
+ actions etc.
+ - Adding X-Forwarded-Port to allow the frontend proxy to dictate the
+ frontend port (jshirley)
+ - Added Catalyst::Stats->created accessor for the time at the start of
+ the request.
Documentation:
- Fix POD to refer to ->config(key => $val), rather than
->config->{key} = $val, as the latter form is deprecated.
- Clearer docs for the 'uri_for' method.
+ - Fix POD refering to CGI::Cookie. We're using CGI::Simple::Cookie.
+ (Forrest Cahoon)
5.80007 2009-06-30 23:54:34
-^(?!script/\w+\.pl$|TODO$|lib/.+(?<!ROADMAP)\.p(m|od)$|inc/|t/aggregate/.*\.t$|t/.*\.(gif|yml|pl|t)$|t/lib/.*\.pm$|t/something/(Makefile.PL|script/foo/bar/for_dist)$|t/conf/extra.conf.in$|Makefile.PL$|README$|MANIFEST$|Changes$|META.yml$)
+^(?!script/\w+\.pl$|TODO$|lib/.+(?<!ROADMAP)\.p(m|od)$|inc/|t/a(uthor|ggregate)/.*\.t$|t/.*\.(gif|yml|pl|t)$|t/lib/.*\.pm$|t/something/(Makefile.PL|script/foo/bar/for_dist)$|t/conf/extra.conf.in$|Makefile.PL$|README$|MANIFEST$|Changes$|META.yml$)
+use strict;
+use warnings;
use inc::Module::Install 0.87;
-
-perl_version '5.008001';
+BEGIN { # Make it easy for newbies
+ if ($Module::Install::AUTHOR) {
+ require Module::Install::AuthorRequires;
+ require Module::Install::CheckConflicts;
+ require Module::Install::AuthorTests;
+ }
+}
+perl_version '5.008004';
name 'Catalyst-Runtime';
all_from 'lib/Catalyst/Runtime.pm';
+requires 'List::MoreUtils';
requires 'namespace::autoclean';
requires 'namespace::clean';
requires 'B::Hooks::EndOfScope' => '0.08';
requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00801';
requires 'Class::MOP' => '0.83';
requires 'Moose' => '0.78';
-requires 'MooseX::MethodAttributes::Inheritable' => '0.14';
+requires 'MooseX::MethodAttributes::Inheritable' => '0.15';
requires 'Carp';
requires 'Class::C3::Adopt::NEXT' => '0.07';
requires 'CGI::Simple::Cookie';
map { glob } qw[t/*.t t/aggregate/*.t];
}
+author_tests 't/author';
author_requires(map {; $_ => 0 } qw(
Test::NoTabs
Test::Pod
'Catalyst::Plugin::Upload::Image::Magick' => '0.03',
'Catalyst::Plugin::ConfigLoader' => '0.22', # Older versions work but
# throw Data::Visitor warns
- 'Catalyst::Devel' => '0.09',
+ 'Catalyst::Devel' => '1.19',
'Catalyst::Plugin::SmartURI' => '0.032',
'CatalystX::CRUD' => '0.37',
'Catalyst::Action::RenderView' => '0.07',
'Catalyst::Action::REST' => '0.67',
'CatalystX::CRUD' => '0.42',
'CatalystX::CRUD::Model::RDBO' => '0.20',
+ 'Catalyst::View::Mason' => '0.17',
);
check_conflicts(%conflicts);
# Compatibility warnings to add:
- $self->config should warn as config should only ever be called as a
- class method.
+ class method (TESTS).
# Proposed functionality / feature additions:
## App / ctx split:
NOTE - these are notes that t0m thought up after doing back compat for
- _component_class, may be inaccurate, wrong or missing things
+ catalyst_component_class, may be inaccurate, wrong or missing things
bug mst (at least) to correct before trying more than the first 2
steps. Please knock yourself out on the first two however :)
- Profit! (Things like changing the complete app config per vhost, i.e.
writing a config loader / app class role which dispatches per vhost to
differently configured apps is piss easy)
-
use Tree::Simple qw/use_weak_refs/;
use Tree::Simple::Visitor::FindByUID;
use Class::C3::Adopt::NEXT;
+use List::MoreUtils qw/uniq/;
use attributes;
use utf8;
use Carp qw/croak carp shortmess/;
-BEGIN { require 5.008001; }
+BEGIN { require 5.008004; }
has stack => (is => 'ro', default => sub { [] });
has stash => (is => 'rw', default => sub { {} });
# Remember to update this in Catalyst::Runtime as well!
-our $VERSION = '5.80007';
+our $VERSION = '5.80012';
{
my $dev_version = $VERSION =~ /_\d{2}$/;
sub model {
my ( $c, $name, @args ) = @_;
-
+ my $appclass = ref($c) || $c;
if( $name ) {
my @result = $c->_comp_search_prefixes( $name, qw/Model M/ );
return map { $c->_filter_component( $_, @args ) } @result if ref $name;
return $c->model( $c->stash->{current_model} )
if $c->stash->{current_model};
}
- return $c->model( $c->config->{default_model} )
- if $c->config->{default_model};
+ return $c->model( $appclass->config->{default_model} )
+ if $appclass->config->{default_model};
my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/Model M/);
sub view {
my ( $c, $name, @args ) = @_;
+ my $appclass = ref($c) || $c;
if( $name ) {
my @result = $c->_comp_search_prefixes( $name, qw/View V/ );
return map { $c->_filter_component( $_, @args ) } @result if ref $name;
return $c->view( $c->stash->{current_view} )
if $c->stash->{current_view};
}
- return $c->view( $c->config->{default_view} )
- if $c->config->{default_view};
+ return $c->view( $appclass->config->{default_view} )
+ if $appclass->config->{default_view};
my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/View V/);
. "Class::Accessor(::Fast)?\nPlease pass "
. "(replace_constructor => 1)\nwhen making your class immutable.\n";
}
- $meta->make_immutable(replace_constructor => 1)
- unless $meta->is_immutable;
+ $meta->make_immutable(
+ replace_constructor => 1,
+ allow_mutable_ancestors => 1,
+ ) unless $meta->is_immutable;
};
$class->setup_finalize;
If the first argument is a string, it is taken as a public URI path relative
to C<< $c->namespace >> (if it doesn't begin with a forward slash) or
-relative to the application root (if it does). It is then merged with
+relative to the application root (if it does). It is then merged with
C<< $c->request->base >>; any C<@args> are appended as additional path
components; and any C<%query_values> are appended as C<?foo=bar> parameters.
provided, appending any arguments or parameters and creating an absolute
URI.
-The captures for the current request can be found in
+The captures for the current request can be found in
C<< $c->request->captures >>, and actions can be resolved using
C<< Catalyst::Controller->action_for($name) >>. If you have a private action
path, use C<< $c->uri_for_action >> instead.
# Equivalent to $c->req->uri
- $c->uri_for($c->action, $c->req->captures,
+ $c->uri_for($c->action, $c->req->captures,
@{ $c->req->args }, $c->req->params);
# For the Foo action in the Bar controller
sub uri_for {
my ( $c, $path, @args ) = @_;
+ if (blessed($path) && $path->isa('Catalyst::Controller')) {
+ $path = $path->path_prefix;
+ $path =~ s{/+\z}{};
+ $path .= '/';
+ }
+
if ( blessed($path) ) { # action object
my $captures = ( scalar @args && ref $args[0] eq 'ARRAY'
? shift(@args)
sub _stats_start_execute {
my ( $c, $code ) = @_;
-
+ my $appclass = ref($c) || $c;
return if ( ( $code->name =~ /^_.*/ )
- && ( !$c->config->{show_internal_actions} ) );
+ && ( !$appclass->config->{show_internal_actions} ) );
my $action_name = $code->reverse();
$c->counter->{$action_name}++;
$c->prepare_read;
# Parse the body unless the user wants it on-demand
- unless ( $c->config->{parse_on_demand} ) {
+ unless ( ref($c)->config->{parse_on_demand} ) {
$c->prepare_body;
}
}
=head2 $c->setup_components
-Sets up components. Specify a C<setup_components> config option to pass
-additional options directly to L<Module::Pluggable>. To add additional
-search paths, specify a key named C<search_extra> as an array
-reference. Items in the array beginning with C<::> will have the
-application class name prepended to them.
+This method is called internally to set up the application's components.
-All components found will also have any
-L<inner packages|Devel::InnerPackage> loaded and set up as components.
-Note, that modules which are B<not> an I<inner package> of the main
-file namespace loaded will not be instantiated as components.
+It finds modules by calling the L<locate_components> method, expands them to
+package names with the L<expand_component_module> method, and then installs
+each component into the application.
+
+The C<setup_components> config option is passed to both of the above methods.
+
+Installation of each component is performed by the L<setup_component> method,
+below.
=cut
sub setup_components {
my $class = shift;
- my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
my $config = $class->config->{ setup_components };
- my $extra = delete $config->{ search_extra } || [];
- push @paths, @$extra;
-
- my $locator = Module::Pluggable::Object->new(
- search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
- %$config
- );
-
- my @comps = sort { length $a <=> length $b } $locator->plugins;
+ my @comps = sort { length $a <=> length $b }
+ $class->locate_components($config);
my %comps = map { $_ => 1 } @comps;
- my $deprecated_component_names = grep { /::[CMV]::/ } @comps;
+ my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps;
$class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}.
qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n}
- ) if $deprecated_component_names;
+ ) if $deprecatedcatalyst_component_names;
for my $component ( @comps ) {
# we know M::P::O found a file on disk so this is safe
Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
- #Class::MOP::load_class($component);
-
- my $module = $class->setup_component( $component );
- my %modules = (
- $component => $module,
- map {
- $_ => $class->setup_component( $_ )
- } grep {
- not exists $comps{$_}
- } Devel::InnerPackage::list_packages( $component )
- );
- for my $key ( keys %modules ) {
- $class->components->{ $key } = $modules{ $key };
+ # Needs to be done as soon as the component is loaded, as loading a sub-component
+ # (next time round the loop) can cause us to get the wrong metaclass..
+ $class->_controller_init_base_classes($component);
+ }
+
+ for my $component (@comps) {
+ $class->components->{ $component } = $class->setup_component($component);
+ for my $component ($class->expand_component_module( $component, $config )) {
+ next if $comps{$component};
+ $class->_controller_init_base_classes($component); # Also cover inner packages
+ $class->components->{ $component } = $class->setup_component($component);
}
}
}
+=head2 $c->locate_components( $setup_component_config )
+
+This method is meant to provide a list of component modules that should be
+setup for the application. By default, it will use L<Module::Pluggable>.
+
+Specify a C<setup_components> config option to pass additional options directly
+to L<Module::Pluggable>. To add additional search paths, specify a key named
+C<search_extra> as an array reference. Items in the array beginning with C<::>
+will have the application class name prepended to them.
+
+=cut
+
+sub locate_components {
+ my $class = shift;
+ my $config = shift;
+
+ my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
+ my $extra = delete $config->{ search_extra } || [];
+
+ push @paths, @$extra;
+
+ my $locator = Module::Pluggable::Object->new(
+ search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
+ %$config
+ );
+
+ my @comps = $locator->plugins;
+
+ return @comps;
+}
+
+=head2 $c->expand_component_module( $component, $setup_component_config )
+
+Components found by C<locate_components> will be passed to this method, which
+is expected to return a list of component (package) names to be set up.
+
+=cut
+
+sub expand_component_module {
+ my ($class, $module) = @_;
+ return Devel::InnerPackage::list_packages( $module );
+}
+
=head2 $c->setup_component
=cut
+# FIXME - Ugly, ugly hack to ensure the we force initialize non-moose base classes
+# nearest to Catalyst::Controller first, no matter what order stuff happens
+# to be loaded. There are TODO tests in Moose for this, see
+# f2391d17574eff81d911b97be15ea51080500003
sub _controller_init_base_classes {
my ($app_class, $component) = @_;
+ return unless $component->isa('Catalyst::Controller');
foreach my $class ( reverse @{ mro::get_linear_isa($component) } ) {
Moose::Meta::Class->initialize( $class )
unless find_meta($class);
return $component;
}
- # FIXME - Ugly, ugly hack to ensure the we force initialize non-moose base classes
- # nearest to Catalyst::Controller first, no matter what order stuff happens
- # to be loaded. There are TODO tests in Moose for this, see
- # f2391d17574eff81d911b97be15ea51080500003
- if ($component->isa('Catalyst::Controller')) {
- $class->_controller_init_base_classes($component);
- }
-
my $suffix = Catalyst::Utils::class2classsuffix( $component );
my $config = $class->config->{ $suffix } || {};
- # Stash _component_name in the config here, so that custom COMPONENT
+ # Stash catalyst_component_name in the config here, so that custom COMPONENT
# methods also pass it. local to avoid pointlessly shitting in config
# for the debug screen, as $component is already the key name.
- local $config->{_component_name} = $component;
+ local $config->{catalyst_component_name} = $component;
my $instance = eval { $component->COMPONENT( $class, $config ); };
The host value for $c->req->base and $c->req->uri is set to the real
host, as read from the HTTP X-Forwarded-Host header.
+Additionally, you may be running your backend application on an insecure
+connection (port 80) while your frontend proxy is running under SSL. If there
+is a discrepancy in the ports, use the HTTP header C<X-Forwarded-Port> to
+tell Catalyst what port the frontend listens on. This will allow all URIs to
+be created properly.
+
+In the case of passing in:
+
+ X-Forwarded-Port: 443
+
+All calls to C<uri_for> will result in an https link, as is expected.
+
Obviously, your web server must support these headers for this to work.
In a more complex server farm environment where you may have your
Andrew Bramble
-Andrew Ford
+Andrew Ford E<lt>A.Ford@ford-mason.co.ukE<gt>
Andrew Ruthven
chicks: Christopher Hicks
+Chisel Wright C<pause@herlpacker.co.uk>
+
+Danijel Milicevic C<me@danijel.de>
+
+David Kamholz E<lt>dkamholz@cpan.orgE<gt>
+
+David Naughton, C<naughton@umn.edu>
+
David E. Wheeler
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
fireartist: Carl Franks <cfranks@cpan.org>
+frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
+
gabb: Danijel Milicevic
Gary Ashton Jones
+Gavin Henry C<ghenry@perl.me.uk>
+
Geoff Richards
+groditi: Guillermo Roditi <groditi@gmail.com>
+
hobbs: Andrew Rodland <andrew@cleverdomain.org>
ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
jcamacho: Juan Camacho
-jester: Jesse Sheidlower
+jester: Jesse Sheidlower C<jester@panix.com>
jhannah: Jay Hannah <jay@jays.net>
jon: Jon Schutz <jjschutz@cpan.org>
+Jonathan Rockway C<< <jrockway@cpan.org> >>
+
+Kieren Diment C<kd@totaldatasolution.com>
+
konobi: Scott McWhirter <konobi@cpan.org>
marcus: Marcus Ramberg <mramberg@cpan.org>
random: Roland Lammel <lammel@cpan.org>
+Robert Sedlacek C<< <rs@474.at> >>
+
sky: Arthur Bergman
t0m: Tomas Doran <bobtfish@bobtfish.net>
Ulf Edvinsson
+Viljo Marrandi C<vilts@yahoo.com>
+
+Will Hawes C<info@whawes.co.uk>
+
willert: Sebastian Willert <willert@cpan.org>
+Yuval Kogman, C<nothingmuch@woobling.org>
+
=head1 LICENSE
This library is free software. You can redistribute it and/or modify it under
=head2 class
Returns the name of the component where this action is defined.
-Derived by calling the L<Catalyst::Component/_component_name|_component_name>
+Derived by calling the L<Catalyst::Component/catalyst_component_name|catalyst_component_name>
method on each component.
=head2 code
use Moose::Util ();
sub mk_classdata {
- my ($class, $attribute) = @_;
+ my ($class, $attribute, $warn_on_instance) = @_;
confess("mk_classdata() is a class method, not an object method")
if blessed $class;
__PACKAGE__->mk_classdata('_plugins');
__PACKAGE__->mk_classdata('_config');
-has _component_name => ( is => 'ro' ); # Cannot be required => 1 as context
+has catalyst_component_name => ( is => 'ro' ); # Cannot be required => 1 as context
# class @ISA component - HATE
# Make accessor callable as a class method, as we need to call setup_actions
# on the application class, which we don't have an instance of, ewwwww
-around _component_name => sub {
+# Also, naughty modules like Catalyst::View::JSON try to write to _everything_,
+# so spit a warning, ignore that (and try to do the right thing anyway) here..
+around catalyst_component_name => sub {
my ($orig, $self) = (shift, shift);
- blessed($self) ? $self->$orig(@_) : $self;
+ Carp::cluck("Tried to write to the catalyst_component_name accessor - is your component broken or just mad? (Write ignored - using default value.)") if scalar @_;
+ blessed($self) ? $self->$orig() || blessed($self) : $self;
};
sub BUILDARGS {
sub config {
my $self = shift;
+ # Uncomment once sane to do so
+ #Carp::cluck("config method called on instance") if ref $self;
my $config = $self->_config || {};
if (@_) {
my $newconfig = { %{@_ > 1 ? {@_} : $_[0]} };
use Moose;
use Moose::Util qw/find_meta/;
-
+use List::MoreUtils qw/uniq/;
use namespace::clean -except => 'meta';
BEGIN { extends qw/Catalyst::Component MooseX::MethodAttributes::Inheritable/; }
predicate => 'has_action_namespace',
);
-has _controller_actions =>
+has actions =>
(
- is => 'rw',
+ accessor => '_controller_actions',
isa => 'HashRef',
init_arg => undef,
);
$self->_controller_actions($attr_value);
}
+
+
=head1 NAME
Catalyst::Controller - Catalyst Controller base class
my $orig = shift;
my ( $self, $c ) = @_;
+ my $class = ref($self) || $self;
+ my $appclass = ref($c) || $c;
if( ref($self) ){
return $self->$orig if $self->has_action_namespace;
} else {
- return $self->config->{namespace} if exists $self->config->{namespace};
+ return $class->config->{namespace} if exists $class->config->{namespace};
}
my $case_s;
if( $c ){
- $case_s = $c->config->{case_sensitive};
+ $case_s = $appclass->config->{case_sensitive};
} else {
if ($self->isa('Catalyst')) {
- $case_s = $self->config->{case_sensitive};
+ $case_s = $class->config->{case_sensitive};
} else {
if (ref $self) {
- $case_s = $self->_application->config->{case_sensitive};
+ $case_s = ref($self->_application)->config->{case_sensitive};
} else {
confess("Can't figure out case_sensitive setting");
}
}
}
- my $namespace = Catalyst::Utils::class2prefix($self->_component_name, $case_s) || '';
+ my $namespace = Catalyst::Utils::class2prefix($self->catalyst_component_name, $case_s) || '';
$self->$orig($namespace) if ref($self);
return $namespace;
};
sub get_action_methods {
my $self = shift;
- my $meta = find_meta($self);
- confess("Metaclass for "
+ my $meta = find_meta($self) || confess("No metaclass setup for $self");
+ confess("Metaclass "
. ref($meta) . " for "
. $meta->name
. " cannot support register_actions." )
. ( ref $self ) )
} keys %{ $self->_controller_actions }
) if ( ref $self );
- return @methods;
+ return uniq @methods;
}
sub register_action_methods {
my ( $self, $c, @methods ) = @_;
- my $class = $self->_component_name;
+ my $class = $self->catalyst_component_name;
#this is still not correct for some reason.
my $namespace = $self->action_namespace($c);
return unless $self->_endpoints;
- my $column_width = Catalyst::Utils::term_width() - 35 - 9;
+ my $avail_width = Catalyst::Utils::term_width() - 9;
+ my $col1_width = ($avail_width * .50) < 35 ? 35 : int($avail_width * .50);
+ my $col2_width = $avail_width - $col1_width;
my $paths = Text::SimpleTable->new(
- [ 35, 'Path Spec' ], [ $column_width, 'Private' ],
+ [ $col1_width, 'Path Spec' ], [ $col2_width, 'Private' ],
);
my $has_unattached_actions;
my $unattached_actions = Text::SimpleTable->new(
- [ 35, 'Private' ], [ $column_width, 'Missing parent' ],
+ [ $col1_width, 'Private' ], [ $col2_width, 'Missing parent' ],
);
ENDPOINT: foreach my $endpoint (
sub list {
my ( $self, $c ) = @_;
- my $column_width = Catalyst::Utils::term_width() - 35 - 9;
+ my $avail_width = Catalyst::Utils::term_width() - 9;
+ my $col1_width = ($avail_width * .50) < 35 ? 35 : int($avail_width * .50);
+ my $col2_width = $avail_width - $col1_width;
my $paths = Text::SimpleTable->new(
- [ 35, 'Path' ], [ $column_width, 'Private' ]
+ [ $col1_width, 'Path' ], [ $col2_width, 'Private' ]
);
foreach my $path ( sort keys %{ $self->_paths } ) {
my $display_path = $path eq '/' ? $path : "/$path";
sub list {
my ( $self, $c ) = @_;
- my $column_width = Catalyst::Utils::term_width() - 35 - 9;
- my $re = Text::SimpleTable->new( [ 35, 'Regex' ], [ $column_width, 'Private' ] );
+ my $avail_width = Catalyst::Utils::term_width() - 9;
+ my $col1_width = ($avail_width * .50) < 35 ? 35 : int($avail_width * .50);
+ my $col2_width = $avail_width - $col1_width;
+ my $re = Text::SimpleTable->new(
+ [ $col1_width, 'Regex' ], [ $col2_width, 'Private' ]
+ );
for my $regex ( @{ $self->_compiled } ) {
my $action = $regex->{action};
$re->row( $regex->{path}, "/$action" );
reverse => "$component_class->$method",
class => $component_class,
namespace => Catalyst::Utils::class2prefix(
- $component_class, $c->config->{case_sensitive}
+ $component_class, ref($c)->config->{case_sensitive}
),
}
);
sub _display_action_tables {
my ($self, $c) = @_;
- my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
+ my $avail_width = Catalyst::Utils::term_width() - 12;
+ my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25);
+ my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50);
+ my $col3_width = $avail_width - $col1_width - $col2_width;
my $privates = Text::SimpleTable->new(
- [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, 'Method' ]
+ [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ]
);
my $has_private = 0;
my $body = $c->response->body;
no warnings 'uninitialized';
if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
- while ( !eof $body ) {
- read $body, my ($buffer), $CHUNKSIZE;
- last unless $self->write( $c, $buffer );
- }
+ my $got;
+ do {
+ $got = read $body, my ($buffer), $CHUNKSIZE;
+ $got = 0 unless $self->write( $c, $buffer );
+ } while $got > 0;
+
close $body;
}
else {
my ( $self, $c ) = @_;
$c->res->content_type('text/html; charset=utf-8');
- my $name = $c->config->{name} || join(' ', split('::', ref $c));
+ my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
my ( $title, $error, $infos );
if ( $c->debug ) {
sub prepare_body {
my ( $self, $c ) = @_;
+ my $appclass = ref($c) || $c;
if ( my $length = $self->read_length ) {
my $request = $c->request;
unless ( $request->_body ) {
my $type = $request->header('Content-Type');
$request->_body(HTTP::Body->new( $type, $length ));
- $request->_body->tmpdir( $c->config->{uploadtmp} )
- if exists $c->config->{uploadtmp};
+ $request->_body->tmpdir( $appclass->config->{uploadtmp} )
+ if exists $appclass->config->{uploadtmp};
}
while ( my $buffer = $self->read($c) ) {
PROXY_CHECK:
{
- unless ( $c->config->{using_frontend_proxy} ) {
+ unless ( ref($c)->config->{using_frontend_proxy} ) {
last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
- last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
+ last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
}
last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
# as 127.0.0.1. Select the most recent upstream IP (last in the list)
my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/;
$request->address($ip);
+ if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) {
+ $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT};
+ }
}
$request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST};
# If we are running as a backend proxy, get the true hostname
PROXY_CHECK:
{
- unless ( $c->config->{using_frontend_proxy} ) {
+ unless ( ref($c)->config->{using_frontend_proxy} ) {
last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
- last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
+ last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
}
last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
# backend could be on any port, so
# assume frontend is on the default port
$port = $c->request->secure ? 443 : 80;
+ if ( $ENV{HTTP_X_FORWARDED_PORT} ) {
+ $port = $ENV{HTTP_X_FORWARDED_PORT};
+ }
}
# set the request URI
use IO::Socket::INET ();
use IO::Select ();
-# For PAR
-require Catalyst::Engine::HTTP::Restarter;
-require Catalyst::Engine::HTTP::Restarter::Watcher;
-
use constant CHUNKSIZE => 64 * 1024;
use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0;
# Prepend the headers if they have not yet been sent
if ( $self->_has_header_buf ) {
$self->_warn_on_write_error(
- $self->$orig($self->_clear_header_buf)
+ $self->$orig($c, $self->_clear_header_buf)
);
}
while (1) {
my ( $path, $query_string ) = split /\?/, $uri, 2;
+ # URI is not the same as path. Remove scheme, domain name and port from it
+ $path =~ s{^https?://[^/?#]+}{};
+
# Initialize CGI environment
local %ENV = (
PATH_INFO => $path || '',
=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>.
+Returns the message body of the request, as returned by L<HTTP::Body>: a string,
+unless Content-Type is C<application/x-www-form-urlencoded>, C<text/xml>, or
+C<multipart/form-data>, in which case a L<File::Temp> object is returned.
=head2 $req->body_parameters
print $c->request->cookies->{mycookie}->value;
-The cookies in the hash are indexed by name, and the values are L<CGI::Cookie>
+The cookies in the hash are indexed by name, and the values are L<CGI::Simple::Cookie>
objects.
=head2 $req->header
Returns a reference to a hash containing cookies to be set. The keys of the
hash are the cookies' names, and their corresponding values are hash
-references used to construct a L<CGI::Cookie> object.
+references used to construct a L<CGI::Simple::Cookie> object.
$c->response->cookies->{foo} = { value => '123' };
-The keys of the hash reference on the right correspond to the L<CGI::Cookie>
+The keys of the hash reference on the right correspond to the L<CGI::Simple::Cookie>
parameters of the same name, except they are used without a leading dash.
Possible parameters are:
use strict;
use warnings;
-BEGIN { require 5.008001; }
+BEGIN { require 5.008004; }
# Remember to update this in Catalyst as well!
-our $VERSION='5.80007';
+our $VERSION='5.80012';
$VERSION = eval $VERSION;
return $node->getUID;
}
+sub created {
+ return @{ shift->{tree}->getNodeValue->{t} };
+}
+
sub elapsed {
return tv_interval(shift->{tree}->getNodeValue->{t});
}
Returns the UID of the current point in the profile tree. The UID is
automatically assigned if not explicitly given.
+=head2 created
+
+ ($seconds, $microseconds) = $stats->created;
+
+Returns the time the object was created, in C<gettimeofday> format, with
+Unix epoch seconds followed by microseconds.
+
=head2 elapsed
$elapsed = $stats->elapsed
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 6*$iters;
-
+use Test::More;
use Catalyst::Test 'TestAppIndexDefault';
+plan 'skip_all' if ( $ENV{CATALYST_SERVER} );
+
+plan tests => 6*$iters;
+
if ( $ENV{CAT_BENCHMARK} ) {
require Benchmark;
Benchmark::timethis( $iters, \&run_tests );
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 3*$iters;
+use Test::More;
use Catalyst::Test 'TestAppMatchSingleArg';
+plan 'skip_all' if ( $ENV{CATALYST_SERVER} );
+
+plan tests => 3*$iters;
+
if ( $ENV{CAT_BENCHMARK} ) {
require Benchmark;
Benchmark::timethis( $iters, \&run_tests );
'TestApp::Controller::Action::Regexp',
'Test Class'
);
+ my $location = $response->header('location');
+ $location =~ s/localhost(:\d+)?/localhost/;
is(
- $response->header('location'),
+ $location,
$url,
'Redirect URI is the same as the request URI'
);
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 10*$iters;
+use Test::More tests => 15*$iters;
use Catalyst::Test 'TestApp';
if ( $ENV{CAT_BENCHMARK} ) {
is( $response->content_length, -s $file, 'Response Content-Length' );
is( $response->content, $buffer, 'Content is read from filehandle' );
}
+
+ {
+ my $size = 128 * 1024; # more than one read with the default chunksize
+
+ ok( my $response = request('http://localhost/action/streaming/body_large'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content_length, $size, 'Response Content-Length' );
+ is( $response->content, "\0" x $size, 'Content is read from filehandle' );
+ }
}
my $response = request('http://localhost/anon/test');
ok($response->is_success);
is($response->header('X-Component-Name-Action'),
- 'TestApp::Controller::Anon', 'Action can see correct _component_name');
+ 'TestApp::Controller::Anon', 'Action can see correct catalyst_component_name');
isnt($response->header('X-Component-Instance-Name-Action'),
- 'TestApp::Controller::Anon', 'ref($controller) ne _component_name');
+ 'TestApp::Controller::Anon', 'ref($controller) ne catalyst_component_name');
is($response->header('X-Component-Name-Controller'),
- 'TestApp::Controller::Anon', 'Controller can see correct _component_name');
+ 'TestApp::Controller::Anon', 'Controller can see correct catalyst_component_name');
is($response->header('X-Class-In-Action'),
- 'TestApp::Controller::Anon', '$action->class is _component_name');
+ 'TestApp::Controller::Anon', '$action->class is catalyst_component_name');
is($response->header('X-Anon-Trait-Applied'),
'1', 'Anon controller class has trait applied correctly');
}
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 3*$iters;
+use Test::More;
use Catalyst::Test 'TestAppOneView';
+plan 'skip_all' if ( $ENV{CATALYST_SERVER} );
+
+plan tests => 3*$iters;
+
if ( $ENV{CAT_BENCHMARK} ) {
require Benchmark;
Benchmark::timethis( $iters, \&run_tests );
}
# test that request with URL-escaped code works.
-TODO: {
- local $TODO = 'Actions should match when path parts are url encoded';
my $request = Catalyst::Utils::request( 'http://localhost/args/param%73/one/two' );
my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
TestApp->handle_request( env => \%ENV );
ok( my $response = $cgi->restore->response );
+TODO: {
+ local $TODO = 'Actions should match when path parts are url encoded';
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content, 'onetwo' );
}
use FindBin;
use lib "$FindBin::Bin/../lib";
-use Test::More tests => 17;
+use Test::More tests => 18;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
'X-Multiple' => [ 1 .. 5 ],
'X-Forwarded-Host' => 'frontend.server.com',
'X-Forwarded-For' => '192.168.1.1, 1.2.3.4',
+ 'X-Forwarded-Port' => 443
);
ok( my $response = request($request), 'Request' );
like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
isa_ok( $creq, 'Catalyst::Request' );
+ ok( $creq->secure, 'Forwarded port sets securet' );
isa_ok( $creq->headers, 'HTTP::Headers', 'Catalyst::Request->headers' );
is( $creq->header('X-Whats-Cool'), $request->header('X-Whats-Cool'), 'Catalyst::Request->header X-Whats-Cool' );
}
isa_ok( $creq, 'Catalyst::Request' );
-
- is( $creq->remote_user, 'dwc', '$c->req->remote_user ok' );
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 1;
+ }
+ is( $creq->remote_user, 'dwc', '$c->req->remote_user ok' );
+ }
}
use Test::More;
-plan tests => 29;
+plan tests => 30;
use_ok('TestApp');
namespace => 'yada',
} );
+is($context->uri_for($context->controller('Action')),
+ "http://127.0.0.1/foo/yada/action/",
+ "uri_for a controller");
+
is($context->uri_for($path_action),
"http://127.0.0.1/foo/action/relative/relative",
"uri_for correct for path action");
use strict;
use warnings;
-use Test::More;
-BEGIN {
- plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
-}
+use Test::More tests => 1;
use File::Path;
use FindBin;
use IPC::Open3;
use IO::Socket;
-eval "use Catalyst::Devel 1.0";
-plan skip_all => 'Catalyst::Devel required' if $@;
-eval "use File::Copy::Recursive";
-plan skip_all => 'File::Copy::Recursive required' if $@;
-plan tests => 1;
+use Catalyst::Devel 1.0;
+use File::Copy::Recursive;
# Run a single test by providing it as the first arg
my $single_test = shift;
-my $tmpdir = "$FindBin::Bin/../t/tmp";
+my $tmpdir = "$FindBin::Bin/../../t/tmp";
# clean up
rmtree $tmpdir if -d $tmpdir;
# create a TestApp and copy the test libs into it
mkdir $tmpdir;
chdir $tmpdir;
-system( $^X, "-I$FindBin::Bin/../lib", "$FindBin::Bin/../script/catalyst.pl", 'TestApp' );
+system( $^X, "-I$FindBin::Bin/../../lib", "$FindBin::Bin/../../script/catalyst.pl", 'TestApp' );
chdir "$FindBin::Bin/..";
-File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+File::Copy::Recursive::dircopy( '../t/lib', '../t/tmp/TestApp/lib' ) or die;
# remove TestApp's tests
-rmtree 't/tmp/TestApp/t';
+rmtree '../t/tmp/TestApp/t' or die;
# spawn the standalone HTTP server
my $port = 30000 + int rand(1 + 10000);
-my $pid = open3( undef, my $server, undef,
- $^X, "-I$FindBin::Bin/../lib",
- "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', $port )
+my @cmd = ($^X, "-I$FindBin::Bin/../../lib",
+ "$FindBin::Bin/../../t/tmp/TestApp/script/testapp_server.pl", '-port', $port );
+my $pid = open3( undef, my $server, undef, @cmd)
or die "Unable to spawn standalone HTTP server: $!";
# wait for it to start
print "Waiting for server to start...\n";
+my $timeout = 30;
+my $count = 0;
while ( check_port( 'localhost', $port ) != 1 ) {
sleep 1;
+ die("Server did not start within $timeout seconds: " . join(' ', @cmd))
+ if $count++ > $timeout;
}
# run the testsuite against the HTTP server
my $return;
if ( $single_test ) {
- $return = system( "$^X -Ilib/ $single_test" );
+ $return = system( "$^X -I../lib/ $single_test" );
}
else {
- $return = prove( '-r', '-Ilib/', glob('t/aggregate/live_*.t') );
+ $return = prove( '-r', '-I../lib/', glob('../t/aggregate/live_*.t') );
}
# shut it down
close $server;
# clean up
-rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp";
is( $return, 0, 'live tests' );
Catalyst::Component
Catalyst::Dispatcher
Catalyst::DispatchType
- Catalyst::Engine::HTTP::Restarter::Watcher
Catalyst::Engine
Catalyst::Log
Catalyst::Request::Upload
+++ /dev/null
-use strict;
-use warnings;
-use lib 't/lib';
-
-use Test::More tests => 2;
-use Test::Exception;
-
-# Force a stack trace.
-use Carp;
-$SIG{__DIE__} = \&Carp::confess;
-
-{
- package CDICompatTestApp;
- use Catalyst qw/
- +CDICompatTestPlugin
- /;
- # Calling ->config here (before we call setup). With CDI/Cat 5.70 this
- # causes *CDICompatTestApp::_config to have a class data accessor created.
-
- # If this doesn't happen, then later when we've added CDICompatTestPlugin
- # to @ISA, we fail in the overridden ->setup method when we call ->config
- # again, as we get the CAF accessor from CDICompatTestPlugin, not the one
- # created in this package as a side-effect of this call. :-(
- __PACKAGE__->config;
-}
-
-SKIP: {
- skip 'Not trying to replicate the nasty CDI hackness', 2;
- lives_ok {
- CDICompatTestApp->setup;
- } 'Setup app with plugins which says use base qw/Class::Accessor::Fast/';
-
- # And the plugin's setup_finished method should have been run, as accessors
- # are not created in MyApp until the data is written to.
- {
- no warnings 'once';
- is $CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED, 1, 'Plugin setup_finish run';
- }
-}
\ No newline at end of file
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use FindBin qw/$Bin/;
+use lib "$Bin/lib";
+use Test::More tests => 1;
+use Test::Exception;
+
+TODO: {
+ local $TODO = 'Does not work yet';
+
+lives_ok {
+ require TestAppClassExceptionSimpleTest;
+} 'Can load application';
+
+}
+
BEGIN {
my $logger = Class::MOP::Class->create_anon_class(
methods => {
+ debug => sub {0},
+ info => sub {0},
warn => sub {
if ($_[1] =~ /switch your class names/) {
$mvc_warnings++;
@executed
);
}
-
+ no warnings 'recursion';
return $c->SUPER::execute(@_);
}
my $self = shift;
my ( $controller, $c, $test ) = @_;
$c->res->header( 'X-TestAppActionTestMyAction', 'MyAction works' );
- $c->res->header( 'X-Component-Name-Action', $controller->_component_name);
+ $c->res->header( 'X-Component-Name-Action', $controller->catalyst_component_name);
$c->res->header( 'X-Component-Instance-Name-Action', ref($controller));
$c->res->header( 'X-Class-In-Action', $self->class);
$self->next::method(@_);
sub body : Local {
my ( $self, $c ) = @_;
-
+
my $file = "$FindBin::Bin/../lib/TestApp/Controller/Action/Streaming.pm";
my $fh = IO::File->new( $file, 'r' );
if ( defined $fh ) {
}
}
+sub body_large : Local {
+ my ($self, $c) = @_;
+
+ # more than one write with the default chunksize
+ my $size = 128 * 1024;
+
+ my $data = "\0" x $size;
+ open my $fh, '<', \$data;
+ $c->res->content_length($size);
+ $c->res->body($fh);
+}
+
1;
sub test : Local ActionClass('+TestApp::Action::TestMyAction') {
my ($self, $c) = @_;
- $c->res->header('X-Component-Name-Controller', $self->_component_name);
+ $c->res->header('X-Component-Name-Controller', $self->catalyst_component_name);
$c->res->body('It works');
}
--- /dev/null
+package TestAppClassExceptionSimpleTest::Exception;
+use strict;
+use warnings;
+
+sub throw {}
+
+#########
+
+package TestAppClassExceptionSimpleTest;
+use strict;
+use warnings;
+
+BEGIN { $Catalyst::Exception::CATALYST_EXCEPTION_CLASS = 'TestAppClassExceptionSimpleTest::Exception'; }
+
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
--- /dev/null
+package TestAppNonMooseController;
+use base qw/Catalyst/;
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
+
--- /dev/null
+package TestAppNonMooseController::Controller::Foo;
+use base qw/TestAppNonMooseController::ControllerBase/;
+
+1;
+
--- /dev/null
+package TestAppNonMooseController::ControllerBase;
+use base qw/Catalyst::Controller/;
+
+1;
+
my $port = 30000 + int rand( 1 + 10000 );
my( $server, $pid );
-$pid = open3( undef, $server, undef,
- $^X, "-I$FindBin::Bin/../lib",
+my @cmd = ($^X, "-I$FindBin::Bin/../lib", "-I$FindBin::Bin/lib",
"$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port',
- $port, '-restart' )
+ $port, '-restart');
+
+$pid = open3( undef, $server, undef, @cmd )
or die "Unable to spawn standalone HTTP server: $!";
# switch to non-blocking reads so we can fail
"$FindBin::Bin/../t/tmp/TestApp/lib/TestApp.pm",
"$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Action/Begin.pm",
"$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable.pm",
+ "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable/HardToReload.pm",
);
-push(@files, "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable/HardToReload.pm")
- if Catalyst::Engine::HTTP::Restarter::Watcher::DETECT_PACKAGE_COMPILATION();
-
# change some files and make sure the server restarts itself
NON_ERROR_RESTART:
for ( 1 .. 20 ) {
# give the server time to notice the change and restart
my $count = 0;
my $line;
-
while ( ( $line || '' ) !~ /can connect/ ) {
# wait for restart message
$line = $server->getline;
--- /dev/null
+use strict;
+use warnings;
+use Test::More tests => 4;
+
+use Catalyst ();
+{
+ package TestController;
+ use Moose;
+ BEGIN { extends 'Catalyst::Controller' }
+
+ sub action : Local {}
+
+ sub foo : Path {}
+
+ no Moose;
+}
+
+my $mock_app = Class::MOP::Class->create_anon_class( superclasses => ['Catalyst'] );
+my $app = $mock_app->name->new;
+my $controller = TestController->new($app, {actions => { foo => { Path => '/some/path' }}});
+
+ok $controller->can('_controller_actions');
+is_deeply $controller->_controller_actions => { foo => { Path => '/some/path' }};
+is_deeply $controller->{actions} => { foo => { Path => '/some/path' }}; # Back compat.
+is_deeply [ sort grep { ! /^_/ } map { $_->name } $controller->get_action_methods ], [sort qw/action foo/];
+
is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref3));
is(refaddr(ClassDataTest->_coderef), refaddr($coderef3));
is(ClassDataTest->_scalar, $scalar3);
+
+my $i = bless {}, 'ClassDataTest';
+$i->_scalar('foo');
+
# (do not forget to update the number of components in test 3 as well)
# 5 extra tests for the loading options
# One test for components in inner packages
-use Test::More tests => 2 + 6 * 24 + 5 + 1;
+use Test::More tests => 2 + 6 * 24 + 8 + 1;
use strict;
use warnings;
my \$self = shift->next::method(\@_);
no strict 'refs';
*{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };
+ *${appclass}::Model::TopLevel::GENERATED::ACCEPT_CONTEXT = sub {
+ return bless {}, 'FooBarBazQuux';
+ };
\$self;
}
package ${appclass}::Model::TopLevel::Nested;
use base 'Catalyst::Model';
+my \$called=0;
no warnings 'redefine';
-sub COMPONENT { return shift->next::method(\@_); }
+sub COMPONENT { \$called++;return shift->next::method(\@_); }
+sub called { return \$called };
1;
EOF
eval "package $appclass; use Catalyst; __PACKAGE__->setup";
is($@, '', "Didn't load component twice");
+is($appclass->model('TopLevel::Nested')->called,1, 'COMPONENT called once');
+
+ok($appclass->model('TopLevel::Generated'), 'Have generated model');
+is(ref($appclass->model('TopLevel::Generated')), 'FooBarBazQuux',
+ 'ACCEPT_CONTEXT in generated inner package fired as expected');
$appclass = "InnerComponent";
use PluginTestApp;
my $logger = Class::MOP::Class->create_anon_class(
methods => {
+ error => sub {0},
+ debug => sub {0},
+ info => sub {0},
warn => sub {
if ($_[1] =~ /plugin method is deprecated/) {
$warnings++;
# for Catalyst 5.9
ok( get("/run_time_plugins"), "get ok" );
+local $ENV{CATALYST_DEBUG} = 0;
+
is( $warnings, 1, '1 warning' );
use_ok 'TestApp';
# Faux::Plugin is no longer reported
is_deeply [ TestApp->registered_plugins ], \@expected,
'registered_plugins() should only report the plugins for the current class';
+
return $name;
}
-local %ENV; # Don't allow env variables to mess us up.
+local %ENV = %ENV;
+
+# Remove all relevant env variables to avoid accidental fail
+foreach my $name (grep { /^(CATALYST|TESTAPP)/ } keys %ENV) {
+ delete $ENV{$name};
+}
{
- my $app = build_test_app_with_setup('MyTestDebug', '-Debug');
+ my $app = build_test_app_with_setup('TestAppMyTestDebug', '-Debug');
- ok my $c = MyTestDebug->new, 'Get debug app object';
+ ok my $c = $app->new, 'Get debug app object';
ok my $log = $c->log, 'Get log object';
isa_ok $log, 'Catalyst::Log', 'It should be a Catalyst::Log object';
ok $log->is_warn, 'Warnings should be enabled';
}
{
- my $app = build_test_app_with_setup('MyTestLogParam', '-Log=warn,error,fatal');
+ my $app = build_test_app_with_setup('TestAppMyTestLogParam', '-Log=warn,error,fatal');
ok my $c = $app->new, 'Get log app object';
ok my $log = $c->log, 'Get log object';
ok !$c->debug, 'Catalyst debugging is off';
}
{
- my $app = build_test_app_with_setup('MyTestNoParams');
+ my $app = build_test_app_with_setup('TestAppMyTestNoParams');
ok my $c = $app->new, 'Get log app object';
ok my $log = $c->log, 'Get log object';
methods => { map { $_ => sub { 0 } } qw/debug error fatal info warn/ },
);
{
- package MyTestAppWithOwnLogger;
+ package TestAppWithOwnLogger;
use base qw/Catalyst/;
__PACKAGE__->log($log_meta->new_object);
__PACKAGE__->setup('-Debug');
}
-ok my $c = MyTestAppWithOwnLogger->new, 'Get with own logger app object';
+ok my $c = TestAppWithOwnLogger->new, 'Get with own logger app object';
ok $c->debug, '$c->debug is true';
}
}
-local %ENV; # Ensure blank or someone, somewhere will fail..
+local %ENV = %ENV;
+
+# Remove all relevant env variables to avoid accidental fail
+foreach my $name (grep { /^(CATALYST|TESTAPP)/ } keys %ENV) {
+ delete $ENV{$name};
+}
{
- my $app = mock_app('TestLogAppParseLevels');
+ my $app = mock_app('TestAppParseLogLevels');
$app->setup_log('error,warn');
ok !$app->debug, 'Not in debug mode';
test_log_object($app->log,
);
}
{
- local %ENV = ( CATALYST_DEBUG => 1 );
- my $app = mock_app('TestLogAppDebugEnvSet');
+ local %ENV = %ENV;
+ $ENV{CATALYST_DEBUG} = 1;
+ my $app = mock_app('TestAppLogDebugEnvSet');
$app->setup_log('');
ok $app->debug, 'In debug mode';
test_log_object($app->log,
);
}
{
- local %ENV = ( CATALYST_DEBUG => 0 );
- my $app = mock_app('TestLogAppDebugEnvUnset');
+ local %ENV = %ENV;
+ $ENV{CATALYST_DEBUG} = 0;
+ my $app = mock_app('TestAppLogDebugEnvUnset');
$app->setup_log('warn');
ok !$app->debug, 'Not In debug mode';
test_log_object($app->log,
);
}
{
- my $app = mock_app('TestLogAppEmptyString');
+ my $app = mock_app('TestAppLogEmptyString');
$app->setup_log('');
ok !$app->debug, 'Not In debug mode';
# Note that by default, you get _all_ the log levels turned on
);
}
{
- my $app = mock_app('TestLogAppDebugOnly');
+ my $app = mock_app('TestAppLogDebugOnly');
$app->setup_log('debug');
ok $app->debug, 'In debug mode';
test_log_object($app->log,
sub mock_app {
my $name = shift;
%log_messages = (); # Flatten log messages.
- print "Setting up mock application: $name\n";
my $meta = Moose->init_meta( for_class => $name );
$meta->superclasses('Catalyst');
$meta->add_method('log', sub { $mock_log });
return $meta->name;
}
-local %ENV; # Ensure blank or someone, somewhere will fail..
+local %ENV = %ENV;
+
+# Remove all relevant env variables to avoid accidental fail
+foreach my $name (grep { /^(CATALYST|TESTAPP)/ } keys %ENV) {
+ delete $ENV{$name};
+}
{
- my $app = mock_app('TestNoStats');
+ my $app = mock_app('TestAppNoStats');
$app->setup_stats();
ok !$app->use_stats, 'stats off by default';
}
{
- my $app = mock_app('TestStats');
+ my $app = mock_app('TestAppStats');
$app->setup_stats(1);
ok $app->use_stats, 'stats on if you say >setup_stats(1)';
}
{
- my $app = mock_app('TestStatsDebugTurnsStatsOn');
+ my $app = mock_app('TestAppStatsDebugTurnsStatsOn');
$app->meta->add_method('debug' => sub { 1 });
$app->setup_stats();
ok $app->use_stats, 'debug on turns stats on';
}
{
- local %ENV = ( CATALYST_STATS => 1 );
- my $app = mock_app('TestStatsAppStatsEnvSet');
+ local %ENV = %ENV;
+ $ENV{CATALYST_STATS} = 1;
+ my $app = mock_app('TestAppStatsEnvSet');
$app->setup_stats();
ok $app->use_stats, 'ENV turns stats on';
}
{
- local %ENV = ( CATALYST_STATS => 0 );
- my $app = mock_app('TestStatsAppStatsEnvUnset');
+ local %ENV = %ENV;
+ $ENV{CATALYST_STATS} = 0;
+ my $app = mock_app('TestAppStatsEnvUnset');
$app->meta->add_method('debug' => sub { 1 });
$app->setup_stats(1);
ok !$app->use_stats, 'ENV turns stats off, even when debug on and ->setup_stats(1)';
-use Catalyst ();
+use strict;
+use warnings;
-{
- package TestApp;
- use base qw/Catalyst/;
-}
-{
- package TestApp::Controller::Base;
- use base qw/Catalyst::Controller/;
-}
-{
- package TestApp::Controller::Other;
- use base qw/TestApp::Controller::Base/;
-}
-
-TestApp->setup_component('TestApp::Controller::Other');
-TestApp->setup_component('TestApp::Controller::Base');
+use FindBin;
+use lib "$FindBin::Bin/lib";
use Test::More tests => 1;
use Test::Exception;
+use TestAppNonMooseController;
# Metaclass init order causes fail.
# There are TODO tests in Moose for this, see
# after which the evil kludge in core can die in a fire.
lives_ok {
- TestApp::Controller::Base->get_action_methods
+ TestAppNonMooseController::ControllerBase->get_action_methods
} 'Base class->get_action_methods ok when sub class initialized first';
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 13;
use Time::HiRes qw/gettimeofday/;
use Tree::Simple;
my $stats = Catalyst::Stats->new;
is (ref($stats), "Catalyst::Stats", "new");
+ is_deeply([ $stats->created ], [0, 0], "created time");
+
my @expected; # level, string, time
$fudge_t[0] = 1;
projects / catagits/Catalyst-Runtime.git / commitdiff