# This file documents the revision history for Perl extension Catalyst.
-5.71000_01 UNRELEASED
- - Add failing test for passing arguments to visited chained
- actions (Radoslaw Zielinski)
- - Support Moose components so that attribute defaults work
- and BUILD methods are correctly called (t0m)
- - Add tests for this (Florian Ragwitz)
-
-5.71000 2009-01-19 17:50:00
+ - Add Catalyst::Test::crequest to return both HTTP::Response object
+ & $c for local requests (kane)
+ - debug() POD rewrite (jhannah)
+ - Change the warning when you have conflicting components to
+ present a list (t0m)
+ - Move NEXT use and testing deprecated features out to its own
+ test application so that the main TestApp isn't polluted with
+ spurious warnings (t0m)
+ - Add a warning for the old ::[MVC]:: style naming scheme (t0m)
+ - Test for this (t0m)
+ - Kill Class::C3::Adopt::NEXT warnings for the Catalyst:: namespace
+ in production versions (t0m)
+ - Make MyApp.pm restartable by unsetting setup_finished in
+ the restarter process (t0m)
+ - Non-naive implementation of making mutable on restart using
+ B::Hooks::OP::Check::StashChange if installed (t0m)
+ - Tests for this (t0m)
+ - Naive implementation of making all components mutable in the
+ forked restart watcher process so native Moose apps using
+ immutable restart correctly. (t0m)
+ - Tests for this (t0m)
+ - Bump Moose dependency to 0.70 so that we avoid nasty surprises
+ with is_class_loaded and perl 5.80 when you Moosify MyApp.pm (t0m)
+ - Clarify that request arguments aren't unescaped automatically
+ (Simon Bertrang) (Closes RT#41153)
+ - Don't require C3 for the MRO test (rafl)
+ - Bump MX::Emulate::CAF prereq to support list assignment (rafl)
+ - Remove useless column in chained action debug table. (rafl)
+ - namespace::clean related cleanups (rafl)
+ - Import related cleanups and consistency fixes (rafl)
+ - Fix test suite TestApp /dump/env action (t0m)
+
+5.8000_06 2009-02-04 21:00
+ - Disallow writing to config after setup (rafl)
+ - Disallow calling setup more than once (rafl)
+ - Documentation fix regarding overloading of Engine and Dispatcher
+ instances (rafl)
+ - Several documentation typo fixes (rafl)
+ - Stop Makefile.PL from warning about versions that fixed a conflict
+ (t0m)
+ - Improved upgrading documentation (t0m, rafl)
+ - Seed the RNG in each FastCGI child process (Andrew Rodland)
+ - Properly report dynamic bind port for the development server (rafl)
+ (Closes RT#38544)
+ - Use the way documented by IO::Socket::INET to get the error message
+ after trying to create a listening socket (rafl) (Closes RT#41828)
+ - Don't ignore SIGCHLD while handling requests with the dev server
+ (rafl) (Closes RT#42962)
+
+5.8000_05 2008-29-01 00:00
- Text::SimpleTable's go as wide as $ENV{COLUMNS} (jhannah)
Patch written by Oleg Kostyuk <cub.uanic@gmail.com>
- - backport go doc patch
- - added ru/ua translations to error page
- - backport stripping build_requires
-
-5.7099_04 2009-01-12 13:06:00
- - Add environment hack for FastCGI under IIS (Simon Bertrang)
- - Test for this and preexisting Lighty hack (Simon Bertrang)
- - Change streaming test to serve itself rather than 01use.t, making test
- sync for engines easier (t0m)
+ - Improve docs for visit (mateu)
+ - Add docs for finalize hook (dhoss)
+ - Added ru/ua translations to error page
+ - Improve the clarity and verbosity of the warning when component
+ resolution uses regex fallback. (jhannah)
+ - Handle leading CRLF in HTTP requests sometimes sent by IE6 in
+ keep-alive requests. (andyg)
+ - Fixes for FastCGI with IIS 6.0 (janus)
+ - Passing request method exported by Catalyst::Test an extra
+ parameter used to be ignored, but started breaking if the parameter
+ was not a hash in 5.8000_04. Extra parameter is now ignored if
+ it isn't a hashref (t0m)
+ - Fix request argumentss getting corrupted if you override the
+ dispatcher and call an action which detaches (for
+ Catalyst::Plugin::Authorization::ACL) (t0m)
+ - Fix calling use Catalyst::Test 'MyApp' 'foo' which used to work,
+ but stopped as the 2nd parameter can be an options hash now (t0m)
+ - Bump Moose dependency to fix make_immutable bug (t0m)
+ - Use compile time extends in Catalyst::Controller (t0m)
+ - Make Catalyst::Request::uploads attribute non-lazy, to fix
+ test for Catalyst-Engine-Apache (t0m)
+ - Bump version of MooseX::Emulate::Class::Accessor::Fast (t0m)
+ - Stop using MooseX::Adopt::Class::Accessor::Fast by default, to stop
+ breaking other packages which use Class::Accessor::Fast
+ - Remove unused action_container_class attribute from
+ Catalyst::Dispatcher (t0m)
+ - Replace {_body} instance access with calls to _body accessors (t0m)
+ - Add backwards compatibility alias methods for private attributes on
+ Catalyst::Dispatcher which used to be public. Needed by
+ Catalyst::Plugin::Server and Catalyst::Plugin::Authorization::ACL
+ (t0m)
+ - Fix return value of $c->req->body, which delegates to the body
+ method on the requests HTTP::Body instance (t0m)
+ - Test for this (t0m)
+ - Fix calling $c->req->body from inside an overridden prepare_action
+ method in a plugin, as used by Catalyst::Plugin::Server (t0m)
+ - Test for this (t0m)
+ - Fix assignment to Catalyst::Dispatcher's preload_dispatch_types and
+ postload_dispatch_types attributes - assigning a list should later
+ return a listref. Fixes Catalyst::Plugin::Server. (t0m)
+ - Tests for this (t0m)
+ - Change streaming test to serve itself rather than 01use.t, making
+ test sync for engines easier (t0m)
+ - Refactor capturing of $app from Catalyst::Controller into
+ Catalyst::Component::ApplicationAttribute for easier reuse in other
+ components (Florian Ragwitz)
+ - Make the test suites YAML dependency optional (Florian Ragwitz)
+ - Make debug output show class name for the engine and dispatcher
+ rather than the stringified ref. (t0m)
+ - Make MyApp immutable at the end of the scope after the setup
+ method is called, fixing issues with plugins which have their
+ own new methods by inlining a constructor on MyApp (t0m)
+ - Test for this and method modifiers in MyApp (t0m)
+ - Fix bug causing Catalyst::Request::Upload's basename method
+ to return undef (t0m)
+ - Test for this (Carl Franks)
+ - Fix loading of classes which do not define any symbols to not
+ die, as it didn't in 5.70 (t0m)
+ - Test for this (t0m)
+ - Bump MooseX::Emulate::Class::Accessor::Fast dependency
+ to force new version which fixes a lot of plugins (t0m)
+ - Make log levels additive, and add documentation and tests
+ for the setup_log method, which previously had none.
+ Sewn together by t0m from two patches provided by David E. Wheeler
+ - Switch an around 'new' in Catalyst::Controller to a BUILDARGS
+ method as it's much neater and more obvious what is going on (t0m)
+ - Add a clearer method on request and response _context
+ attributes, and use if from ::Engine rather than deleting
+ the key from the instance hash (t0m)
+ - Use handles on tree attribute of Catalyst::Stats to replace
+ trivial delegation methods (t0m)
+ - Change the following direct hash accesses into attributes:
+ Catalyst::Engine: _prepared_write
+ Catalyst::Engine::CGI: _header_buf
+ Catalyst::Engine::HTTP: options, _keepalive, _write_error
+ Catalyst::Request: _path
+ Catalyst::Stats: tree
+ (t0m)
+ - Fix issues in Catalyst::Controller::WrapCGI
+ and any other components which import (or define) their
+ own meta method by always explicitly calling
+ Class::MOP::Object->meta inside Catalyst (t0m)
+ - Add test for this (t0m)
+ - Add test case for the bug which is causing the
+ Catalyst::Plugin::Authentication tests to fail (t0m)
+ - Fix a bug in uri_for which could cause it to generate paths
+ with multiple slashes in them. (t0m)
+ - Add test for this (t0m)
+ - Fix SKIP block name in t/optional_http-server-restart.t,
+ stopping 'Label not found for "last SKIP"' error from
+ Test::More (t0m)
+ - Workaround max_redirect 0 bug in LWP (andyg)
+ - Move live_engine_response_print into aggregate (andyg)
+ - Fix dependency bug, s/parent/base/ in new test (rafl)
+ - Fix optional tests to run the live tests in the aggregate
+ dir (andyg)
+ - Fix Catalyst->go error in remote tests (andyg)
+ - Fix upload test to work with remote servers, don't check for
+ deleted files (andyg)
+ - Fix engine_request_uri tests to work on remote server with
+ different URI (andyg)
+
+5.8000_04 2008-12-05 12:15:00
+ - Silence Class::C3::Adopt::NEXT warnings in the test suite (rafl)
+ - Fix loads of 'used once, possible typo' warnings (rafl)
+ - Additional tests to ensure upload temp files are deleted (andyg)
+ - Remove use of NEXT from the test suite, except for one case
+ which tests if Class::C3::Adopt::NEXT is working (t0m)
+ - Use a predicate to avoid recursion in cases where the uri
+ method is overridden by a plugin, and calls the base method,
+ for example Catalyst::Plugin::SmartURI (t0m)
+ - Test for this (caelum)
+ - Compose the MooseX::Emulate::Class::Accessor::Fast role to
+ Catalyst::Action, Catalyst::Request, and all other modules which
+ inherit from Class::Accessor::Fast in 5.70.
+ This fixes:
+ - Catalyst::Controller::HTML::FormFu (zamolxes)
+ - Catalyst::Request::REST (t0m)
+ - Test for this (t0m)
+ - Make hostname resolution lazy (Marc Mims)
+ - Support mocking virtualhosts in test suite (Jason Gottshall)
+ - Add README (marcus)
+ - Fix TODO list (t0m)
+ - Use Class::C3::Adopt::NEXT (rafl)
+ - Ignore C3 warnings on 5.10 when testing ensure_class_loaded (rafl)
+ - Add TODO test for chained bug (gbjk)
+ - Fix list address in documentation (zarquon)
+ - Fix ACCEPT_CONTEXT on MyApp, called as a class method (marcus)
+ - Test for this (marcus)
+ - Bump MooseX::Emulate::Class::Accessor::Fast version requirement to
+ get more back compatibility (t0m)
+ - Improve documentation for $req->captures (caelum)
+ - Fix a bug in Catalyst::Stats, stopping garbage being inserted into
+ the stats if a user calls begin => but no end => (jhannah)
+ - Test for this (jhannah)
+ - Trim lines sooner in stats to avoid ugly Text::SimpleTable wrapping
+ (jhannah)
+ - Change Catalyst::ClassData to tweak the symbol table inline for
+ performance after profiling (mst)
+ - Fix POD typo in finalize_error (jhannah)
+ - Add tests to ensure that we delete the temp files created by
+ HTTP::Body's OctetStream parser (t0m)
+
+5.8000_03 2008-10-14 14:13:00
+ - Fix forwarding to Catalyst::Action objects (Rafael Kitover).
+ - Fix links to the mailing lists (RT #39754 and Florian Ragwitz).
+ - Use Class::MOP instead of Class::Inspector (Florian Ragwitz).
+ - Change Catalyst::Test to use Sub::Exporter (Florian Ragwitz).
+ - Fixed typo in Engine::HTTP::Restarter::Watcher causing -r to complain.
+
+5.8000_02 2008-10-14 07:59:00
+ - Fix manifest
+
+5.8000_01 2008-10-13 22:52:00
+ - Port to Moose
+ - Added test for action stringify
+ - Added test for component instances getting $self->{value} from config.
+ - Add Catalyst::Response->print() method (ilmari)
+ - Optionally aggregate tests using Test::Aggregate (Florian Ragwitz).
+ - Additional docs for uri_for to mention how to use $c->action and
+ $c->req->captures (jhannah)
+ - List unattached chained actions in Debug mode (Florian Ragwitz).
+ - Pod formatting fix for Engine::FastCGI (Oleg Kostyuk).
+ - Add visit, a returning ->go
+
+5.7XXXXXX XXXX
- Workaround change in LWP that broke a cookie test (RT #40037)
- - Backport go() from 5.8 branch.
+ - Back out go() since that feature's been pushed to 5.80
- Fix some Win32 test failures
- Add pt translation of error message (wreis)
- Make :Chained('../action') work (Florian Ragwitz)
- - Fix forwarding to action object.
- - Handle leading CRLF in HTTP requests sometimes sent by IE6 in keep-alive requests.
+ - Add test actions
+ - Chained doc improvements (rev 8326-8328)
5.7099_03 2008-07-20 10:10:00
- Fix regressions for regexp fallback in model(), view() and controller()
-use inc::Module::Install 0.77;
+use inc::Module::Install 0.64;
perl_version '5.008001';
name 'Catalyst-Runtime';
all_from 'lib/Catalyst/Runtime.pm';
+requires 'namespace::clean';
+requires 'Scope::Upper' => '0.06';
+requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00800';
+requires 'Moose' => '0.70';
requires 'Carp';
-requires 'Class::Accessor::Fast';
-requires 'Class::Data::Inheritable';
-requires 'Class::Inspector' => '1.06';
+requires 'Class::C3::Adopt::NEXT' => '0.07';
+requires 'Class::MOP';
requires 'CGI::Simple::Cookie';
requires 'Data::Dump';
requires 'File::Modified';
requires 'HTTP::Request::AsCGI' => '0.5';
requires 'LWP::UserAgent';
requires 'Module::Pluggable' => '3.01';
-requires 'NEXT';
requires 'Path::Class' => '0.09';
requires 'Scalar::Util';
+requires 'Sub::Exporter';
requires 'Text::SimpleTable' => '0.03';
requires 'Time::HiRes';
requires 'Tree::Simple' => '1.15';
requires 'Tree::Simple::Visitor::FindByPath';
requires 'URI' => '1.35';
requires 'Text::Balanced'; # core in 5.8.x but mentioned for completeness
+requires 'MRO::Compat';
+recommends 'B::Hooks::OP::Check::StashChange';
+test_requires 'Class::Data::Inheritable';
+test_requires 'Test::MockObject';
+
+# Run aggregate tests if AGGREGATE_TESTS environment = 1, but not if it = 0
+# Otherwise default to using Test::Aggregate if installed, but not requiring it.
+if ( ( exists $ENV{AGGREGATE_TESTS} && !$ENV{AGGREGATE_TESTS})
+ || (!exists $ENV{AGGREGATE_TESTS} && !can_use('Test::Aggregate', '0.34_01'))) {
+ tests join q{ },
+ grep { $_ ne 't/aggregate.t' }
+ map { glob } qw[t/*.t t/aggregate/*.t];
+}
+else {
+ test_requires('Test::Aggregate', '0.34_01');
+}
my @force_build_requires_if_author = qw(
- Test::NoTabs
- Test::Pod
- Test::Pod::Coverage
- Pod::Coverage
+ Test::NoTabs
+ Test::Pod
+ Test::Pod::Coverage
+ Pod::Coverage
);
-
-if ($Module::Install::AUTHOR) {
+if ($Module::Install::AUTHOR) {
foreach my $module (@force_build_requires_if_author) {
build_requires $module;
}
-
-
- if ($^O eq 'darwin') {
- my $osx_ver = `/usr/bin/sw_vers -productVersion`;
- chomp $osx_ver;
-
-# TAR on 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE
-# On 10.5 (Leopard) it wants COPYFILE_DISABLE
- my $attr = $osx_ver eq '10.5' ? 'COPYFILE_DISABLE' : 'COPY_EXTENDED_ATTRIBUTES_DISABLE';
-
- makemaker_args(dist => { PREOP => qq{\@if [ "\$\$$attr" != "true" ]; then}.
- qq{ echo "You must set the ENV variable $attr to true,"; }.
- ' echo "to avoid getting resource forks in your dist."; exit 255; fi' });
- }
+ darwin_check_no_resource_forks();
}
install_script glob('script/*.pl');
if ($Module::Install::AUTHOR) {
-# Strip out the author only build_requires from META.yml
-# Need to do this _after_ WriteAll else it looses track of them
- Meta->{values}{build_requires} = [ grep {
- my $ok = 1;
- foreach my $module (@force_build_requires_if_author) {
- if ($_->[0] =~ /$module/) {
- $ok = 0;
- last;
- }
- }
- $ok;
- } @{Meta->{values}{build_requires}} ];
-
- Meta->{values}{resources} = [
- [ 'MailingList', 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst' ],
- [ 'IRC', 'irc://irc.perl.org/#catalyst' ],
- [ 'license', 'http://dev.perl.org/licenses/' ],
- [ 'homepage', 'http://dev.catalyst.perl.org/'],
- [ 'repository', 'http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/' ],
- ];
-
- Meta->write;
+ # Strip out the author only build_requires from META.yml
+ # Need to do this _after_ WriteAll else it looses track of them
+ strip_author_only_build_requires(@force_build_requires_if_author);
+
+ Meta->{values}{resources} = [
+ [ 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst' ],
+ [ 'IRC' => 'irc://irc.perl.org/#catalyst' ],
+ [ 'license', => 'http://dev.perl.org/licenses/' ],
+ [ 'homepage', => 'http://dev.catalyst.perl.org/'],
+ [ 'repository', => 'http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/' ],
+ ];
+
+ Meta->write;
}
+
print <<"EOF";
Important:
Have fun!
EOF
+
+# NOTE - This is the version number of the _incompatible_ code,
+# not the version number of the fixed version.
+my %conflicts = (
+ 'Catalyst::Plugin::SmartURI' => '0.029',
+ 'CatalystX::CRUD' => '0.37',
+ 'Catalyst::Action::RenderView' => '0.07',
+ 'Catalyst::Plugin::DebugCookie' => '0.999002',
+ 'Catalyst::Plugin::Authentication' => '0.100091',
+ 'CatalystX::Imports' => '0.03',
+ 'Catalyst::Plugin::HashedCookies' => '1.03',
+);
+check_conflicts(%conflicts);
+
+# End of script, helper functions below.
+
+sub darwin_check_no_resource_forks {
+ if ($^O eq 'darwin') {
+ my $osx_ver = `/usr/bin/sw_vers -productVersion`;
+ chomp $osx_ver;
+
+ # TAR on 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE
+ # On 10.5 (Leopard) it wants COPYFILE_DISABLE
+ my $attr = $osx_ver eq '10.5' ? 'COPYFILE_DISABLE' : 'COPY_EXTENDED_ATTRIBUTES_DISABLE';
+
+ makemaker_args(dist => { PREOP => qq{\@if [ "\$\$$attr" != "true" ]; then}.
+ qq{ echo "You must set the ENV variable $attr to true,"; }.
+ ' echo "to avoid getting resource forks in your dist."; exit 255; fi' });
+ }
+}
+
+sub strip_author_only_build_requires {
+ my @build_requires_to_strip = @_;
+ Meta->{values}{build_requires} = [ grep {
+ my $ok = 1;
+ foreach my $module (@build_requires_to_strip) {
+ if ($_->[0] =~ /$module/) {
+ $ok = 0;
+ last;
+ }
+ }
+ $ok;
+ } @{Meta->{values}{build_requires}} ];
+}
+
+sub check_conflicts {
+ my %conflicts = @_;
+
+ my %conflicts_found;
+ for my $mod ( sort keys %conflicts ) {
+ eval "require($mod)";
+ next if $@;
+
+ my $installed = $mod->VERSION();
+ $conflicts_found{$mod} = $installed if ( $installed le $conflicts{$mod} );
+ }
+
+ return unless scalar keys %conflicts_found;
+
+ print <<"EOF";
+
+ WARNING:
+
+ This version of Catalyst conflicts with the versions of
+ some components you have installed.
+
+ You will need to upgrade these modules after installing
+ this version of Catalyst.
+
+ List of the conflicting components and their installed versions:
+
+EOF
+
+ foreach my $mod (keys %conflicts_found) {
+ print sprintf(" %s => %s\n", $mod, $conflicts_found{$mod});
+ }
+ print "\n";
+
+ # More or less copied from Module::Build, via Moose
+ return if $ENV{PERL_MM_USE_DEFAULT};
+ return unless -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT));
+
+ sleep 4;
+}
--- /dev/null
+Catalyst-Runtime
+================
+This is the Runtime distribution for the Catalyst MVC framework.
+For more information about Catalyst, write
+
+$ perldoc Catalyst
+
+at the command line, or visit http://www.catalystframework.org/.
+You can also install Catalyst::Manual from CPAN for more
+comprehensive information.
+
+If you are going to write your own Catalyst application, you will
+need to install Catalyst::Devel. Afterwards run catalyst.pl
+for more information about creating your first app.
--- /dev/null
+Compatibility:
+
+ - $self->config should warn as config should only ever be called as a
+ class method.
+
+ - Need at least good docs on how C3 fail occurs.
+
+Bugs:
+
+ - Fix the bleedin visit bug
+
+Testing:
+
+ - Run more smokes
+
+Profiling:
+
+ - vs 5.70 and optimisation as needed on perl 5.8 (5.10 is already faster!).
package Catalyst;
-use strict;
-use base 'Catalyst::Component';
+use Moose;
+extends 'Catalyst::Component';
use bytes;
+use Scope::Upper ();
use Catalyst::Exception;
use Catalyst::Log;
use Catalyst::Request;
use Devel::InnerPackage ();
use File::stat;
use Module::Pluggable::Object ();
-use NEXT;
use Text::SimpleTable ();
use Path::Class::Dir ();
use Path::Class::File ();
-use Time::HiRes qw/gettimeofday tv_interval/;
use URI ();
use URI::http;
use URI::https;
-use Scalar::Util qw/weaken blessed/;
use Tree::Simple qw/use_weak_refs/;
use Tree::Simple::Visitor::FindByUID;
+use Class::C3::Adopt::NEXT;
use attributes;
use utf8;
use Carp qw/croak carp shortmess/;
BEGIN { require 5.008001; }
-__PACKAGE__->mk_accessors(
- qw/counter request response state action stack namespace stats/
-);
+has stack => (is => 'ro', default => sub { [] });
+has stash => (is => 'rw', default => sub { {} });
+has state => (is => 'rw', default => 0);
+has stats => (is => 'rw');
+has action => (is => 'rw');
+has counter => (is => 'rw', default => sub { {} });
+has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1);
+has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1);
+has namespace => (is => 'rw');
sub depth { scalar @{ shift->stack || [] }; }
+sub comp { shift->component(@_) }
-# Laziness++
-*comp = \&component;
-*req = \&request;
-*res = \&response;
+sub req {
+ # carp "the use of req() is deprecated in favour of request()";
+ my $self = shift; return $self->request(@_);
+}
+sub res {
+ # carp "the use of res() is deprecated in favour of response()";
+ my $self = shift; return $self->response(@_);
+}
# For backwards compatibility
-*finalize_output = \&finalize_body;
+sub finalize_output { shift->finalize_body(@_) };
# For statistics
our $COUNT = 1;
our $DETACH = "catalyst_detach\n";
our $GO = "catalyst_go\n";
+#I imagine that very few of these really need to be class variables. if any.
+#maybe we should just make them attributes with a default?
__PACKAGE__->mk_classdata($_)
for qw/components arguments dispatcher engine log dispatcher_class
engine_class context_class request_class response_class stats_class
# Remember to update this in Catalyst::Runtime as well!
-our $VERSION = '5.71000';
+our $VERSION = '5.8000_06';
+
+{
+ my $dev_version = $VERSION =~ /_\d{2}$/;
+ *_IS_DEVELOPMENT_VERSION = sub () { $dev_version };
+}
+
+$VERSION = eval $VERSION;
sub import {
my ( $class, @arguments ) = @_;
# callers @ISA.
return unless $class eq 'Catalyst';
- my $caller = caller(0);
+ my $caller = caller();
+ return if $caller eq 'main';
+
+ # Kill Adopt::NEXT warnings if we're a non-RC version
+ unless (_IS_DEVELOPMENT_VERSION()) {
+ Class::C3::Adopt::NEXT->unimport(qr/^Catalyst::/);
+ }
+
+ my $meta = Moose::Meta::Class->initialize($caller);
+ #Moose->import({ into => $caller }); #do we want to do this?
unless ( $caller->isa('Catalyst') ) {
- no strict 'refs';
- push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
+ my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller');
+ $meta->superclasses(@superclasses);
+ }
+ unless( $meta->has_method('meta') ){
+ $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
}
$caller->arguments( [@arguments] );
=head2 -Log
-Specifies log level.
+ use Catalyst '-Log=warn,fatal,error';
+
+Specifies a comma-delimited list of log levels.
=head2 -Stats
=cut
-sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
+sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $c, @_ ) }
=head2 $c->detach( $action [, \@arguments ] )
=cut
-sub stash {
+around stash => sub {
+ my $orig = shift;
my $c = shift;
+ my $stash = $orig->($c);
if (@_) {
- my $stash = @_ > 1 ? {@_} : $_[0];
- croak('stash takes a hash or hashref') unless ref $stash;
- foreach my $key ( keys %$stash ) {
- $c->{stash}->{$key} = $stash->{$key};
+ my $new_stash = @_ > 1 ? {@_} : $_[0];
+ croak('stash takes a hash or hashref') unless ref $new_stash;
+ foreach my $key ( keys %$new_stash ) {
+ $stash->{$key} = $new_stash->{$key};
}
}
- return $c->{stash};
-}
+
+ return $stash;
+};
+
=head2 $c->error
my ( $c, $name, @prefixes ) = @_;
my $appclass = ref $c || $c;
my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
+ $filter = qr/$filter/; # Compile regex now rather than once per loop
# map the original component name to the sub part that we will search against
my %eligible = map { my $n = $_; $n =~ s{^$appclass\::[^:]+::}{}; $_ => $n; }
# don't warn if we didn't find any results, it just might not exist
if( @result ) {
- my $msg = "Used regexp fallback for \$c->model('${name}'), which found '" .
+ # Disgusting hack to work out correct method name
+ my $warn_for = lc $prefixes[0];
+ my $msg = "Used regexp fallback for \$c->{$warn_for}('${name}'), which found '" .
(join '", "', @result) . "'. Relying on regexp fallback behavior for " .
"component resolution is unreliable and unsafe.";
my $short = $result[0];
$msg .= " You probably need to set '$short' instead of '${name}' in this " .
"component's config";
} else {
- $msg .= " You probably meant \$c->model('$short') instead of \$c->model{'${name}'}, " .
+ $msg .= " You probably meant \$c->${warn_for}('$short') instead of \$c->${warn_for}({'${name}'}), " .
"but if you really wanted to search, pass in a regexp as the argument " .
- "like so: \$c->model(qr/${name}/)";
+ "like so: \$c->${warn_for}(qr/${name}/)";
}
$c->log->warn( "${msg}$shortmess" );
}
$c->log->warn( '* $c->config->{default_model} # the name of the default model to use' );
$c->log->warn( '* $c->stash->{current_model} # the name of the model to use for this request' );
$c->log->warn( '* $c->stash->{current_model_instance} # the instance of the model to use for this request' );
- $c->log->warn( 'NB: in version 5.80, the "random" behavior will not work at all.' );
+ $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' );
}
return $c->_filter_component( $comp );
$c->log->warn( '* $c->config->{default_view} # the name of the default view to use' );
$c->log->warn( '* $c->stash->{current_view} # the name of the view to use for this request' );
$c->log->warn( '* $c->stash->{current_view_instance} # the instance of the view to use for this request' );
- $c->log->warn( 'NB: in version 5.80, the "random" behavior will not work at all.' );
+ $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' );
}
return $c->_filter_component( $comp );
=cut
-sub config {
+around config => sub {
+ my $orig = shift;
my $c = shift;
- $c->log->warn("Setting config after setup has been run is not a good idea.")
- if ( @_ and $c->setup_finished );
+ croak('Setting config after setup has been run is not allowed.')
+ if ( @_ and $c->setup_finished );
- $c->NEXT::config(@_);
-}
+ $c->$orig(@_);
+};
=head2 $c->log
=head2 $c->debug
-Overload to enable debug messages (same as -Debug option).
+Returns 1 if debug mode is enabled, 0 otherwise.
-Note that this is a static method, not an accessor and should be overloaded
-by declaring "sub debug { 1 }" in your MyApp.pm, not by calling $c->debug(1).
+You can enable debug mode in several ways:
+(1) with the environment variables MYAPP_DEBUG, or CATALYST_DEBUG
+(2) the -Debug option in your MyApp.pm
+(3) by declaring "sub debug { 1 }" in your MyApp.pm.
+
+Calling $c->debug(1) has no effect.
=cut
=head2 $c->dispatcher
-Returns the dispatcher instance. Stringifies to class name. See
-L<Catalyst::Dispatcher>.
+Returns the dispatcher instance. See L<Catalyst::Dispatcher>.
=head2 $c->engine
-Returns the engine instance. Stringifies to the class name. See
-L<Catalyst::Engine>.
+Returns the engine instance. See L<Catalyst::Engine>.
=head2 UTILITY METHODS
=head2 $c->plugin( $name, $class, @args )
-Helper method for plugins. It creates a classdata accessor/mutator and
+Helper method for plugins. It creates a class data accessor/mutator and
loads and instantiates the given class.
MyApp->plugin( 'prototype', 'HTML::Prototype' );
$c->prototype->define_javascript_functions;
+
+B<Note:> This method of adding plugins is deprecated. The ability
+to add plugins like this B<will be removed> in a Catalyst 5.9.
+Please do not use this functionality in new code.
=cut
sub plugin {
my ( $class, $name, $plugin, @args ) = @_;
+
+ # See block comment in t/unit_core_plugin.t
+ $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.9/);
+
$class->_register_plugin( $plugin, 1 );
eval { $plugin->import };
sub setup {
my ( $class, @arguments ) = @_;
-
- $class->log->warn("Running setup twice is not a good idea.")
- if ( $class->setup_finished );
+ croak('Running setup more than once')
+ if ( $class->setup_finished );
unless ( $class->isa('Catalyst') ) {
my $engine = $class->engine;
my $home = $class->config->{home};
- $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
- $class->log->debug(qq/Loaded engine "$engine"/);
+ $class->log->debug(sprintf(q/Loaded dispatcher "%s"/, blessed($dispatcher)));
+ $class->log->debug(sprintf(q/Loaded engine "%s"/, blessed($engine)));
$home
? ( -d $home )
: $class->log->debug(q/Couldn't find home/);
}
- # Call plugins setup
+ # Call plugins setup, this is stupid and evil.
{
no warnings qw/redefine/;
local *setup = sub { };
}
# Add our self to components, since we are also a component
- $class->components->{$class} = $class;
+ if( $class->isa('Catalyst::Controller') ){
+ $class->components->{$class} = $class;
+ }
$class->setup_actions;
}
$class->log->_flush() if $class->log->can('_flush');
- $class->setup_finished(1);
+ # Make sure that the application class becomes immutable at this point,
+ # which ensures that it gets an inlined constructor. This means that it
+ # works even if the user has added a plugin which contains a new method.
+ # Note however that we have to do the work on scope end, so that method
+ # modifiers work correctly in MyApp (as you have to call setup _before_
+ # applying modifiers).
+ Scope::Upper::reap(sub {
+ my $meta = Class::MOP::get_metaclass_by_name($class);
+ $meta->make_immutable unless $meta->is_immutable;
+ }, Scope::Upper::SCOPE(1));
+
+ $class->setup_finalize;
}
-=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
-
-=head2 $c->uri_for( $path, @args?, \%query_values? )
-
-=over
-
-=item $action
-
-A Catalyst::Action object representing the Catalyst action you want to
-create a URI for.
-
-To get an action object:
-
- From another controller, anywhere:
- C<< $c->controller('ControllerName')->action_for('someactionname') >>
- Shorter styles useful in particular places:
- In the current controller's action method:
- C<< $self->action_for('someactionname') >>
- From the view for currently dispatched action:
- C<< $c->controller->action_for('someactionname') >>
-
-This method must be used to create URIs for
-L<Catalyst::DispatchType::Chained> actions.
+=head2 $app->setup_finalize
-=item $path
+A hook to attach modifiers to.
+Using C< after setup => sub{}; > doesn't work, because of quirky things done for plugin setup.
+Also better than C< setup_finished(); >, as that is a getter method.
-The actual path you wish to create a URI for, this is a public path,
-not a private action path.
+ sub setup_finalize {
-=item \@captures
+ my $app = shift;
-If provided, this argument is used to insert values into a I<Chained>
-action in the parts where the definitions contain I<CaptureArgs>. If
-not needed, leave out this argument.
+ ## do stuff, i.e., determine a primary key column for sessions stored in a DB
-=item @args
+ $app->next::method(@_);
-If provided, this is used as a list of further path sections to append
-to the URI. In a I<Chained> action these are the equivalent to the
-endpoint L<Args>.
-=item \%query_values
+ }
-If provided, the query_values hashref is used to add query parameters
-to the URI, with the keys as the names, and the values as the values.
+=cut
-=back
+sub setup_finalize {
+ my ($class) = @_;
+ $class->setup_finished(1);
+}
-Returns a L<URI> object.
+=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
- ## Ex 1: a path with args and a query parameter
- $c->uri_for($c->controller('User')->action_for('list'), 'short', { page => 2});
- ## -> ($c->req->base is 'http://localhost:3000/'
- URI->new('http://localhost:3000/user/list/short?page=2)
+=head2 $c->uri_for( $path, @args?, \%query_values? )
- ## Ex 2: a chained view action that captures the user id
- ## In controller:
- sub user : Chained('/'): PathPart('myuser'): CaptureArgs(1) {}
- sub viewuser : Chained('user'): PathPart('view') {}
+=over
- ## In uri creating code:
- my $uaction = $c->controller('Users')->action_for('viewuser');
- $c->uri_for($uaction, [ 42 ]);
- ## outputs:
- URI->new('http://localhost:3000/myuser/42/view')
+=item $action
- ## Ex 3: this style is deprecated and should be omitted
- $c->uri_for('user/list', 'short', { page => 2});
- ## -> ($c->req->base is 'http://localhost:3000/'
- URI->new('http://localhost:3000/user/list/short?page=2)
+A Catalyst::Action object representing the Catalyst action you want to
+create a URI for. To get one for an action in the current controller,
+use C<< $c->action('someactionname') >>. To get one from different
+controller, fetch the controller using C<< $c->controller() >>, then
+call C<action_for> on it.
-Creates a URI object using C<< $c->request->base >> and a path. If an
-Action object is given instead of a path, the path is constructed
-using C<< $c->dispatcher->uri_for_action >> and passing it the
-@captures array, if supplied.
+You can maintain the arguments captured by an action (e.g.: Regex, Chained)
+using C<< $c->req->captures >>.
-If any query parameters are passed they are added to the end of the
-URI in the usual way.
+ # For the current action
+ $c->uri_for($c->action, $c->req->captures);
+
+ # For the Foo action in the Bar controller
+ $c->uri_for($c->controller->('Bar')->action_for('Foo'), $c->req->captures);
-Note that uri_for is destructive to the passed query values hashref.
-Subsequent calls with the same hashref may have unintended results.
+=back
=cut
sub uri_for {
my ( $c, $path, @args ) = @_;
- if ( Scalar::Util::blessed($path) ) { # action object
+ if ( blessed($path) ) { # action object
my $captures = ( scalar @args && ref $args[0] eq 'ARRAY'
? shift(@args)
: [] );
# join args with '/', or a blank string
my $args = join('/', grep { defined($_) } @args);
$args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
- $args =~ s!^/!!;
+ $args =~ s!^/+!!;
my $base = $c->req->base;
my $class = ref($base);
$base =~ s{(?<!/)$}{/};
<a href="http://dev.catalyst.perl.org">Wiki</a>
</li>
<li>
- <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
+ <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
</li>
<li>
<a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
$c->state(0);
if ( $c->depth >= $RECURSION ) {
- my $action = "$code";
+ my $action = $code->reverse();
$action = "/$action" unless $action =~ /->/;
- my $error = qq/Deep recursion detected calling "$action"/;
+ my $error = qq/Deep recursion detected calling "${action}"/;
$c->log->error($error);
$c->error($error);
$c->state(0);
push( @{ $c->stack }, $code );
- eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
+ eval { $c->state( $code->execute( $class, $c, @{ $c->req->args } ) || 0 ) };
$c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
return if ( ( $code->name =~ /^_.*/ )
&& ( !$c->config->{show_internal_actions} ) );
- $c->counter->{"$code"}++;
+ my $action_name = $code->reverse();
+ $c->counter->{$action_name}++;
- my $action = "$code";
+ my $action = $action_name;
$action = "/$action" unless $action =~ /->/;
# determine if the call was the result of a forward
}
}
- my $uid = "$code" . $c->counter->{"$code"};
+ my $uid = $action_name . $c->counter->{$action_name};
# is this a root-level call or a forwarded call?
if ( $callsub =~ /forward$/ ) {
=cut
+#Why does this exist? This is no longer safe and WILL NOT WORK.
+# it doesnt seem to be used anywhere. can we remove it?
sub _localize_fields {
my ( $c, $localized, $code ) = ( @_ );
}
# Allow engine to handle finalize flow (for POE)
- if ( $c->engine->can('finalize') ) {
- $c->engine->finalize($c);
+ my $engine = $c->engine;
+ if ( my $code = $engine->can('finalize') ) {
+ $engine->$code($c);
}
else {
sub finalize_headers {
my $c = shift;
+ my $response = $c->response; #accessor calls can add up?
+
# Check if we already finalized headers
- return if $c->response->{_finalized_headers};
+ return if $response->finalized_headers;
# Handle redirects
- if ( my $location = $c->response->redirect ) {
+ if ( my $location = $response->redirect ) {
$c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
- $c->response->header( Location => $location );
-
- if ( !$c->response->body ) {
+ $response->header( Location => $location );
+
+ if ( !$response->has_body ) {
# Add a default body if none is already present
- $c->response->body(
+ $response->body(
qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
);
}
}
# Content-Length
- if ( $c->response->body && !$c->response->content_length ) {
+ if ( $response->body && !$response->content_length ) {
# get the length from a filehandle
- if ( blessed( $c->response->body ) && $c->response->body->can('read') )
+ if ( blessed( $response->body ) && $response->body->can('read') )
{
- my $stat = stat $c->response->body;
+ my $stat = stat $response->body;
if ( $stat && $stat->size > 0 ) {
- $c->response->content_length( $stat->size );
+ $response->content_length( $stat->size );
}
else {
$c->log->warn('Serving filehandle without a content-length');
}
else {
# everything should be bytes at this point, but just in case
- $c->response->content_length( bytes::length( $c->response->body ) );
+ $response->content_length( bytes::length( $response->body ) );
}
}
# Errors
- if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
- $c->response->headers->remove_header("Content-Length");
- $c->response->body('');
+ if ( $response->status =~ /^(1\d\d|[23]04)$/ ) {
+ $response->headers->remove_header("Content-Length");
+ $response->body('');
}
$c->finalize_cookies;
$c->engine->finalize_headers( $c, @_ );
# Done
- $c->response->{_finalized_headers} = 1;
+ $response->finalized_headers(1);
}
=head2 $c->finalize_output
}
$COUNT++;
- $class->log->_flush() if $class->log->can('_flush');
+
+ if(my $coderef = $class->log->can('_flush')){
+ $class->log->$coderef();
+ }
return $status;
}
sub prepare {
my ( $class, @arguments ) = @_;
+ # XXX
+ # After the app/ctxt split, this should become an attribute based on something passed
+ # into the application.
$class->context_class( ref $class || $class ) unless $class->context_class;
- my $c = $class->context_class->new(
- {
- counter => {},
- stack => [],
- request => $class->request_class->new(
- {
- arguments => [],
- body_parameters => {},
- cookies => {},
- headers => HTTP::Headers->new,
- parameters => {},
- query_parameters => {},
- secure => 0,
- captures => [],
- uploads => {}
- }
- ),
- response => $class->response_class->new(
- {
- body => '',
- cookies => {},
- headers => HTTP::Headers->new(),
- status => 200
- }
- ),
- stash => {},
- state => 0
- }
- );
+
+ my $c = $class->context_class->new({});
+
+ # For on-demand data
+ $c->request->_context($c);
+ $c->response->_context($c);
+ #surely this is not the most efficient way to do things...
$c->stats($class->stats_class->new)->enable($c->use_stats);
if ( $c->debug ) {
$c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
}
- # For on-demand data
- $c->request->{_context} = $c;
- $c->response->{_context} = $c;
- weaken( $c->request->{_context} );
- weaken( $c->response->{_context} );
-
+ #XXX reuse coderef from can
# Allow engine to direct the prepare flow (for POE)
if ( $c->engine->can('prepare') ) {
$c->engine->prepare( $c, @arguments );
sub prepare_body {
my $c = shift;
- # Do we run for the first time?
- return if defined $c->request->{_body};
+ return if $c->request->_has_body;
# Initialize on-demand data
$c->engine->prepare_body( $c, @_ );
my @comps = sort { length $a <=> length $b } $locator->plugins;
my %comps = map { $_ => 1 } @comps;
-
+
+ my $deprecated_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;
+
for my $component ( @comps ) {
# We pass ignore_loaded here so that overlay files for (e.g.)
# 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 = (
Catalyst::Exception->throw(
message =>
qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/
- ) unless eval { $instance->can( 'can' ) };
+ ) unless blessed($instance);
return $instance;
}
$dispatcher = $class->dispatcher_class;
}
- unless (Class::Inspector->loaded($dispatcher)) {
- require Class::Inspector->filename($dispatcher);
- }
+ Class::MOP::load_class($dispatcher);
# dispatcher instance
$class->dispatcher( $dispatcher->new );
}
if ( $ENV{MOD_PERL} ) {
-
+ my $meta = Class::MOP::get_metaclass_by_name($class);
+
# create the apache method
- {
- no strict 'refs';
- *{"$class\::apache"} = sub { shift->engine->apache };
- }
+ $meta->add_method('apache' => sub { shift->engine->apache });
my ( $software, $version ) =
$ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
$engine = $class->engine_class;
}
- unless (Class::Inspector->loaded($engine)) {
- require Class::Inspector->filename($engine);
- }
+ Class::MOP::load_class($engine);
# check for old engines that are no longer compatible
my $old_engine;
$home = $env;
}
- unless ($home) {
- $home = Catalyst::Utils::home($class);
- }
+ $home ||= Catalyst::Utils::home($class);
if ($home) {
+ #I remember recently being scolded for assigning config values like this
$class->config->{home} ||= $home;
$class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
}
=head2 $c->setup_log
-Sets up log.
+Sets up log by instantiating a L<Catalyst::Log|Catalyst::Log> object and
+passing it to C<log()>. Pass in a comma-delimited list of levels to set the
+log to.
+
+This method also installs a C<debug> method that returns a true value into the
+catalyst subclass if the "debug" level is passed in the comma-delimited list,
+or if the C<$CATALYST_DEBUG> environment variable is set to a true value.
+
+Note that if the log has already been setup, by either a previous call to
+C<setup_log> or by a call such as C<< __PACKAGE__->log( MyLogger->new ) >>,
+that this method won't actually set up the log object.
=cut
sub setup_log {
- my ( $class, $debug ) = @_;
+ my ( $class, $levels ) = @_;
+ $levels ||= '';
+ $levels =~ s/^\s+//;
+ $levels =~ s/\s+$//;
+ my %levels = map { $_ => 1 } split /\s*,\s*/, $levels || '';
+
unless ( $class->log ) {
- $class->log( Catalyst::Log->new );
+ $class->log( Catalyst::Log->new(keys %levels) );
}
my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
- if ( defined($env_debug) ? $env_debug : $debug ) {
- no strict 'refs';
- *{"$class\::debug"} = sub { 1 };
+ if ( defined($env_debug) or $levels{debug} ) {
+ Class::MOP::get_metaclass_by_name($class)->add_method('debug' => sub { 1 });
$class->log->debug('Debug messages enabled');
}
}
my $env = Catalyst::Utils::env_value( $class, 'STATS' );
if ( defined($env) ? $env : ($stats || $class->debug ) ) {
- no strict 'refs';
- *{"$class\::use_stats"} = sub { 1 };
+ Class::MOP::get_metaclass_by_name($class)->add_method('use_stats' => sub { 1 });
$class->log->debug('Statistics enabled');
}
}
# no ignore_loaded here, the plugin may already have been
# defined in memory and we don't want to error on "no file" if so
- Catalyst::Utils::ensure_class_loaded( $plugin );
+ Class::MOP::load_class( $plugin );
$proto->_plugins->{$plugin} = 1;
unless ($instant) {
no strict 'refs';
- unshift @{"$class\::ISA"}, $plugin;
+ if ( my $meta = Class::MOP::get_metaclass_by_name($class) ) {
+ my @superclasses = ($plugin, $meta->superclasses );
+ $meta->superclasses(@superclasses);
+ } else {
+ unshift @{"$class\::ISA"}, $plugin;
+ }
}
return $class;
}
Mailing Lists:
- http://lists.rawmode.org/mailman/listinfo/catalyst
- http://lists.rawmode.org/mailman/listinfo/catalyst-dev
+ http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst
+ http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
Web:
bricas: Brian Cassidy <bricas@cpan.org>
+Caelum: Rafael Kitover <rkitover@io.com>
+
chansen: Christian Hansen
chicks: Christopher Hicks
+David E. Wheeler
+
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
Drew Taylor
Geoff Richards
+ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+
jcamacho: Juan Camacho
jhannah: Jay Hannah <jay@jays.net>
phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
+rafl: Florian Ragwitz <rafl@debian.org>
+
sky: Arthur Bergman
the_jester: Jesse Sheidlower
+t0m: Tomas Doran <bobtfish@bobtfish.net>
+
Ulf Edvinsson
willert: Sebastian Willert <willert@cpan.org>
-batman: Jan Henning Thorsen <pm@flodhest.net>
-
=head1 LICENSE
This library is free software, you can redistribute it and/or modify it under
=cut
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::Action;
-use strict;
-use base qw/Class::Accessor::Fast/;
-
-
=head1 NAME
Catalyst::Action - Catalyst Action
=head1 SYNOPSIS
- <form action="[%c.uri_for(c.action.reverse)%]">
+ <form action="[%c.uri_for(c.action)%]">
=head1 DESCRIPTION
=cut
-__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/);
+use Moose;
+
+with 'MooseX::Emulate::Class::Accessor::Fast';
+
+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;
use overload (
);
+
+
+no warnings 'recursion';
+
+#__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/);
+
sub dispatch { # Execute ourselves against a context
my ( $self, $c ) = @_;
return $c->execute( $self->class, $self );
sub execute {
my $self = shift;
- $self->{code}->(@_);
+ $self->code->(@_);
}
sub match {
my ( $self, $c ) = @_;
+ #would it be unreasonable to store the number of arguments
+ #the action has as it's own attribute?
+ #it would basically eliminate the code below. ehhh. small fish
return 1 unless exists $self->attributes->{Args};
my $args = $self->attributes->{Args}[0];
return 1 unless defined($args) && length($args);
return scalar( @{ $c->req->args } ) == $args;
}
+__PACKAGE__->meta->make_immutable;
+
1;
__END__
returns the sub name of this action.
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHORS
Catalyst Contributors, see Catalyst.pm
package Catalyst::ActionChain;
-use strict;
-use base qw/Catalyst::Action/;
+use Moose;
+extends qw(Catalyst::Action);
+has chain => (is => 'rw');
+
+no Moose;
=head1 NAME
=cut
-__PACKAGE__->mk_accessors(qw/chain/);
-
-use overload (
-
- # Stringify to reverse for debug output etc.
- q{""} => sub { shift->{reverse} },
-
- # Codulate to execute to invoke the encapsulated action coderef
- '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; },
-
- # Make general $stuff still work
- fallback => 1,
-
-);
-
-
sub dispatch {
my ( $self, $c ) = @_;
my @captures = @{$c->req->captures||[]};
return $self->new({ %$final, chain => $actions });
}
+__PACKAGE__->meta->make_immutable;
1;
__END__
Takes a list of Catalyst::Action objects and constructs and returns a
Catalyst::ActionChain object representing a chain of these actions
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHORS
Catalyst Contributors, see Catalyst.pm
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;
+with 'MooseX::Emulate::Class::Accessor::Fast';
-sub new {
- my ( $class, $fields ) = @_;
+has part => (is => 'rw', required => 1);
+has actions => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
- $fields = { part => $fields, actions => {} } unless ref $fields;
-
- $class->SUPER::new($fields);
-}
+around BUILDARGS => sub {
+ my ($next, $self, @args) = @_;
+ unshift @args, 'part' if scalar @args == 1 && !ref $args[0];
+ return $self->$next(@args);
+};
+no Moose;
+use overload (
+ # Stringify to path part for tree search
+ q{""} => sub { shift->part },
+);
sub get_action {
my ( $self, $name ) = @_;
$self->actions->{$name} = $action;
}
+__PACKAGE__->meta->make_immutable;
+
1;
__END__
Accessor to the path part this container resolves to. Also what the container
stringifies to.
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHORS
Catalyst Contributors, see Catalyst.pm
package Catalyst::AttrContainer;
-use strict;
-use base qw/Class::Accessor::Fast Class::Data::Inheritable/;
-
+use Moose;
use Catalyst::Exception;
-use NEXT;
+with 'Catalyst::ClassData';
+
+no Moose;
-__PACKAGE__->mk_classdata($_) for qw/_attr_cache _action_cache/;
-__PACKAGE__->_attr_cache( {} );
-__PACKAGE__->_action_cache( [] );
+__PACKAGE__->mk_classdata(_attr_cache => {} );
+__PACKAGE__->mk_classdata( _action_cache => [] );
# note - see attributes(3pm)
sub MODIFY_CODE_ATTRIBUTES {
package Catalyst::Base;
-use strict;
use base qw/Catalyst::Controller/;
+use Moose;
+no Moose;
1;
=head1 DESCRIPTION
This used to be the base class for Catalyst Controllers. It
-remains here for compability reasons.
+remains here for compatibility reasons.
=head1 SEE ALSO
--- /dev/null
+package Catalyst::ClassData;
+
+use Moose::Role;
+use Class::MOP;
+use Class::MOP::Object;
+
+sub mk_classdata {
+ my ($class, $attribute) = @_;
+ confess("mk_classdata() is a class method, not an object method")
+ if blessed $class;
+
+ my $slot = '$'.$attribute;
+ my $accessor = sub {
+ my $pkg = ref $_[0] || $_[0];
+ # Hack - delberately create a metaclass instance
+ my $meta = $pkg->Class::MOP::Object::meta();
+ if (@_ > 1) {
+ $meta->namespace->{$attribute} = \$_[1];
+ return $_[1];
+ }
+
+ # tighter version of
+ # if ( $meta->has_package_symbol($slot) ) {
+ # return ${ $meta->get_package_symbol($slot) };
+ # }
+ no strict 'refs';
+ my $v = *{"${pkg}::${attribute}"}{SCALAR};
+ if (defined ${$v}) {
+ return ${$v};
+ } else {
+ foreach my $super ( $meta->linearized_isa ) {
+ # tighter version of same after
+ # my $super_meta = Moose::Meta::Class->initialize($super);
+ my $v = ${"${super}::"}{$attribute} ? *{"${super}::${attribute}"}{SCALAR} : undef;
+ if (defined ${$v}) {
+ return ${$v};
+ }
+ }
+ }
+ return;
+ };
+
+ confess("Failed to create accessor: $@ ")
+ unless ref $accessor eq 'CODE';
+
+ my $meta = $class->Class::MOP::Object::meta();
+ my $immutable_options;
+ if( $meta->is_immutable ){
+ $immutable_options = $meta->get_immutable_options;
+ $meta->make_mutable;
+ }
+ my $alias = "_${attribute}_accessor";
+ $meta->add_method($alias, $accessor);
+ $meta->add_method($attribute, $accessor);
+ if(defined $immutable_options){
+ $meta->make_immutable(%{ $immutable_options });
+ }
+ $class->$attribute($_[2]) if(@_ > 2);
+ return $accessor;
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Catalyst::ClassData - Class data accessors
+
+=head1 METHODS
+
+=head2 mk_classdata $name, $optional_value
+
+A moose-safe clone of L<Class::Data::Inheritable> that borrows some ideas from
+L<Class::Accessor::Grouped>;
+
+=head1 AUTHOR
+
+Guillermo Roditi
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
package Catalyst::Component;
-use strict;
-use base qw/Class::Accessor::Fast Class::Data::Inheritable/;
-use NEXT;
+use Moose;
+use Class::MOP;
+use Class::MOP::Object;
use Catalyst::Utils;
+use Class::C3::Adopt::NEXT;
+use MRO::Compat;
+use mro 'c3';
+
+with 'MooseX::Emulate::Class::Accessor::Fast';
+with 'Catalyst::ClassData';
-BEGIN {
- if (eval 'require Moose; 1') {
- *__HAVE_MOOSE = sub () { 1 };
- }
- else {
- *__HAVE_MOOSE = sub () { 0 };
- }
-}
=head1 NAME
=cut
-__PACKAGE__->mk_classdata($_) for qw/_config _plugins/;
-
-
-
-sub new {
- my ( $class, $c ) = @_;
+__PACKAGE__->mk_classdata('_plugins');
+__PACKAGE__->mk_classdata('_config');
+sub BUILDARGS {
+ my ($self) = @_;
+
# Temporary fix, some components does not pass context to constructor
my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {};
- my $config = $class->merge_config_hashes( $class->config, $arguments );
-
- my $self = $class->NEXT::new($config);
-
- if (__HAVE_MOOSE) {
- my $meta = Class::MOP::get_metaclass_by_name($class);
- if ($meta) {
- $self = $meta->new_object(
- __INSTANCE__ => $self,
- %$config
- );
- # May not inherit from Moose::Object at all, so
- # call BUILDALL explicitly.
- $self->Moose::Object::BUILDALL($config);
- }
- }
- return $self;
+ my $args = $self->merge_config_hashes( $self->config, $arguments );
+
+ return $args;
}
sub COMPONENT {
# Temporary fix, some components does not pass context to constructor
my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {};
-
- if ( my $new = $self->NEXT::COMPONENT( $c, $arguments ) ) {
- return $new;
- }
- else {
- if ( my $new = $self->new( $c, $arguments ) ) {
- return $new;
- }
- else {
- my $class = ref $self || $self;
- my $new = $self->merge_config_hashes(
- $self->config, $arguments );
- return bless $new, $class;
- }
+ if( my $next = $self->next::can ){
+ my $class = blessed $self || $self;
+ my ($next_package) = Class::MOP::get_code_info($next);
+ warn "There is a COMPONENT method resolving after Catalyst::Component in ${next_package}.\n";
+ warn "This behavior can no longer be supported, and so your application is probably broken.\n";
+ warn "Your linearised isa hierarchy is: " . join(', ', mro::get_linear_isa($class)) . "\n";
+ warn "Please see perldoc Catalyst::Upgrading for more information about this issue.\n";
}
+ return $self->new($c, $arguments);
}
sub config {
my $self = shift;
- my $config_sub = $self->can('_config');
- my $config = $self->$config_sub() || {};
+ my $config = $self->_config || {};
if (@_) {
my $newconfig = { %{@_ > 1 ? {@_} : $_[0]} };
$self->_config(
} else {
# this is a bit of a kludge, required to make
# __PACKAGE__->config->{foo} = 'bar';
- # work in a subclass. Calling the Class::Data::Inheritable setter
- # will create a new _config method in the current class if it's
- # currently inherited from the superclass. So, the can() call will
- # return a different subref in that case and that means we know to
- # copy and reset the value stored in the class data.
-
- $self->_config( $config );
-
- if ((my $config_sub_now = $self->can('_config')) ne $config_sub) {
+ # work in a subclass.
+ my $class = blessed($self) || $self;
+ my $meta = Class::MOP::get_metaclass_by_name($class);
+ unless ($meta->has_package_symbol('$_config')) {
$config = $self->merge_config_hashes( $config, {} );
- $self->$config_sub_now( $config );
+ $self->_config( $config );
}
}
return $config;
. " did not override Catalyst::Component::process" );
}
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
1;
__END__
=head2 ACCEPT_CONTEXT($c, @args)
-Catalyst components are normally initalized during server startup, either
+Catalyst components are normally initialized during server startup, either
as a Class or a Instance. However, some components require information about
the current request. To do so, they can implement an ACCEPT_CONTEXT method.
--- /dev/null
+package Catalyst::Component::ApplicationAttribute;
+
+use Moose::Role;
+use namespace::clean -except => 'meta';
+
+# Future - isa => 'ClassName|Catalyst' performance?
+# required => 1 breaks tests..
+has _application => (is => 'ro', weak_ref => 1);
+sub _app { (shift)->_application(@_) }
+
+override BUILDARGS => sub {
+ my ($self, $app) = @_;
+
+ my $args = super();
+ $args->{_application} = $app;
+
+ return $args;
+};
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catalyst::Component::ApplicationAttribute - Moose Role for components which capture the application context.
+
+=head1 SYNOPSIS
+
+ package My::Component;
+ use Moose;
+ extends 'Catalyst::Component';
+ with 'Catalyst::Component::ApplicationAttribute';
+
+ # Your code here
+
+ 1;
+
+=head1 DESCRIPTION
+
+This role provides a BUILDARGS method which captures the application context into an attribute.
+
+=head1 ATTRIBUTES
+
+=head2 _application
+
+Weak reference to the application context.
+
+=head1 METHODS
+
+=head2 BUILDARGS ($self, $app)
+
+BUILDARGS method captures the application context into the C<_application> attribute.
+
+=head2 _application
+
+Reader method for the application context.
+
+=head1 SEE ALSO
+
+L<Catalyst::Component>,
+L<Catalyst::Controller>.
+
+=head1 AUTHORS
+
+Catalyst Contributors, see Catalyst.pm
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
package Catalyst::Controller;
-use strict;
-use base qw/Catalyst::Component Catalyst::AttrContainer Class::Accessor::Fast/;
+use Moose;
+use Moose::Util qw/find_meta/;
+
+use namespace::clean -except => 'meta';
+
+# Note - Must be done at compile time due to attributes (::AttrContainer)
+BEGIN { extends qw/Catalyst::Component Catalyst::AttrContainer/; }
use Catalyst::Exception;
use Catalyst::Utils;
-use Class::Inspector;
-use NEXT;
+
+with 'Catalyst::Component::ApplicationAttribute';
+
+has path_prefix =>
+ (
+ is => 'rw',
+ isa => 'Str',
+ init_arg => 'path',
+ predicate => 'has_path_prefix',
+ );
+
+has action_namespace =>
+ (
+ is => 'rw',
+ isa => 'Str',
+ init_arg => 'namespace',
+ predicate => 'has_action_namespace',
+ );
+
+has actions =>
+ (
+ is => 'rw',
+ isa => 'HashRef',
+ init_arg => undef,
+ );
+
+sub BUILD {
+ my ($self, $args) = @_;
+ my $action = delete $args->{action} || {};
+ my $actions = delete $args->{actions} || {};
+ my $attr_value = $self->merge_config_hashes($actions, $action);
+ $self->actions($attr_value);
+}
=head1 NAME
=cut
+#I think both of these could be attributes. doesn't really seem like they need
+#to ble class data. i think that attributes +default would work just fine
__PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/;
__PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
__PACKAGE__->_action_class('Catalyst::Action');
-__PACKAGE__->mk_accessors( qw/_application/ );
-
-### _app as alias
-*_app = *_application;
sub _DISPATCH : Private {
my ( $self, $c ) = @_;
return !@{ $c->error };
}
-sub new {
- my $self = shift;
- my $app = $_[0];
- my $new = $self->NEXT::new(@_);
- $new->_application( $app );
- return $new;
-}
-
-
sub action_for {
my ( $self, $name ) = @_;
my $app = ($self->isa('Catalyst') ? $self : $self->_application);
return $app->dispatcher->get_action($name, $self->action_namespace);
}
-sub action_namespace {
+#my opinion is that this whole sub really should be a builder method, not
+#something that happens on every call. Anyone else disagree?? -- groditi
+## -- apparently this is all just waiting for app/ctx split
+around action_namespace => sub {
+ my $orig = shift;
my ( $self, $c ) = @_;
- unless ( $c ) {
- $c = ($self->isa('Catalyst') ? $self : $self->_application);
+
+ if( ref($self) ){
+ return $self->$orig if $self->has_action_namespace;
+ } else {
+ return $self->config->{namespace} if exists $self->config->{namespace};
}
- my $hash = (ref $self ? $self : $self->config); # hate app-is-class
- return $hash->{namespace} if exists $hash->{namespace};
- return Catalyst::Utils::class2prefix( ref($self) || $self,
- $c->config->{case_sensitive} )
- || '';
-}
-sub path_prefix {
- my ( $self, $c ) = @_;
- unless ( $c ) {
- $c = ($self->isa('Catalyst') ? $self : $self->_application);
+ my $case_s;
+ if( $c ){
+ $case_s = $c->config->{case_sensitive};
+ } else {
+ if ($self->isa('Catalyst')) {
+ $case_s = $self->config->{case_sensitive};
+ } else {
+ if (ref $self) {
+ $case_s = $self->_application->config->{case_sensitive};
+ } else {
+ confess("Can't figure out case_sensitive setting");
+ }
+ }
}
- my $hash = (ref $self ? $self : $self->config); # hate app-is-class
- return $hash->{path} if exists $hash->{path};
- return shift->action_namespace(@_);
-}
+
+ my $namespace = Catalyst::Utils::class2prefix(ref($self) || $self, $case_s) || '';
+ $self->$orig($namespace) if ref($self);
+ return $namespace;
+};
+
+#Once again, this is probably better written as a builder method
+around path_prefix => sub {
+ my $orig = shift;
+ my $self = shift;
+ if( ref($self) ){
+ return $self->$orig if $self->has_path_prefix;
+ } else {
+ return $self->config->{path} if exists $self->config->{path};
+ }
+ my $namespace = $self->action_namespace(@_);
+ $self->$orig($namespace) if ref($self);
+ return $namespace;
+};
sub register_actions {
my ( $self, $c ) = @_;
my $class = ref $self || $self;
+ #this is still not correct for some reason.
my $namespace = $self->action_namespace($c);
- my %methods;
- $methods{ $self->can($_) } = $_
- for @{ Class::Inspector->methods($class) || [] };
+ my $meta = find_meta($self);
+ my %methods = map { $_->body => $_->name }
+ $meta->get_all_methods;
# Advanced inheritance support for plugins and the like
+ #moose todo: migrate to eliminate CDI compat
my @action_cache;
- {
- no strict 'refs';
- for my $isa ( @{"$class\::ISA"}, $class ) {
- push @action_cache, @{ $isa->_action_cache }
- if $isa->can('_action_cache');
+ for my $isa ( $meta->superclasses, $class ) {
+ if(my $coderef = $isa->can('_action_cache')){
+ push(@action_cache, @{ $isa->$coderef });
}
}
if $c->debug;
next;
}
- my $reverse = $namespace ? "$namespace/$method" : $method;
+ my $reverse = $namespace ? "${namespace}/${method}" : $method;
my $action = $self->create_action(
name => $method,
code => $code,
? $args{attributes}{ActionClass}[0]
: $self->_action_class);
- unless ( Class::Inspector->loaded($class) ) {
- require Class::Inspector->filename($class);
- }
-
+ Class::MOP::load_class($class);
return $class->new( \%args );
}
}
}
- my $hash = (ref $self ? $self : $self->config); # hate app-is-class
-
- if (exists $hash->{actions} || exists $hash->{action}) {
- my $a = $hash->{actions} || $hash->{action};
- %raw_attributes = ((exists $a->{'*'} ? %{$a->{'*'}} : ()),
- %raw_attributes,
- (exists $a->{$name} ? %{$a->{$name}} : ()));
+ #I know that the original behavior was to ignore action if actions was set
+ # but i actually think this may be a little more sane? we can always remove
+ # the merge behavior quite easily and go back to having actions have
+ # presedence over action by modifying the keys. i honestly think this is
+ # superior while mantaining really high degree of compat
+ my $actions;
+ if( ref($self) ) {
+ $actions = $self->actions;
+ } else {
+ my $cfg = $self->config;
+ $actions = $self->merge_config_hashes($cfg->{actions}, $cfg->{action});
}
+ %raw_attributes = ((exists $actions->{'*'} ? %{$actions->{'*'}} : ()),
+ %raw_attributes,
+ (exists $actions->{$name} ? %{$actions->{$name}} : ()));
+
+
my %final_attributes;
foreach my $key (keys %raw_attributes) {
foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
my $meth = "_parse_${key}_attr";
- if ( $self->can($meth) ) {
- ( $key, $value ) = $self->$meth( $c, $name, $value );
+ if ( my $code = $self->can($meth) ) {
+ ( $key, $value ) = $self->$code( $c, $name, $value );
}
push( @{ $final_attributes{$key} }, $value );
}
return ( 'ActionClass', $value );
}
+__PACKAGE__->meta->make_immutable;
+
1;
__END__
package Catalyst::DispatchType;
-use strict;
-use base 'Class::Accessor::Fast';
+use Moose;
+with 'MooseX::Emulate::Class::Accessor::Fast';
+no Moose;
=head1 NAME
sub register { }
-=head2 $self->expand_action
-
-Default fallback, returns nothing. See L<Catalyst::Dispatcher> for more info
-about expand_action.
-
-=cut
-
-sub expand_action { }
-
=head2 $self->uri_for_action( $action, \@captures )
abstract method, to be implemented by dispatchtypes. Takes a
sub uri_for_action { }
+=head2 $self->expand_action
+
+Default fallback, returns nothing. See L<Catalyst::Dispatcher> for more info
+about expand_action.
+
+=cut
+
+sub expand_action { }
+
=head1 AUTHORS
Catalyst Contributors, see Catalyst.pm
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::DispatchType::Chained;
-use strict;
-use base qw/Catalyst::DispatchType/;
+use Moose;
+extends 'Catalyst::DispatchType';
+
use Text::SimpleTable;
use Catalyst::ActionChain;
use Catalyst::Utils;
use URI;
+has _endpoints => (
+ is => 'rw',
+ isa => 'ArrayRef',
+ required => 1,
+ default => sub{ [] },
+ );
+
+has _actions => (
+ is => 'rw',
+ isa => 'HashRef',
+ required => 1,
+ default => sub{ {} },
+ );
+
+has _children_of => (
+ is => 'rw',
+ isa => 'HashRef',
+ required => 1,
+ default => sub{ {} },
+ );
+
+no Moose;
+
# please don't perltidy this. hairy code within.
=head1 NAME
sub list {
my ( $self, $c ) = @_;
- return unless $self->{endpoints};
+ return unless $self->_endpoints;
my $column_width = Catalyst::Utils::term_width() - 35 - 9;
my $paths = Text::SimpleTable->new(
- [ 35, 'Path Spec' ], [ 36, 'Private' ], [ $column_width, 'Private' ]
+ [ 35, 'Path Spec' ], [ $column_width, 'Private' ],
+ );
+
+ my $has_unattached_actions;
+ my $unattached_actions = Text::SimpleTable->new(
+ [ 35, 'Private' ], [ 36, 'Missing parent' ],
);
ENDPOINT: foreach my $endpoint (
sort { $a->reverse cmp $b->reverse }
- @{ $self->{endpoints} }
+ @{ $self->_endpoints }
) {
my $args = $endpoint->attributes->{Args}->[0];
my @parts = (defined($args) ? (("*") x $args) : '...');
if (defined $pp->[0] && length $pp->[0]);
}
$parent = $curr->attributes->{Chained}->[0];
- $curr = $self->{actions}{$parent};
+ $curr = $self->_actions->{$parent};
unshift(@parents, $curr) if $curr;
}
- next ENDPOINT unless $parent eq '/'; # skip dangling action
+ if ($parent ne '/') {
+ $has_unattached_actions = 1;
+ $unattached_actions->row('/'.$parents[0]->reverse, $parent);
+ next ENDPOINT;
+ }
my @rows;
foreach my $p (@parents) {
my $name = "/${p}";
}
$c->log->debug( "Loaded Chained actions:\n" . $paths->draw . "\n" );
+ $c->log->debug( "Unattached Chained actions:\n", $unattached_actions->draw . "\n" )
+ if $has_unattached_actions;
}
=head2 $self->match( $c, $path )
sub match {
my ( $self, $c, $path ) = @_;
- return 0 if @{$c->req->args};
+ my $request = $c->request;
+ return 0 if @{$request->args};
my @parts = split('/', $path);
my ($chain, $captures, $parts) = $self->recurse_match($c, '/', \@parts);
- push @{$c->req->args}, @$parts if $parts && @$parts;
+ push @{$request->args}, @$parts if $parts && @$parts;
return 0 unless $chain;
my $action = Catalyst::ActionChain->from_chain($chain);
- $c->req->action("/${action}");
- $c->req->match("/${action}");
- $c->req->captures($captures);
+ $request->action("/${action}");
+ $request->match("/${action}");
+ $request->captures($captures);
$c->action($action);
$c->namespace( $action->namespace );
sub recurse_match {
my ( $self, $c, $parent, $path_parts ) = @_;
- my $children = $self->{children_of}{$parent};
+ my $children = $self->_children_of->{$parent};
return () unless $children;
my $best_action;
my @captures;
);
}
- my $children = ($self->{children_of}{ $chained_attr[0] } ||= {});
+ my $children = ($self->_children_of->{ $chained_attr[0] } ||= {});
my @path_part = @{ $action->attributes->{PathPart} || [] };
$part = $path_part[0];
} elsif (@path_part > 1) {
Catalyst::Exception->throw(
- "Multiple PathPart attributes not supported registering ${action}"
+ "Multiple PathPart attributes not supported registering " . $action->reverse()
);
}
if ($part =~ m(^/)) {
Catalyst::Exception->throw(
- "Absolute parameters to PathPart not allowed registering ${action}"
+ "Absolute parameters to PathPart not allowed registering " . $action->reverse()
);
}
unshift(@{ $children->{$part} ||= [] }, $action);
- ($self->{actions} ||= {})->{'/'.$action->reverse} = $action;
+ $self->_actions->{'/'.$action->reverse} = $action;
unless ($action->attributes->{CaptureArgs}) {
- unshift(@{ $self->{endpoints} ||= [] }, $action);
+ unshift(@{ $self->_endpoints }, $action);
}
return 1;
if (defined($pp->[0]) && length($pp->[0]));
}
$parent = $curr->attributes->{Chained}->[0];
- $curr = $self->{actions}{$parent};
+ $curr = $self->_actions->{$parent};
}
return undef unless $parent eq '/'; # fail for dangling action
while ($curr) {
push @chain, $curr;
my $parent = $curr->attributes->{Chained}->[0];
- $curr = $self->{'actions'}{$parent};
+ $curr = $self->_actions->{$parent};
}
return Catalyst::ActionChain->from_chain([reverse @chain]);
}
+__PACKAGE__->meta->make_immutable;
+
=head1 USAGE
=head2 Introduction
package Catalyst::DispatchType::Default;
-use strict;
-use base qw/Catalyst::DispatchType/;
+use Moose;
+extends 'Catalyst::DispatchType';
+
+no Moose;
=head1 NAME
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::DispatchType::Index;
-use strict;
-use base qw/Catalyst::DispatchType/;
+use Moose;
+extends 'Catalyst::DispatchType';
+no Moose;
=head1 NAME
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::DispatchType::Path;
-use strict;
-use base qw/Catalyst::DispatchType/;
+use Moose;
+extends 'Catalyst::DispatchType';
+
use Text::SimpleTable;
use Catalyst::Utils;
use URI;
+has _paths => (
+ is => 'rw',
+ isa => 'HashRef',
+ required => 1,
+ default => sub { +{} },
+ );
+
+no Moose;
+
=head1 NAME
Catalyst::DispatchType::Path - Path DispatchType
my $paths = Text::SimpleTable->new(
[ 35, 'Path' ], [ $column_width, 'Private' ]
);
- foreach my $path ( sort keys %{ $self->{paths} } ) {
+ foreach my $path ( sort keys %{ $self->_paths } ) {
my $display_path = $path eq '/' ? $path : "/$path";
- foreach my $action ( @{ $self->{paths}->{$path} } ) {
+ foreach my $action ( @{ $self->_paths->{$path} } ) {
$paths->row( $display_path, "/$action" );
}
}
$c->log->debug( "Loaded Path actions:\n" . $paths->draw . "\n" )
- if ( keys %{ $self->{paths} } );
+ if ( keys %{ $self->_paths } );
}
=head2 $self->match( $c, $path )
$path = '/' if !defined $path || !length $path;
- foreach my $action ( @{ $self->{paths}->{$path} || [] } ) {
+ foreach my $action ( @{ $self->_paths->{$path} || [] } ) {
next unless $action->match($c);
$c->req->action($path);
$c->req->match($path);
$path = '/' unless length $path;
$path = URI->new($path)->canonical;
- unshift( @{ $self->{paths}{$path} ||= [] }, $action);
+ unshift( @{ $self->_paths->{$path} ||= [] }, $action);
return 1;
}
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::DispatchType::Regex;
-use strict;
-use base qw/Catalyst::DispatchType::Path/;
+use Moose;
+extends 'Catalyst::DispatchType::Path';
+
use Text::SimpleTable;
use Catalyst::Utils;
use Text::Balanced ();
+has _compiled => (
+ is => 'rw',
+ isa => 'ArrayRef',
+ required => 1,
+ default => sub{ [] },
+ );
+
+no Moose;
+
=head1 NAME
Catalyst::DispatchType::Regex - Regex DispatchType
my ( $self, $c ) = @_;
my $column_width = Catalyst::Utils::term_width() - 35 - 9;
my $re = Text::SimpleTable->new( [ 35, 'Regex' ], [ $column_width, 'Private' ] );
- for my $regex ( @{ $self->{compiled} } ) {
+ for my $regex ( @{ $self->_compiled } ) {
my $action = $regex->{action};
$re->row( $regex->{path}, "/$action" );
}
$c->log->debug( "Loaded Regex actions:\n" . $re->draw . "\n" )
- if ( @{ $self->{compiled} } );
+ if ( @{ $self->_compiled } );
}
=head2 $self->match( $c, $path )
# Check path against plain text first
- foreach my $compiled ( @{ $self->{compiled} || [] } ) {
+ foreach my $compiled ( @{ $self->_compiled } ) {
if ( my @captures = ( $path =~ $compiled->{re} ) ) {
next unless $compiled->{action}->match($c);
$c->req->action( $compiled->{path} );
=head2 $self->register_regex($c, $re, $action)
-Register an individual regex on the action. Usually called from the
+Register an individual regex on the action. Usually called from the
register method.
=cut
sub register_regex {
my ( $self, $c, $re, $action ) = @_;
push(
- @{ $self->{compiled} }, # and compiled regex for us
+ @{ $self->_compiled }, # and compiled regex for us
{
re => qr#$re#,
action => $action,
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::Dispatcher;
-use strict;
-use base 'Class::Accessor::Fast';
+use Moose;
+use Class::MOP;
+with 'MooseX::Emulate::Class::Accessor::Fast';
+
use Catalyst::Exception;
use Catalyst::Utils;
use Catalyst::Action;
use Text::SimpleTable;
use Tree::Simple;
use Tree::Simple::Visitor::FindByPath;
-use Scalar::Util ();
-
-# 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
- /
-);
+# Refactoring note:
+# do these belong as package vars or should we build these via a builder method?
+# See Catalyst-Plugin-Server for them being added to, which should be much less ugly.
# Preload these action types
our @PRELOAD = qw/Index Path Regex/;
# Postload these action types
our @POSTLOAD = qw/Default/;
+# Note - see back-compat methods at end of file.
+has _tree => (is => 'rw');
+has _dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1);
+has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1);
+has _method_action_class => (is => 'rw', default => 'Catalyst::Action');
+has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
+has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} });
+
+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] });
+
+# Wrap accessors so you can assign a list and it will capture a list ref.
+around qw/preload_dispatch_types postload_dispatch_types/ => sub {
+ my $orig = shift;
+ my $self = shift;
+ return $self->$orig([@_]) if (scalar @_ && ref $_[0] ne 'ARRAY');
+ return $self->$orig(@_);
+};
+
+no Moose;
+
=head1 NAME
Catalyst::Dispatcher - The Catalyst Dispatcher
=cut
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
+sub BUILD {
+ my ($self, $params) = @_;
- my $obj = $class->SUPER::new(@_);
+ my $container =
+ Catalyst::ActionContainer->new( { part => '/', actions => {} } );
- # set the default pre- and and postloads
- $obj->preload_dispatch_types( \@PRELOAD );
- $obj->postload_dispatch_types( \@POSTLOAD );
- $obj->action_hash( {} );
- $obj->container_hash( {} );
-
- # 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
+My::Dispatch::Type
-=head2 $self->detach( $c, $command [, \@arguments ] )
-
-Documented in L<Catalyst>
-
-=cut
-
-sub detach {
- my ( $self, $c, $command, @args ) = @_;
- $c->forward( $command, @args ) if $command;
- die $Catalyst::DETACH;
-}
-
=head2 $self->dispatch($c)
Delegate the dispatch to the action that matched the url, or return a
message about unknown resource
-
=cut
sub dispatch {
my ( $self, $c ) = @_;
- if ( $c->action ) {
- $c->forward( join( '/', '', $c->action->namespace, '_DISPATCH' ) );
+ if ( my $action = $c->action ) {
+ $c->forward( join( '/', '', $action->namespace, '_DISPATCH' ) );
}
-
else {
my $path = $c->req->path;
my $error = $path
}
my @args;
-
+
if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
@args = @{ pop @extra_params }
} else {
my $action;
- if (Scalar::Util::blessed($command) && $command->isa('Catalyst::Action')) {
+ # go to a string path ("/foo/bar/gorch")
+ # or action object
+ if (blessed($command) && $command->isa('Catalyst::Action')) {
$action = $command;
}
else {
- # go to a string path ("/foo/bar/gorch")
- # or action object which stringifies to that
$action = $self->_invoke_as_path( $c, "$command", \@args );
}
sub forward {
my $self = shift;
+ $self->_do_forward(forward => @_);
+}
+
+sub _do_forward {
+ my $self = shift;
+ my $opname = shift;
my ( $c, $command ) = @_;
my ( $action, $args ) = $self->_command2action(@_);
- unless ($action) {
- my $error =
- qq/Couldn't forward to command "$command": /
- . qq/Invalid action or component./;
+ if (!$action) {
+ my $error .= qq/Couldn't $opname to command "$command": /
+ .qq/Invalid action or component./;
$c->error($error);
$c->log->debug($error) if $c->debug;
return 0;
}
+ no warnings 'recursion';
+
local $c->request->{arguments} = $args;
$action->dispatch( $c );
return $c->state;
}
+=head2 $self->detach( $c, $command [, \@arguments ] )
+
+Documented in L<Catalyst>
+
+=cut
+
+sub detach {
+ my ( $self, $c, $command, @args ) = @_;
+ $self->_do_forward(detach => $c, $command, @args ) if $command;
+ die $Catalyst::DETACH;
+}
+
sub _action_rel2abs {
my ( $self, $c, $path ) = @_;
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,
sub prepare_action {
my ( $self, $c ) = @_;
- my $path = $c->req->path;
- my @path = split /\//, $c->req->path;
- $c->req->args( \my @args );
+ my $req = $c->req;
+ my $path = $req->path;
+ my @path = split /\//, $req->path;
+ $req->args( \my @args );
unshift( @path, '' ); # Root action
# 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 );
}
unshift @args, $arg;
}
- s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$c->req->captures||[]};
+ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg for grep { defined } @{$req->captures||[]};
- $c->log->debug( 'Path is "' . $c->req->match . '"' )
- if ( $c->debug && length $c->req->match );
+ $c->log->debug( 'Path is "' . $req->match . '"' )
+ if ( $c->debug && defined $req->match && length $req->match );
$c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
if ( $c->debug && @args );
$namespace = join( "/", grep { length } split '/', ( defined $namespace ? $namespace : "" ) );
- return $self->action_hash->{"$namespace/$name"};
+ return $self->_action_hash->{"${namespace}/${name}"};
}
=head2 $self->get_action_by_path( $path );
-
+
Returns the named action by its full path.
-=cut
+=cut
sub get_action_by_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->{''};
+ #return (split '/', $namespace); # isnt this more clear?
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);
return undef;
}
-=head2 expand_action
+=head2 expand_action
expand an action into a full representation of the dispatch.
mostly useful for chained, other actions will just return a
sub expand_action {
my ($self, $action) = @_;
- foreach my $dispatch_type (@{ $self->dispatch_types }) {
+ foreach my $dispatch_type (@{ $self->_dispatch_types }) {
my $expanded = $dispatch_type->expand_action($action);
return $expanded if $expanded;
}
sub register {
my ( $self, $c, $action ) = @_;
- my $registered = $self->registered_dispatch_types;
+ my $registered = $self->_registered_dispatch_types;
- my $priv = 0;
+ #my $priv = 0; #seems to be unused
foreach my $key ( keys %{ $action->attributes } ) {
next if $key eq 'Private';
my $class = "Catalyst::DispatchType::$key";
unless ( $registered->{$class} ) {
- eval "require $class";
- push( @{ $self->dispatch_types }, $class->new ) unless $@;
+ # FIXME - Some error checking and re-throwing needed here, as
+ # we eat exceptions loading dispatch types.
+ eval { Class::MOP::load_class($class) };
+ 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;
=head2 $self->setup_actions( $class, $context )
+Loads all of the preload dispatch types, registers their actions and then
+loads all of the postload dispatch types, and iterates over the tree of
+actions, displaying the debug information if appropriate.
=cut
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');
-
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');
$self->_load_dispatch_types( @{ $self->postload_dispatch_types } );
return unless $c->debug;
- $self->_display_action_tables($c);
-}
-
-sub _display_action_tables {
- my ($self, $c) = @_;
my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
my $privates = Text::SimpleTable->new(
$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 {
for my $type (@types) {
my $class =
( $type =~ /^\+(.*)$/ ) ? $1 : "Catalyst::DispatchType::${type}";
- eval "require $class";
+
+ eval { Class::MOP::load_class($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;
}
-# Dont document this until someone else is happy with beaviour. Ash 2009/03/16
-sub dispatch_type {
- my ($self, $name) = @_;
-
- unless ($name =~ s/^\+//) {
- $name = "Catalyst::DispatchType::" . $name;
+use Moose;
+
+# 5.70 backwards compatibility hacks.
+
+# Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
+# need the methods here which *should* be private..
+
+# However we can't really take them away until there is a sane API for
+# building actions and configuring / introspecting the dispatcher.
+# In 5.90, we should build that infrastructure, port the plugins which
+# use it, and then take the crap below away.
+# See also t/lib/TestApp/Plugin/AddDispatchTypes.pm
+
+# Alias _method_name to method_name, add a before modifier to warn..
+foreach my $public_method_name (qw/
+ tree
+ dispatch_types
+ registered_dispatch_types
+ method_action_class
+ action_hash
+ container_hash
+ /) {
+ my $private_method_name = '_' . $public_method_name;
+ my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time.
+ $meta->add_method($public_method_name, $meta->get_method($private_method_name));
+ {
+ my %package_hash; # Only warn once per method, per package. These are infrequent enough that
+ # I haven't provided a way to disable them, patches welcome.
+ $meta->add_before_method_modifier($public_method_name, sub {
+ my $class = blessed(shift);
+ $package_hash{$class}++ || do {
+ warn("Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name,\n"
+ . "this will be removed in Catalyst 5.9X");
+ };
+ });
}
-
- for (@{ $self->dispatch_types }) {
- return $_ if ref($_) eq $name;
- }
- return undef;
}
+# End 5.70 backwards compatibility hacks.
+
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
+=head2 meta
+
+Provided by Moose
=head1 AUTHORS
package Catalyst::Engine;
-use strict;
-use base 'Class::Accessor::Fast';
+use Moose;
+with 'MooseX::Emulate::Class::Accessor::Fast';
+
use CGI::Simple::Cookie;
use Data::Dump qw/dump/;
use Errno 'EWOULDBLOCK';
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
-use Scalar::Util ();
+
+use namespace::clean -except => 'meta';
# input position and length
-__PACKAGE__->mk_accessors(qw/read_position read_length/);
+has read_length => (is => 'rw');
+has read_position => (is => 'rw');
-# Stringify to class
-use overload '""' => sub { return ref shift }, fallback => 1;
+has _prepared_write => (is => 'rw');
# Amount of data to read from input on each pass
our $CHUNKSIZE = 64 * 1024;
my ( $self, $c ) = @_;
my $body = $c->response->body;
no warnings 'uninitialized';
- if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
+ 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 ( $self, $c ) = @_;
my @cookies;
+ my $response = $c->response;
- foreach my $name ( keys %{ $c->response->cookies } ) {
+ foreach my $name (keys %{ $response->cookies }) {
- my $val = $c->response->cookies->{$name};
+ my $val = $response->cookies->{$name};
my $cookie = (
- Scalar::Util::blessed($val)
+ blessed($val)
? $val
: CGI::Simple::Cookie->new(
-name => $name,
}
for my $cookie (@cookies) {
- $c->res->headers->push_header( 'Set-Cookie' => $cookie );
+ $response->headers->push_header( 'Set-Cookie' => $cookie );
}
}
=head2 $self->finalize_error($c)
-Output an apropriate error message, called if there's an error in $c
+Output an appropriate error message. Called if there's an error in $c
after the dispatch has finished. Will output debug messages if Catalyst
is in debug mode, or a `please come back later` message otherwise.
$name = "<h1>$name</h1>";
# Don't show context in the dump
- delete $c->req->{_context};
- delete $c->res->{_context};
+ $c->req->_clear_context;
+ $c->res->_clear_context;
# Don't show body parser in the dump
- delete $c->req->{_body};
-
- # Don't show response header state in dump
- delete $c->res->{_finalized_headers};
+ $c->req->_clear_body;
my @infos;
my $i = 0;
sub finalize_uploads {
my ( $self, $c ) = @_;
- if ( keys %{ $c->request->uploads } ) {
- for my $key ( keys %{ $c->request->uploads } ) {
- my $upload = $c->request->uploads->{$key};
- unlink map { $_->tempname }
- grep { -e $_->tempname }
- ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
- }
+ my $request = $c->request;
+ foreach my $key (keys %{ $request->uploads }) {
+ my $upload = $request->uploads->{$key};
+ unlink grep { -e $_ } map { $_->tempname }
+ (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
}
+
}
=head2 $self->prepare_body($c)
my ( $self, $c ) = @_;
if ( my $length = $self->read_length ) {
- unless ( $c->request->{_body} ) {
- my $type = $c->request->header('Content-Type');
- $c->request->{_body} = HTTP::Body->new( $type, $length );
- $c->request->{_body}->tmpdir( $c->config->{uploadtmp} )
+ 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};
}
}
else {
# Defined but will cause all body code to be skipped
- $c->request->{_body} = 0;
+ $c->request->_body(0);
}
}
sub prepare_body_chunk {
my ( $self, $c, $chunk ) = @_;
- $c->request->{_body}->add($chunk);
+ $c->request->_body->add($chunk);
}
=head2 $self->prepare_body_parameters($c)
sub prepare_body_parameters {
my ( $self, $c ) = @_;
- return unless $c->request->{_body};
+ return unless $c->request->_body;
- $c->request->body_parameters( $c->request->{_body}->param );
+ $c->request->body_parameters( $c->request->_body->param );
}
=head2 $self->prepare_connection($c)
sub prepare_parameters {
my ( $self, $c ) = @_;
+ my $request = $c->request;
+ my $parameters = $request->parameters;
+ my $body_parameters = $request->body_parameters;
+ my $query_parameters = $request->query_parameters;
# We copy, no references
- foreach my $name ( keys %{ $c->request->query_parameters } ) {
- my $param = $c->request->query_parameters->{$name};
- $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
- $c->request->parameters->{$name} = $param;
+ foreach my $name (keys %$query_parameters) {
+ my $param = $query_parameters->{$name};
+ $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
}
# Merge query and body parameters
- foreach my $name ( keys %{ $c->request->body_parameters } ) {
- my $param = $c->request->body_parameters->{$name};
- $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
- if ( my $old_param = $c->request->parameters->{$name} ) {
- if ( ref $old_param eq 'ARRAY' ) {
- push @{ $c->request->parameters->{$name} },
- ref $param eq 'ARRAY' ? @$param : $param;
- }
- else { $c->request->parameters->{$name} = [ $old_param, $param ] }
+ foreach my $name (keys %$body_parameters) {
+ my $param = $body_parameters->{$name};
+ my @values = ref $param eq 'ARRAY' ? @$param : ($param);
+ if ( my $existing = $parameters->{$name} ) {
+ unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
}
- else { $c->request->parameters->{$name} = $param }
+ $parameters->{$name} = @values > 1 ? \@values : $values[0];
}
}
sub prepare_uploads {
my ( $self, $c ) = @_;
-
- return unless $c->request->{_body};
-
- my $uploads = $c->request->{_body}->upload;
- for my $name ( keys %$uploads ) {
+
+ my $request = $c->request;
+ return unless $request->_body;
+
+ my $uploads = $request->_body->upload;
+ my $parameters = $request->parameters;
+ foreach my $name (keys %$uploads) {
my $files = $uploads->{$name};
- $files = ref $files eq 'ARRAY' ? $files : [$files];
my @uploads;
- for my $upload (@$files) {
- my $u = Catalyst::Request::Upload->new;
- $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
- $u->type( $u->headers->content_type );
- $u->tempname( $upload->{tempname} );
- $u->size( $upload->{size} );
- $u->filename( $upload->{filename} );
+ for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
+ my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
+ my $u = Catalyst::Request::Upload->new
+ (
+ size => $upload->{size},
+ type => $headers->content_type,
+ headers => $headers,
+ tempname => $upload->{tempname},
+ filename => $upload->{filename},
+ );
push @uploads, $u;
}
- $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
+ $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
# support access to the filename as a normal param
my @filenames = map { $_->{filename} } @uploads;
# append, if there's already params with this name
- if (exists $c->request->parameters->{$name}) {
- if (ref $c->request->parameters->{$name} eq 'ARRAY') {
- push @{ $c->request->parameters->{$name} }, @filenames;
+ if (exists $parameters->{$name}) {
+ if (ref $parameters->{$name} eq 'ARRAY') {
+ push @{ $parameters->{$name} }, @filenames;
}
else {
- $c->request->parameters->{$name} =
- [ $c->request->parameters->{$name}, @filenames ];
+ $parameters->{$name} = [ $parameters->{$name}, @filenames ];
}
}
else {
- $c->request->parameters->{$name} =
- @filenames > 1 ? \@filenames : $filenames[0];
+ $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
}
}
}
=head2 $self->read_chunk($c, $buffer, $length)
-Each engine inplements read_chunk as its preferred way of reading a chunk
+Each engine implements read_chunk as its preferred way of reading a chunk
of data.
=cut
sub write {
my ( $self, $c, $buffer ) = @_;
- unless ( $self->{_prepared_write} ) {
+ unless ( $self->_prepared_write ) {
$self->prepare_write($c);
- $self->{_prepared_write} = 1;
+ $self->_prepared_write(1);
}
+ return 0 if !defined $buffer;
+
my $len = length($buffer);
my $wrote = syswrite STDOUT, $buffer;
package Catalyst::Engine::CGI;
-use strict;
-use base 'Catalyst::Engine';
-use NEXT;
+use Moose;
+extends 'Catalyst::Engine';
-__PACKAGE__->mk_accessors('env');
+has env => (is => 'rw');
+has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf');
=head1 NAME
$c->response->header( Status => $c->response->status );
- $self->{_header_buf}
- = $c->response->headers->as_string("\015\012") . "\015\012";
+ $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012");
}
=head2 $self->prepare_connection($c)
my ( $self, $c ) = @_;
local (*ENV) = $self->env || \%ENV;
- $c->request->address( $ENV{REMOTE_ADDR} );
+ my $request = $c->request;
+ $request->address( $ENV{REMOTE_ADDR} );
PROXY_CHECK:
{
# If we are running as a backend server, the user will always appear
# as 127.0.0.1. Select the most recent upstream IP (last in the list)
my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/;
- $c->request->address($ip);
+ $request->address($ip);
}
- $c->request->hostname( $ENV{REMOTE_HOST} );
- $c->request->protocol( $ENV{SERVER_PROTOCOL} );
- $c->request->user( $ENV{REMOTE_USER} );
- $c->request->method( $ENV{REQUEST_METHOD} );
+ $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST};
+ $request->protocol( $ENV{SERVER_PROTOCOL} );
+ $request->user( $ENV{REMOTE_USER} );
+ $request->method( $ENV{REQUEST_METHOD} );
if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
- $c->request->secure(1);
+ $request->secure(1);
}
if ( $ENV{SERVER_PORT} == 443 ) {
- $c->request->secure(1);
+ $request->secure(1);
}
}
sub prepare_headers {
my ( $self, $c ) = @_;
local (*ENV) = $self->env || \%ENV;
-
+ my $headers = $c->request->headers;
# Read headers from %ENV
foreach my $header ( keys %ENV ) {
next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i;
( my $field = $header ) =~ s/^HTTPS?_//;
- $c->req->headers->header( $field => $ENV{$header} );
+ $headers->header( $field => $ENV{$header} );
}
}
=cut
-sub prepare_query_parameters {
+around prepare_query_parameters => sub {
+ my $orig = shift;
my ( $self, $c ) = @_;
local (*ENV) = $self->env || \%ENV;
if ( $ENV{QUERY_STRING} ) {
- $self->SUPER::prepare_query_parameters( $c, $ENV{QUERY_STRING} );
+ $self->$orig( $c, $ENV{QUERY_STRING} );
}
-}
+};
=head2 $self->prepare_request($c, (env => \%env))
=cut
-sub prepare_write {
- my ( $self, $c ) = @_;
-
- # Set the output handle to autoflush
+around prepare_write => sub {
*STDOUT->autoflush(1);
-
- $self->NEXT::prepare_write($c);
-}
+ return shift->(@_);
+};
=head2 $self->write($c, $buffer)
=cut
-sub write {
+around write => sub {
+ my $orig = shift;
my ( $self, $c, $buffer ) = @_;
# Prepend the headers if they have not yet been sent
- if ( my $headers = delete $self->{_header_buf} ) {
- $buffer = $headers . $buffer;
+ if ( $self->_has_header_buf ) {
+ $buffer = $self->_clear_header_buf . $buffer;
}
-
- return $self->NEXT::write( $c, $buffer );
-}
+
+ return $self->$orig( $c, $buffer );
+};
=head2 $self->read_chunk($c, $buffer, $length)
the same terms as Perl itself.
=cut
+no Moose;
1;
package Catalyst::Engine::FastCGI;
-use strict;
-use base 'Catalyst::Engine::CGI';
+use Moose;
+extends 'Catalyst::Engine::CGI';
+
+# eval { Class::MOP::load_class("FCGI") };
eval "use FCGI";
die "Unable to load the FCGI module, you may need to install it:\n$@\n" if $@;
=item leave_umask
-Set to 1 to disable setting umask to 0 for socket open =item nointr
+Set to 1 to disable setting umask to 0 for socket open
+
+=item nointr
Do not allow the listener to be interrupted by Ctrl+C
my $error = \*STDERR; # send STDERR to the web server
$error = \*STDOUT # send STDERR to stdout (a logfile)
if $options->{keep_stderr}; # (if asked to)
-
+
my $request =
FCGI::Request( \*STDIN, \*STDOUT, $error, \%env, $sock,
( $options->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR ),
$self->daemon_detach() if $options->{detach};
$proc_manager->pm_manage();
+
+ # Give each child its own RNG state.
+ srand;
}
elsif ( $options->{detach} ) {
$self->daemon_detach();
$proc_manager && $proc_manager->pm_pre_dispatch();
$self->_fix_env( \%env );
-
+
$class->handle_request( env => \%env );
-
+
$proc_manager && $proc_manager->pm_post_dispatch();
}
}
sub write {
my ( $self, $c, $buffer ) = @_;
- unless ( $self->{_prepared_write} ) {
+ unless ( $self->_prepared_write ) {
$self->prepare_write($c);
- $self->{_prepared_write} = 1;
+ $self->_prepared_write(1);
}
# XXX: We can't use Engine's write() method because syswrite
# written: http://www.fastcgi.com/om_archive/mail-archive/0128.html
# Prepend the headers if they have not yet been sent
- if ( my $headers = delete $self->{_header_buf} ) {
- $buffer = $headers . $buffer;
+ if ( $self->_has_header_buf ) {
+ $buffer = $self->_clear_header_buf . $buffer;
}
# FastCGI does not stream data properly if using 'print $handle',
package Catalyst::Engine::HTTP;
-use strict;
-use base 'Catalyst::Engine::CGI';
+use Moose;
+extends 'Catalyst::Engine::CGI';
+
use Data::Dump qw(dump);
use Errno 'EWOULDBLOCK';
use HTTP::Date ();
use HTTP::Headers;
use HTTP::Status;
-use NEXT;
use Socket;
use IO::Socket::INET ();
use IO::Select ();
use constant CHUNKSIZE => 64 * 1024;
use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0;
+use namespace::clean -except => 'meta';
+
+has options => ( is => 'rw' );
+has _keepalive => ( is => 'rw', predicate => '_is_keepalive', clearer => '_clear_keepalive' );
+has _write_error => ( is => 'rw', predicate => '_has_write_error' );
+
+# Refactoring note - could/should Eliminate all instances of $self->{inputbuf},
+# which I haven't touched as it is used as an lvalue in a lot of places, and I guess
+# doing it differently could be expensive.. Feel free to refactor and NYTProf :)
+
=head1 NAME
Catalyst::Engine::HTTP - Catalyst HTTP Engine
my $protocol = $c->request->protocol;
my $status = $c->response->status;
my $message = status_message($status);
-
+ my $res_headers = $c->response->headers;
+
my @headers;
push @headers, "$protocol $status $message";
-
- $c->response->headers->header( Date => HTTP::Date::time2str(time) );
- $c->response->headers->header( Status => $status );
-
+
+ $res_headers->header( Date => HTTP::Date::time2str(time) );
+ $res_headers->header( Status => $status );
+
# Should we keep the connection open?
my $connection = $c->request->header('Connection');
- if ( $self->{options}->{keepalive}
+ if ( $self->options->{keepalive}
&& $connection
&& $connection =~ /^keep-alive$/i
) {
- $c->response->headers->header( Connection => 'keep-alive' );
- $self->{_keepalive} = 1;
+ $res_headers->header( Connection => 'keep-alive' );
+ $self->_keepalive(1);
}
else {
- $c->response->headers->header( Connection => 'close' );
+ $res_headers->header( Connection => 'close' );
}
-
- push @headers, $c->response->headers->as_string("\x0D\x0A");
-
+
+ push @headers, $res_headers->as_string("\x0D\x0A");
+
# Buffer the headers so they are sent with the first write() call
# This reduces the number of TCP packets we are sending
- $self->{_header_buf} = join("\x0D\x0A", @headers, '');
+ $self->_header_buf( join("\x0D\x0A", @headers, '') );
}
=head2 $self->finalize_read($c)
=cut
-sub finalize_read {
- my ( $self, $c ) = @_;
-
+before finalize_read => sub {
# Never ever remove this, it would result in random length output
# streams if STDIN eq STDOUT (like in the HTTP engine)
*STDIN->blocking(1);
-
- return $self->NEXT::finalize_read($c);
-}
+};
=head2 $self->prepare_read($c)
=cut
-sub prepare_read {
- my ( $self, $c ) = @_;
-
+before prepare_read => sub {
# Set the input handle to non-blocking
*STDIN->blocking(0);
-
- return $self->NEXT::prepare_read($c);
-}
+};
=head2 $self->read_chunk($c, $buffer, $length)
=cut
-sub write {
+around write => sub {
+ my $orig = shift;
my ( $self, $c, $buffer ) = @_;
-
+
# Avoid 'print() on closed filehandle Remote' warnings when using IE
return unless *STDOUT->opened();
# Prepend the headers if they have not yet been sent
- if ( my $headers = delete $self->{_header_buf} ) {
- $buffer = $headers . $buffer;
+ if ( $self->_has_header_buf ) {
+ $buffer = $self->_clear_header_buf . $buffer;
}
-
- my $ret = $self->NEXT::write( $c, $buffer );
-
+
+ my $ret = $self->$orig($c, $buffer);
+
if ( !defined $ret ) {
- $self->{_write_error} = $!;
+ $self->_write_error($!);
DEBUG && warn "write: Failed to write response ($!)\n";
}
else {
DEBUG && warn "write: Wrote response ($ret bytes)\n";
}
-
+
return $ret;
-}
+};
=head2 run
my ( $self, $class, $port, $host, $options ) = @_;
$options ||= {};
-
- $self->{options} = $options;
+
+ $self->options($options);
if ($options->{background}) {
my $child = fork;
ReuseAddr => 1,
Type => SOCK_STREAM,
)
- or die "Couldn't create daemon: $!";
+ or die "Couldn't create daemon: $@";
+
+ $port = $daemon->sockport();
my $url = "http://$host";
$url .= ":$port" unless $port == 80;
}
my $pid = undef;
-
+
# Ignore broken pipes as an HTTP server should
local $SIG{PIPE} = 'IGNORE';
-
+
# Restart on HUP
- local $SIG{HUP} = sub {
+ local $SIG{HUP} = sub {
$restart = 1;
warn "Restarting server on SIGHUP...\n";
};
-
+
LISTEN:
while ( !$restart ) {
- while ( accept( Remote, $daemon ) ) {
+ while ( accept( Remote, $daemon ) ) {
DEBUG && warn "New connection\n";
select Remote;
Remote->blocking(1);
-
+
# Read until we see all headers
$self->{inputbuf} = '';
-
+
if ( !$self->_read_headers ) {
# Error reading, give up
close Remote;
}
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' ) {
# Fork
- if ( $options->{fork} ) {
+ if ( $options->{fork} ) {
if ( $pid = fork ) {
DEBUG && warn "Forked child $pid\n";
next;
}
$self->_handler( $class, $port, $method, $uri, $protocol );
-
- if ( my $error = delete $self->{_write_error} ) {
+
+ if ( $self->_has_write_error ) {
close Remote;
-
+
if ( !defined $pid ) {
next LISTEN;
}
close Remote;
}
}
-
+
$daemon->close;
-
+
DEBUG && warn "Shutting down\n";
if ($restart) {
### those include dirs upon re-exec. So add them to PERL5LIB, so they
### are available again for the exec'ed process --kane
use Config;
- $ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
-
+ $ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
+
exec $^X, $0, @{ $options->{argv} };
}
PATH_INFO => $path || '',
QUERY_STRING => $query_string || '',
REMOTE_ADDR => $sockdata->{peeraddr},
- REMOTE_HOST => $sockdata->{peername},
REQUEST_METHOD => $method || '',
SERVER_NAME => $sockdata->{localname},
SERVER_PORT => $port,
}
# Pass flow control to Catalyst
- $class->handle_request;
+ {
+ # FIXME: don't ignore SIGCHLD while handling requests so system()
+ # et al. work within actions. it might be a little risky to do that
+ # this far out, but then again it's only the dev server anyway.
+ local $SIG{CHLD} = 'DEFAULT';
+
+ $class->handle_request;
+ }
DEBUG && warn "Request done\n";
# Allow keepalive requests, this is a hack but we'll support it until
# the next major release.
- if ( delete $self->{_keepalive} ) {
+ if ( $self->_is_keepalive ) {
+ $self->_clear_keepalive;
DEBUG && warn "Reusing previous connection for keep-alive request\n";
sub _read_headers {
my $self = shift;
-
+
while (1) {
my $read = sysread Remote, my $buf, CHUNKSIZE;
-
+
if ( !defined $read ) {
next if $! == EWOULDBLOCK;
DEBUG && warn "Error reading headers: $!\n";
return;
- }
- elsif ( $read == 0 ) {
+ } elsif ( $read == 0 ) {
DEBUG && warn "EOF\n";
return;
}
-
+
DEBUG && warn "Read $read bytes\n";
$self->{inputbuf} .= $buf;
last if $self->{inputbuf} =~ /(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)/s;
}
-
+
return 1;
}
sub _parse_request_line {
my $self = shift;
- # Parse request line
+ # Parse request line
# Leading CRLF sometimes sent by buggy IE versions
if ( $self->{inputbuf} !~ s/^(?:\x0D\x0A)?(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) {
return ();
}
-
+
my $method = $1;
my $uri = $2;
my $proto = $3 || 'HTTP/0.9';
-
+
return ( $method, $uri, $proto );
}
sub _parse_headers {
my $self = shift;
-
+
# Copy the buffer for header parsing, and remove the header block
# from the content buffer.
my $buf = $self->{inputbuf};
$self->{inputbuf} =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s;
-
+
# Parse headers
my $headers = HTTP::Headers->new;
my ($key, $val);
# This mess is necessary to keep IE from crashing the server
my $data = {
- peername => $iaddr
- ? ( gethostbyaddr( $iaddr, AF_INET ) || 'localhost' )
- : 'localhost',
peeraddr => $iaddr
? ( inet_ntoa($iaddr) || '127.0.0.1' )
: '127.0.0.1',
sub _inet_addr { unpack "N*", inet_aton( $_[0] ) }
+=head2 options
+
+Options hash passed to the http engine to control things like if keepalive
+is supported.
+
=head1 SEE ALSO
L<Catalyst>, L<Catalyst::Engine>
package Catalyst::Engine::HTTP::Restarter;
+use Moose;
+use Moose::Util qw/find_meta/;
+use namespace::clean -except => 'meta';
+
+extends 'Catalyst::Engine::HTTP';
-use strict;
-use warnings;
-use base 'Catalyst::Engine::HTTP';
use Catalyst::Engine::HTTP::Restarter::Watcher;
-use NEXT;
-sub run {
+around run => sub {
+ my $orig = shift;
my ( $self, $class, $port, $host, $options ) = @_;
$options ||= {};
close STDIN;
close STDOUT;
+ # Avoid "Setting config after setup" error restarting MyApp.pm
+ $class->setup_finished(0);
+ # Best effort if we can't trap compiles..
+ $self->_make_components_mutable($class)
+ if !Catalyst::Engine::HTTP::Restarter::Watcher::DETECT_PACKAGE_COMPILATION;
+
my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new(
directory => (
$options->{restart_directory} ||
}
}
- return $self->NEXT::run( $class, $port, $host, $options );
+ return $self->$orig( $class, $port, $host, $options );
+};
+
+# Naive way of trying to avoid Moose blowing up when you re-require components
+# which have been made immutable.
+sub _make_components_mutable {
+ my ($self, $class) = @_;
+
+ my @metas = map { find_meta($_) } ($class, map { blessed($_) } values %{ $class->components });
+
+ foreach my $meta (@metas) {
+ # Paranoia unneeded, all component metaclasses should have immutable
+ $meta->make_mutable if $meta->is_immutable;
+ }
}
1;
package Catalyst::Engine::HTTP::Restarter::Watcher;
-use strict;
-use warnings;
-use base 'Class::Accessor::Fast';
+use Moose;
+with 'MooseX::Emulate::Class::Accessor::Fast';
+
use File::Find;
use File::Modified;
use File::Spec;
use Time::HiRes qw/sleep/;
+use Moose::Util qw/find_meta/;
+use namespace::clean -except => 'meta';
+
+BEGIN {
+ # If we can detect stash changes, then we do magic
+ # to make their metaclass mutable (if they have one)
+ # so that restarting works as expected.
+ eval { require B::Hooks::OP::Check::StashChange; };
+ *DETECT_PACKAGE_COMPILATION = $@
+ ? sub () { 0 }
+ : sub () { 1 }
+}
-__PACKAGE__->mk_accessors(
- qw/delay
- directory
- modified
- regex
- follow_symlinks
- watch_list/
-);
-
-sub new {
- my ( $class, %args ) = @_;
-
- my $self = {%args};
-
- bless $self, $class;
-
- $self->_init;
+has delay => (is => 'rw');
+has regex => (is => 'rw');
+has modified => (is => 'rw');
+has directory => (is => 'rw');
+has watch_list => (is => 'rw');
+has follow_symlinks => (is => 'rw');
- return $self;
+sub BUILD {
+ shift->_init;
}
sub _init {
sub _test {
my ( $self, $file ) = @_;
- delete $INC{$file};
+ my $id;
+ if (DETECT_PACKAGE_COMPILATION) {
+ $id = B::Hooks::OP::Check::StashChange::register(sub {
+ my ($new, $old) = @_;
+ my $meta = find_meta($new);
+ if ($meta) { # A little paranoia here - Moose::Meta::Role has neither of these methods.
+ my $is_immutable = $meta->can('is_immutable');
+ my $make_mutable = $meta->can('make_mutable');
+ $meta->$make_mutable() if $is_immutable && $make_mutable && $meta->$is_immutable();
+ }
+ });
+ }
+
+ delete $INC{$file}; # Remove from %INC so it will reload
local $SIG{__WARN__} = sub { };
open my $olderr, '>&STDERR';
eval "require '$file'";
open STDERR, '>&', $olderr;
+ B::Hooks::OP::Check::StashChange::unregister($id) if $id;
+
return ($@) ? $@ : 0;
}
Returns a list of files that have been added, deleted, or changed since the
last time watch was called.
+=head2 DETECT_PACKAGE_COMPILATION
+
+Returns true if L<B::Hooks::OP::Check::StashChange> is installed and
+can be used to detect when files are compiled. This is used internally
+to make the L<Moose> metaclass of any class being reloaded immutable.
+
+If L<B::Hooks::OP::Check::StashChange> is not installed, then the
+restarter makes all application components immutable. This covers the
+simple case, but is less useful if you're using Moose in components
+outside Catalyst's namespaces, but inside your application directory.
+
=head1 SEE ALSO
L<Catalyst>, L<Catalyst::Engine::HTTP::Restarter>, L<File::Modified>
package Catalyst::Exception;
-use strict;
-use vars qw[@ISA $CATALYST_EXCEPTION_CLASS];
-
-BEGIN {
- push( @ISA, $CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base' );
-}
+# XXX: See bottom of file for Exception implementation
package Catalyst::Exception::Base;
-use strict;
+use Moose;
use Carp ();
=head1 NAME
Carp::croak($message);
}
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHORS
Catalyst Contributors, see Catalyst.pm
=cut
+Catalyst::Exception::Base->meta->make_immutable;
+
+package Catalyst::Exception;
+
+use Moose;
+use vars qw[$CATALYST_EXCEPTION_CLASS];
+
+BEGIN {
+ extends($CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base');
+}
+
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::Log;
-use strict;
-use base 'Class::Accessor::Fast';
+use Moose;
+with 'MooseX::Emulate::Class::Accessor::Fast';
+
use Data::Dump;
+use Class::MOP ();
our %LEVELS = ();
-__PACKAGE__->mk_accessors('level');
-__PACKAGE__->mk_accessors('body');
-__PACKAGE__->mk_accessors('abort');
+has level => (is => 'rw');
+has _body => (is => 'rw');
+has abort => (is => 'rw');
{
my @levels = qw[ debug info warn error fatal ];
+ my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__);
for ( my $i = 0 ; $i < @levels ; $i++ ) {
my $name = $levels[$i];
$LEVELS{$name} = $level;
- no strict 'refs';
-
- *{$name} = sub {
+ $meta->add_method($name, sub {
my $self = shift;
- if ( $self->{level} & $level ) {
+ if ( $self->level & $level ) {
$self->_log( $name, @_ );
}
- };
+ });
- *{"is_$name"} = sub {
+ $meta->add_method("is_$name", sub {
my $self = shift;
- return $self->{level} & $level;
- };
+ return $self->level & $level;
+ });;
}
}
-sub new {
+around new => sub {
+ my $orig = shift;
my $class = shift;
- my $self = $class->SUPER::new;
+ my $self = $class->$orig;
$self->levels( scalar(@_) ? @_ : keys %LEVELS );
return $self;
-}
+};
sub levels {
my ( $self, @levels ) = @_;
sub enable {
my ( $self, @levels ) = @_;
- $self->{level} |= $_ for map { $LEVELS{$_} } @levels;
+ my $level = $self->level;
+ for(map { $LEVELS{$_} } @levels){
+ $level |= $_;
+ }
+ $self->level($level);
}
sub disable {
my ( $self, @levels ) = @_;
- $self->{level} &= ~$_ for map { $LEVELS{$_} } @levels;
+ my $level = $self->level;
+ for(map { $LEVELS{$_} } @levels){
+ $level &= ~$_;
+ }
+ $self->level($level);
}
sub _dump {
my $level = shift;
my $message = join( "\n", @_ );
$message .= "\n" unless $message =~ /\n$/;
- $self->{body} .= sprintf( "[%s] %s", $level, $message );
+ my $body = $self->_body;
+ $body .= sprintf( "[%s] %s", $level, $message );
+ $self->_body($body);
}
sub _flush {
my $self = shift;
- if ( $self->abort || !$self->body ) {
+ if ( $self->abort || !$self->_body ) {
$self->abort(undef);
}
else {
- $self->_send_to_log( $self->body );
+ $self->_send_to_log( $self->_body );
}
- $self->body(undef);
+ $self->_body(undef);
}
sub _send_to_log {
print STDERR @_;
}
+no Moose;
+__PACKAGE__->meta->make_immutable();
+
1;
__END__
$log = Catalyst::Log->new;
$log = Catalyst::Log->new( 'warn', 'error' );
+=head2 level
+
+Contains a bitmask of the currently set log levels.
+
=head2 levels
Set log levels
You may subclass this module and override this method to get finer control
over the log output.
+=head2 meta
+
=head1 SEE ALSO
L<Catalyst>.
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
Mailing-Lists:
- http://lists.rawmode.org/mailman/listinfo/catalyst
- http://lists.rawmode.org/mailman/listinfo/catalyst-dev
+ http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst
+ http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
=head1 AUTHORS
already been installed, complete with database engines and a full
complement of Catalyst plugins.
+=item *
+
+Frank Speiser's Amazon EC2 Catalyst SDK
+
+There are currently two flavors of publicly available Amazon Machine
+Images (AMI) that contain all the dependencies you'd need to get a
+Catalyst development environment,with all the trimmings, up and
+running within minutes.
+
+Once you obtain an Amazon Elastic Cloud Computing account available
+here:
+L<http://www.amazon.com/EC2-AWS-Service-Pricing/b/ref=sc_fe_l_2?ie=UTF8&node=201590011>,
+you can literally get a Catalyst development instance up and running
+in less than 5 minutes.
+
+The current AMIs that are available are here in abbreviated form:
+
+ IMAGE ami-bdbe5ad4 developer-tools/Debian-Etch_Catalyst_DBIC_TT.manifest.xml
+ IMAGE ami-9fbe5af6 developer-tools/Fedora8-Catalyst_DBIC_TT.manifest.xml
+
+You can run the instances according to the Amazon documentation, as follows:
+
+ ec2-run-instances <ami here> -k gsg-keypair
+
+Refer to the Amazon EC2 documentation from the "Amazon Web Services"
+section of the L<Amazon.com| Amazon.com> web site for further
+assistance.
+
+You can currently choose between ready-made SDKs on Fedora8 and Debian
+Etch. Both machine images include Catalyst, DBIx::Class,
+Template::Toolkit, Moose, the mysql and postgresql databases, as well
+as subversion source control. The Debian Etch machine instance also
+includes svk and git.
+
+Just run the installation instructions contained in this manual and
+go.
+
=back
=head2 OTHER METHODS
command to check the status of the packages listed in <cat-install>. Ideally,
everything should return a I<name> C<is up to date> message. If any packages
try to re-install, the you could need to manually install the package with the
-C<force> option. Also, look for new optional dependences that C<cat-install>
+C<force> option. Also, look for new optional dependencies that C<cat-install>
was not able to automatically handle. You can address these by manually
installing the dependency and then re-running C<perl cat-install>.
package Catalyst::Model;
-use strict;
-use base qw/Catalyst::Component/;
+use Moose;
+extends qw/Catalyst::Component/;
+
+no Moose;
=head1 NAME
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
=head1 ROADMAP
-This is a living document, that represents the core team's current plans
-for the Catalyst framework. It's liable to change at any time. This document
-lives in the the catalyst trunk, currently at
+This is a living document, that represents the core team's current plans for
+the Catalyst framework. It's liable to change at any time. This document lives
+in the the catalyst trunk, currently at
- http://dev.catalyst.perl.org/repos/Catalyst/trunk/Catalyst/lib/Catalyst/ROADMAP.pod
+ http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/5.80/trunk/lib/Catalyst/ROADMAP.pod
Make sure you get it from there to ensure you have the latest version.
-=head2 5.7x series
+=head2 5.80000 1st Quarter 2009
-Stable relases, no major features planned. Bugfixes for current release
-and documentation improvements.
+Next major planned release, ports Catalyst to Moose, and does some refactoring
+to help app/ctx.
-Will be working on developing more ActionClasses, and Reusable chained
-controllers, as well as opinonated highlevel frameworks on top of the
-Catalyst Core.
+=head2 5.81000
-=head3 5.7.1
+=over
-=over 4
+=item Reduce core class data usage.
-=item make deployment of Catalyst easier
+Refactor everything that doesn't have to be class data into object data
-=over 4
+=item Work towards a declarative syntax mode
-=item Add htaccess files to distro
+Dispatcher refactoring to provide alternatives to deprecated methods, and
+support for pluggable dispatcher builders (so that attributes can be
+replaced).
-=item Trim runtime dependencies
+=item MyApp should not ISA Catalyst::Controller
-=item test dependency graph, make sure everything installs cleanly on different platforms.
+=over
-=back
+=item *
-=item Add support for configuration profiles to be selected at startup time
-through switches / ENV
+Update Test suite to not assume MyApp ISA Controller
-=item add call method to do a forward with eval case.
+=item *
-=item add go method to do a call while setting action.
-
-=item move all inline pod to bottom of file.
-
-=item update pod coverage tests to detect stubbed pod, ensure real coverage
+After that set up attr handlers that will output helpful error messages when
+you do it as well as how to fix it.
=back
-=head2 5.80000 4. Quarter 2006
+=back
-Next major planned release.
+=head2 5.82000
-=over 4
+=over
-=item Application / Context Split
+=item Extend pluggability of the Catalyst core.
-Catalyst needs to be split so that $c refers to the current context, and is a separate thing from the Application class.
+good support for reusable components good support for reusable plugins good
+separation of plugins (some reusable components want different plugins) near
+total engine independence
-=item Extend pluggability of the Catalyst core.
+=back
-good support for reusable components good support for reusable plugins good
-separation of plugins (some reusable components want different plugins)
-near total engine independence
+=head2 5.90000
-=item Moose roles instead of NEXT.
+=over
-Change the Catalyst core to use Moose for the plugin system as well as
-accessors/constructors.
+=item Application / Context Split
-=item Reduce core class data usage.
+Catalyst needs to be split so that $c refers to the current context, and is a
+separate thing from the Application class.
-Refactor everything that doesn't have to be class data into object data
+=back
-=item Add support for Isotope Engines
+=head2 Wishlist
-This depends on the progress of Isotope
+=over
-=item Work towards a declarative syntax mode
+=item move all inline pod to bottom of file.
-=back
-
-=head2 5.90000 2007
+=item update pod coverage tests to detect stubbed pod, ensure real coverage
-Blue Sky. Will start planning this once we land 5.8 :)
+=item Add support for configuration profiles to be selected at startup time
+through switches / ENV
+=back
package Catalyst::Request;
-use strict;
-use base 'Class::Accessor::Fast';
-
use IO::Socket qw[AF_INET inet_aton];
use Carp;
use utf8;
use URI::http;
use URI::https;
use URI::QueryParam;
+use HTTP::Headers;
+
+use Moose;
+
+use namespace::clean -except => 'meta';
+
+with 'MooseX::Emulate::Class::Accessor::Fast';
+
+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', predicate => 'has_uri');
+has user => (is => 'rw');
+has headers => (
+ is => 'rw',
+ isa => 'HTTP::Headers',
+ handles => [qw(content_encoding content_length content_type header referer user_agent)],
+ default => sub { HTTP::Headers->new() },
+ required => 1,
+ lazy => 1,
+);
+
+# Moose TODO:
+# - Can we lose the before modifiers which just call prepare_body ?
+# they are wasteful, slow us down and feel cluttery.
+# Can we call prepare_body at BUILD time?
+# Can we make _body an attribute, have the rest of
+# these lazy build from there and kill all the direct hash access
+# in Catalyst.pm and Engine.pm?
+
+has _context => (
+ is => 'rw',
+ weak_ref => 1,
+ handles => ['read'],
+ clearer => '_clear_context',
+);
+
+has body_parameters => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub { {} },
+);
+
+before body_parameters => sub {
+ my ($self) = @_;
+ $self->_context->prepare_body();
+};
-__PACKAGE__->mk_accessors(
- qw/action address arguments cookies headers query_keywords match method
- protocol query_parameters secure captures uri user/
+has uploads => (
+ is => 'rw',
+ required => 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(@_) }
+has parameters => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub { {} },
+);
+
+before parameters => sub {
+ my ($self, $params) = @_;
+ 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;
+ return $self->path if $self->has_uri;
+ },
+);
+
+has _body => (
+ is => 'rw', clearer => '_clear_body', predicate => '_has_body',
+);
+# Eugh, ugly. Should just be able to rename accessor methods to 'body'
+# and provide a custom reader..
+sub body {
+ my $self = shift;
+ $self->_context->prepare_body();
+ $self->_body(@_) if scalar @_;
+ return blessed $self->_body ? $self->_body->body : $self->_body;
+}
+
+has hostname => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+ gethostbyaddr( inet_aton( $self->address ), AF_INET ) || 'localhost'
+ },
+);
+
+has _path => ( is => 'rw', predicate => '_has_path', clearer => '_clear_path' );
+
+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
and the URI for the request was C<http://.../foo/moose/bah>, the string C<bah>
would be the first and only argument.
+Arguments just get passed through and B<don't> get unescaped automatically, so
+you should do that explicitly.
+
=head2 $req->args
Shortcut for arguments.
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
print $c->request->body_parameters->{field}->[0];
These are the parameters from the POST part of the request, if any.
-
+
=head2 $req->body_params
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.
=head2 $req->hostname
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
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.
=head2 $req->path_info
-Alias for path, added for compability with L<CGI>.
+Alias for path, added for compatibility with L<CGI>.
=cut
if (@params) {
$self->uri->path(@params);
- undef $self->{path};
+ $self->_clear_path;
}
- elsif ( defined( my $path = $self->{path} ) ) {
- return $path;
+ elsif ( $self->_has_path ) {
+ return $self->_path;
}
else {
my $path = $self->uri->path;
my $location = $self->base->path;
$path =~ s/^(\Q$location\E)?//;
$path =~ s/^\///;
- $self->{path} = $path;
+ $self->_path($path);
return $path;
}
You have to set MyApp->config->{parse_on_demand} to use this directly.
-=cut
-
-sub read { shift->{_context}->read(@_); }
-
=head2 $req->referer
Shortcut for $req->headers->referer. Returns the referring page.
=head2 $req->captures
-Returns a reference to an array containing regex captures.
+Returns a reference to an array containing captured args from chained
+actions or regex captures.
my @captures = @{ $c->request->captures };
=head2 $req->snippets
-C<captures> used to be called snippets. This is still available for backwoards
+C<captures> used to be called snippets. This is still available for backwards
compatibility, but is considered deprecated.
=head2 $req->upload
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
Catalyst Contributors, see Catalyst.pm
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::Request::Upload;
-use strict;
-use base 'Class::Accessor::Fast';
+use Moose;
+with 'MooseX::Emulate::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/);
+has filename => (is => 'rw');
+has headers => (is => 'rw');
+has size => (is => 'rw');
+has tempname => (is => 'rw');
+has type => (is => 'rw');
+has basename => (is => 'ro', lazy_build => 1);
+
+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;
+ },
+);
+
+sub _build_basename {
+ my $self = shift;
+ my $basename = $self->filename;
+ $basename =~ s|\\|/|g;
+ $basename = ( File::Spec::Unix->splitpath($basename) )[2];
+ $basename =~ s|[^\w\.-]+|_|g;
+ return $basename;
+}
-sub new { shift->SUPER::new( ref( $_[0] ) ? $_[0] : {@_} ) }
+no Moose;
=head1 NAME
=head1 SYNOPSIS
+ my $upload = $c->req->upload('field');
+
$upload->basename;
$upload->copy_to;
$upload->fh;
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.
return $content;
}
-sub basename {
- my $self = shift;
- unless ( $self->{basename} ) {
- my $basename = $self->filename;
- $basename =~ s|\\|/|g;
- $basename = ( File::Spec::Unix->splitpath($basename) )[2];
- $basename =~ s|[^\w\.-]+|_|g;
- $self->{basename} = $basename;
- }
-
- return $self->{basename};
-}
-
=head2 $upload->basename
Returns basename for C<filename>.
Returns the client-supplied Content-Type.
+=head2 meta
+
+Provided by Moose
+
=head1 AUTHORS
Catalyst Contributors, see Catalyst.pm
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::Response;
-use strict;
-use base 'Class::Accessor::Fast';
-
-__PACKAGE__->mk_accessors(qw/cookies body headers location status/);
-
-*output = \&body;
-
-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(@_) }
+use Moose;
+use HTTP::Headers;
+
+with 'MooseX::Emulate::Class::Accessor::Fast';
+
+has cookies => (is => 'rw', default => sub { {} });
+has body => (is => 'rw', default => '', lazy => 1, predicate => 'has_body');
+has location => (is => 'rw');
+has status => (is => 'rw', default => 200);
+has finalized_headers => (is => 'rw', default => 0);
+has headers => (
+ is => 'rw',
+ handles => [qw(content_encoding content_length content_type header)],
+ default => sub { HTTP::Headers->new() },
+ required => 1,
+ lazy => 1,
+);
+has _context => (
+ is => 'rw',
+ weak_ref => 1,
+ handles => ['write'],
+ clearer => '_clear_context',
+);
+
+sub output { shift->body(@_) }
+
+no Moose;
=head1 NAME
in the same fashion), or a filehandle GLOB. Catalyst
will write it piece by piece into the response.
+=head2 $res->has_body
+
+Predicate which returns true when a body has been set.
+
=head2 $res->content_encoding
Shortcut for $res->headers->content_encoding.
return $self->location;
}
+=head2 $res->location
+
+Sets or returns the HTTP 'Location'.
+
=head2 $res->status
Sets or returns the HTTP status.
Writes $data to the output stream.
+=head2 meta
+
+Provided by Moose
+
+=head2 $res->print( @data )
+
+Prints @data to the output stream, separated by $,. This lets you pass
+the response object to functions that want to write to an L<IO::Handle>.
+
=cut
-sub write { shift->{_context}->write(@_); }
+sub print {
+ my $self = shift;
+ my $data = shift;
+
+ defined $self->write($data) or return;
+
+ for (@_) {
+ defined $self->write($,) or return;
+ defined $self->write($_) or return;
+ }
+
+ return 1;
+}
=head1 AUTHORS
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
# Remember to update this in Catalyst as well!
-our $VERSION='5.71000';
+our $VERSION='5.8000_06';
-$VERSION= eval $VERSION;
+$VERSION = eval $VERSION;
=head1 NAME
package Catalyst::Stats;
-use strict;
-use warnings;
+use Moose;
use Time::HiRes qw/gettimeofday tv_interval/;
use Text::SimpleTable ();
use Catalyst::Utils;
use Tree::Simple qw/use_weak_refs/;
use Tree::Simple::Visitor::FindByUID;
-sub new {
- my $class = shift;
+use namespace::clean -except => 'meta';
- my $root = Tree::Simple->new({t => [gettimeofday]});
- bless {
- enabled => 1,
- stack => [ $root ],
- tree => $root,
- }, ref $class || $class;
-}
-
-sub enable {
- my ($self, $enable) = @_;
-
- $self->{enabled} = $enable;
-}
+has enable => (is => 'rw', required => 1, default => sub{ 1 });
+has tree => (
+ is => 'ro',
+ required => 1,
+ default => sub{ Tree::Simple->new({t => [gettimeofday]}) },
+ handles => [qw/ accept traverse /],
+ );
+has stack => (
+ is => 'ro',
+ required => 1,
+ lazy => 1,
+ default => sub { [ shift->tree ] }
+ );
sub profile {
my $self = shift;
- return unless $self->{enabled};
+ return unless $self->enable;
my %params;
if (@_ <= 1) {
- $params{comment} = shift || "";
+ $params{comment} = shift || "";
}
elsif (@_ % 2 != 0) {
- die "profile() requires a single comment parameter or a list of name-value pairs; found "
- . (scalar @_) . " values: " . join(", ", @_);
+ die "profile() requires a single comment parameter or a list of name-value pairs; found "
+ . (scalar @_) . " values: " . join(", ", @_);
}
else {
- (%params) = @_;
- $params{comment} ||= "";
+ (%params) = @_;
+ $params{comment} ||= "";
}
my $parent;
my $prev;
my $t = [ gettimeofday ];
+ my $stack = $self->stack;
if ($params{end}) {
- # parent is on stack; search for matching block and splice out
- for (my $i = $#{$self->{stack}}; $i > 0; $i--) {
- if ($self->{stack}->[$i]->getNodeValue->{action} eq $params{end}) {
- my $node = $self->{stack}->[$i];
- splice(@{$self->{stack}}, $i, 1);
- # Adjust elapsed on partner node
- my $v = $node->getNodeValue;
- $v->{elapsed} = tv_interval($v->{t}, $t);
- return $node->getUID;
+ # parent is on stack; search for matching block and splice out
+ for (my $i = $#{$stack}; $i > 0; $i--) {
+ if ($stack->[$i]->getNodeValue->{action} eq $params{end}) {
+ my ($node) = splice(@{$stack}, $i, 1);
+ # Adjust elapsed on partner node
+ my $v = $node->getNodeValue;
+ $v->{elapsed} = tv_interval($v->{t}, $t);
+ return $node->getUID;
+ }
}
- }
# if partner not found, fall through to treat as non-closing call
}
if ($params{parent}) {
- # parent is explicitly defined
- $prev = $parent = $self->_get_uid($params{parent});
+ # parent is explicitly defined
+ $prev = $parent = $self->_get_uid($params{parent});
}
if (!$parent) {
- # Find previous node, which is either previous sibling or parent, for ref time.
- $prev = $parent = $self->{stack}->[-1] or return undef;
- my $n = $parent->getChildCount;
- $prev = $parent->getChild($n - 1) if $n > 0;
+ # Find previous node, which is either previous sibling or parent, for ref time.
+ $prev = $parent = $stack->[-1] or return undef;
+ my $n = $parent->getChildCount;
+ $prev = $parent->getChild($n - 1) if $n > 0;
}
my $node = Tree::Simple->new({
- action => $params{begin} || "",
- t => $t,
- elapsed => tv_interval($prev->getNodeValue->{t}, $t),
- comment => $params{comment},
+ action => $params{begin} || "",
+ t => $t,
+ elapsed => tv_interval($prev->getNodeValue->{t}, $t),
+ comment => $params{comment},
});
$node->setUID($params{uid}) if $params{uid};
$parent->addChild($node);
- push(@{$self->{stack}}, $node) if $params{begin};
+ push(@{$stack}, $node) if $params{begin};
return $node->getUID;
}
my $column_width = Catalyst::Utils::term_width() - 9 - 13;
my $t = Text::SimpleTable->new( [ $column_width, 'Action' ], [ 9, 'Time' ] );
my @results;
- $self->{tree}->traverse(
+ $self->traverse(
sub {
my $action = shift;
my $stat = $action->getNodeValue;
$stat->{elapsed},
$stat->{action} ? 1 : 0,
);
- $t->row( ( q{ } x $r[0] ) . $r[1],
- defined $r[2] ? sprintf("%fs", $r[2]) : '??');
+ # Trim down any times >= 10 to avoid ugly Text::Simple line wrapping
+ my $elapsed = substr(sprintf("%f", $stat->{elapsed}), 0, 8) . "s";
+ $t->row( ( q{ } x $r[0] ) . $r[1],
+ defined $r[2] ? $elapsed : '??');
push(@results, \@r);
}
);
my $visitor = Tree::Simple::Visitor::FindByUID->new;
$visitor->searchForUID($uid);
- $self->{tree}->accept($visitor);
+ $self->accept($visitor);
return $visitor->getResult;
}
-
-sub accept {
- my $self = shift;
- $self->{tree}->accept( @_ );
-}
-
sub addChild {
my $self = shift;
my $node = $_[ 0 ];
$stat->{ elapsed } =~ s{s$}{};
}
- $self->{tree}->addChild( @_ );
+ $self->tree->addChild( @_ );
}
sub setNodeValue {
$stat->{ elapsed } =~ s{s$}{};
}
- $self->{tree}->setNodeValue( @_ );
+ $self->tree->setNodeValue( @_ );
}
sub getNodeValue {
my $self = shift;
- $self->{tree}->getNodeValue( @_ )->{ t };
+ $self->tree->getNodeValue( @_ )->{ t };
}
-sub traverse {
- my $self = shift;
- $self->{tree}->traverse( @_ );
-}
+__PACKAGE__->meta->make_immutable();
1;
The 'rollup' flag indicates whether the reported time is the rolled up time for
the block, or the elapsed time from the previous profiling point.
-=head1 COMPATABILITY METHODS
+=head1 COMPATIBILITY METHODS
Some components might expect the stats object to be a regular Tree::Simple object.
-We've added some compatability methods to handle this scenario:
+We've added some compatibility methods to handle this scenario:
=head2 accept
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
use strict;
use warnings;
+use Test::More ();
use Catalyst::Exception;
use Catalyst::Utils;
-use Class::Inspector;
+use Class::MOP;
+use Sub::Exporter;
+
+my $build_exports = sub {
+ my ($self, $meth, $args, $defaults) = @_;
+
+ my $request;
+ my $class = $args->{class};
+
+ if ( $ENV{CATALYST_SERVER} ) {
+ $request = sub { remote_request(@_) };
+ } elsif (! $class) {
+ $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") };
+ } else {
+ unless (Class::MOP::is_class_loaded($class)) {
+ Class::MOP::load_class($class);
+ }
+ $class->import;
+
+ $request = sub { local_request( $class, @_ ) };
+ }
+
+ my $get = sub { $request->(@_)->content };
+
+ my $crequest = sub {
+ my $me = ref $self || $self;
+
+ ### throw an exception if crequest is being used against a remote
+ ### server
+ Catalyst::Exception->throw("$me only works with local requests, not remote")
+ if $ENV{CATALYST_SERVER};
+
+ ### place holder for $c after the request finishes; reset every time
+ ### requests are done.
+ my $c;
+
+ ### hook into 'dispatch' -- the function gets called after all plugins
+ ### have done their work, and it's an easy place to capture $c.
+ no warnings 'redefine';
+ my $dispatch = Catalyst->can('dispatch');
+ local *Catalyst::dispatch = sub {
+ $c = shift;
+ $dispatch->( $c, @_ );
+ };
+
+ ### do the request; C::T::request will know about the class name, and
+ ### we've already stopped it from doing remote requests above.
+ my $res = $request->( @_ );
+
+ ### return both values
+ return ( $res, $c );
+ };
+
+ return {
+ request => $request,
+ get => $get,
+ crequest => $crequest,
+ content_like => sub {
+ my $action = shift;
+ return Test::More->builder->like($get->($action),@_);
+ },
+ action_ok => sub {
+ my $action = shift;
+ return Test::More->builder->ok($request->($action)->is_success, @_);
+ },
+ action_redirect => sub {
+ my $action = shift;
+ return Test::More->builder->ok($request->($action)->is_redirect,@_);
+ },
+ action_notfound => sub {
+ my $action = shift;
+ return Test::More->builder->is_eq($request->($action)->code,404,@_);
+ },
+ contenttype_is => sub {
+ my $action = shift;
+ my $res = $request->($action);
+ return Test::More->builder->is_eq(scalar($res->content_type),@_);
+ },
+ };
+};
+
+our $default_host;
+
+{
+ my $import = Sub::Exporter::build_exporter({
+ groups => [ all => $build_exports ],
+ into_level => 1,
+ });
+
+
+ sub import {
+ my ($self, $class, $opts) = @_;
+ $import->($self, '-all' => { class => $class });
+ $opts = {} unless ref $opts eq 'HASH';
+ $default_host = $opts->{default_host} if exists $opts->{default_host};
+ return 1;
+ }
+}
=head1 NAME
package main;
- use Test::More tests => 1;
use Catalyst::Test 'TestApp';
+ use Test::More tests => 1;
ok( get('/foo') =~ /bar/ );
+ # mock virtual hosts
+ use Catalyst::Test 'MyApp', { default_host => 'myapp.com' };
+ like( get('/whichhost'), qr/served by myapp.com/ );
+ like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by yourapp.com/ );
+ {
+ local $Catalyst::Test::default_host = 'otherapp.com';
+ like( get('/whichhost'), qr/served by otherapp.com/ );
+ }
+
=head1 DESCRIPTION
This module allows you to make requests to a Catalyst application either without
a server, by simulating the environment of an HTTP request using
L<HTTP::Request::AsCGI> or remotely if you define the CATALYST_SERVER
-environment variable.
+environment variable. This module also adds a few catalyst
+specific testing methods as displayed in the method section.
The </get> and </request> functions take either a URI or an L<HTTP::Request>
object.
=head2 $res = request( ... );
-Returns a C<HTTP::Response> object.
+Returns a C<HTTP::Response> object. Accepts an optional hashref for request
+header configuration; currently only supports setting 'host' value.
my $res = request('foo/bar?test=1');
+ my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'});
=head1 FUNCTIONS
Works exactly like C<Catalyst::Test::request>, except it also returns the
catalyst context object, C<$c>. Note that this only works for local requests.
-=cut
-
-sub import {
- my $self = shift;
- my $class = shift;
-
- my ( $get, $request );
-
- if ( $ENV{CATALYST_SERVER} ) {
- $request = sub { remote_request(@_) };
- $get = sub { remote_request(@_)->content };
- } elsif (! $class) {
- $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") };
- $get = $request;
- } else {
- unless( Class::Inspector->loaded( $class ) ) {
- require Class::Inspector->filename( $class );
- }
- $class->import;
-
- $request = sub { local_request( $class, @_ ) };
- $get = sub { local_request( $class, @_ )->content };
- }
-
- no strict 'refs';
- my $caller = caller(0);
-
- *{"$caller\::request"} = $request;
- *{"$caller\::get"} = $get;
- *{"$caller\::crequest"} = sub {
- my $me = ref $self || $self;
-
- ### throw an exception if crequest is being used against a remote
- ### server
- Catalyst::Exception->throw("$me only works with local requests, not remote")
- if $ENV{CATALYST_SERVER};
-
- ### place holder for $c after the request finishes; reset every time
- ### requests are done.
- my $c;
-
- ### hook into 'dispatch' -- the function gets called after all plugins
- ### have done their work, and it's an easy place to capture $c.
- no warnings 'redefine';
- my $dispatch = Catalyst->can('dispatch');
- local *Catalyst::dispatch = sub {
- $c = shift;
- $dispatch->( $c, @_ );
- };
-
- ### do the request; C::T::request will know about the class name, and
- ### we've already stopped it from doing remote requests above.
- my $res = $request->( @_ );
-
- ### return both values
- return ( $res, $c );
- };
-}
-
=head2 $res = Catalyst::Test::local_request( $AppClass, $url );
Simulate a request using L<HTTP::Request::AsCGI>.
require HTTP::Request::AsCGI;
my $request = Catalyst::Utils::request( shift(@_) );
+ _customize_request($request, @_);
my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
$class->handle_request;
my $request = Catalyst::Utils::request( shift(@_) );
my $server = URI->new( $ENV{CATALYST_SERVER} );
+ _customize_request($request, @_);
+
if ( $server->path =~ m|^(.+)?/$| ) {
my $path = $1;
$server->path("$path") if $path; # need to be quoted
return $agent->request($request);
}
+sub _customize_request {
+ my $request = shift;
+ my $opts = pop(@_) || {};
+ $opts = {} unless ref($opts) eq 'HASH';
+ if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host ) {
+ $request->header( 'Host' => $host );
+ }
+}
+
+=head2 action_ok
+
+Fetches the given url and check that the request was successful
+
+=head2 action_redirect
+
+Fetches the given url and check that the request was a redirect
+
+=head2 action_notfound
+
+Fetches the given url and check that the request was not found
+
+=head2 content_like
+
+Fetches the given url and matches the content against it.
+
+=head2 contenttype_is
+
+Check for given mime type
+
=head1 SEE ALSO
L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
--- /dev/null
+=head1 Upgrading to Catalyst 5.80
+
+Most applications and plugins should run unaltered on Catalyst 5.80.
+
+However as a lot of refactoring work has taken place, and several changes have
+been made which could cause incompatibilities. If your application or plugin
+is using deprecated code, or relying on side-effects, then you could have
+issues upgrading to this release.
+
+Most issues found with pre-existing components have been easy to solve, and a
+complete description of behaviour changes which may cause compatibility issues,
+or warnings which are now emitted is included below to help if you have problems.
+
+If you think you have found an upgrade related issue which is not covered in
+this document, then please email the Catalyst list to discuss the problem.
+
+=head1 Known backwards compatibility breakages.
+
+=head2 Components which inherit from Moose::Object before Catalyst::Component
+
+Moose components which say:
+
+ package TestApp::Controller::Example;
+ use Moose;
+ extends qw/Moose::Object Catalyst::Component/;
+
+to use the constructor provided by Moose, whilst working (if you do some hacks
+with the C< BUILDARGS > method), will not work with Catalyst 5.80 as
+C<Catalyst::Component> inherits from C<Moose::Object>, and so C< @ISA > fails
+to linearise.
+
+The fix for this is to not inherit directly from C<Moose::Object>
+yourself. Having components which do not inherit their constructor from
+C<Catalyst::Component> is B<unsupported>, and has never been recommended,
+therefore you're on your own if you're using this technique. You'll need
+to detect the version of Catalyst your application is running with and deal
+with it appropriately.
+
+You will also see this issue if you do the following:
+
+ package TestApp::Controller::Example;
+ use Moose;
+ use base 'Catalyst::Controller';
+
+as C< use base > appends to @ISA.
+
+The correct way to use Moose in a component in a both forward and backwards
+compatible way is:
+
+ package TestApp::Controller::Root;
+ use Moose;
+ BEGIN { extends 'Catalyst::Component' }; # Or ::Controller, or whatever
+
+Note that the C< extends > declaration needs to occur in a begin block for
+L<attributes> to operate correctly. You also don't get the L<Moose::Object>
+constructor, and therefore attribute initialization will not work as normally
+expected. If you want to use Moose attributes, then they need to be made lazy
+to correctly initialize.
+
+=head3 use Moose in MyApp
+
+Similar to the above, this will also fail:
+
+ package MyApp;
+ use Moose;
+ use Catalyst qw/
+ ConfigLoader
+ /;
+ __PACKAGE__->setup;
+
+If you need to use Moose in your application class (e.g. for method modifiers
+etc) then the correct technique is:
+
+ package MyApp;
+ use Moose;
+ extends 'Catalyst';
+ __PACKAGE__->setup(qw/
+ ConfigLoader
+ /);
+
+=head2 Anonymous closures installed directly into the symbol table
+
+If you have any code which installs anonymous subroutine references directly
+into the symbol table, you may encounter breakages. The simplest solution is
+to use L<Sub::Name> to name the subroutine. Example:
+
+ # Original code, likely to break:
+ my $full_method_name = join('::', $package_name, $method_name);
+ *$full_method_name = sub { ... };
+
+ # Fixed Code
+ use Sub::Name 'subname';
+ my $full_method_name = join('::',$package_name, $method_name);
+ *$full_method_name = subname $full_method_name, sub { ... };
+
+Additionally, you can take advantage of Catalysts use of L<Class::MOP> and
+install the closure using the appropriate metaclass. Example:
+
+ use Class::MOP;
+ my $metaclass = Moose::Meta::Class->initialize($package_name);
+ $metaclass->add_method($method_name => sub { ... });
+
+=head2 Hooking into application setup
+
+To execute code during application startup the following snippet in MyApp.pm
+used to work:
+
+ sub setup {
+ my ($class, @args) = @_;
+ $class->NEXT::setup(@args);
+ ... # things to do after the actual setup
+ }
+
+With Catalyst 5.80 this won't work anymore. Due to the fact that Catalyst is
+no longer using NEXT.pm for method resolution, this no longer works. The
+functionality was only ever originally operational as L<NEXT> remembers what
+methods have already been called, and will not call them again.
+
+Using this now causes infinite recursion between MyApp::setup and
+Catalyst::setup, due to other backwards compatibility issues related to how
+plugin setup works. Moose method modifiers like C<< before|after|around 'setup
+=> sub { ... }; >> also will not operate correctly on the setup method.
+
+The right way to do it is this:
+
+ after setup_finalize => sub {
+ ... # things to do after the actual setup
+ };
+
+The setup_finalize hook was introduced as a way to void this issue.
+
+=head2 Components with a new method which returns false
+
+Previously, if you had a component which inherited from Catalyst::COMPONENT,
+but overrode the new method to return false, then your class' configuration
+would be blessed into a hash on your behalf, and this would be returned from
+the COMPONENT method.
+
+This behaviour makes no sense, and so has been removed. Implementing your own
+C< new > method in components is B<highly> discouraged, instead, you should
+inherit the new method from Catalyst::Component, and use Mooses BUILD
+functionality and/or Moose attributes to perform any construction work
+necessary for your class.
+
+=head2 __PACKAGE__->mk_accessor('meta');
+
+Won't work due to a limitation of L<Moose>. This is currently being fixed
+inside Moose.
+
+=head2 Class::Data::Inheritable side effects
+
+Previously, writing to a class data accessor would copy the accessor method
+down into your package.
+
+This behaviour has been removed. Whilst the class data is still stored
+per-class, it is stored on the metaclass of the class defining the accessor.
+
+Therefore anything relying on the side-effect of the accessor being copied down
+will be broken.
+
+The following test demonstrates the problem:
+
+ {
+ package BaseClass;
+ use base qw/Class::Data::Inheritable/;
+ __PACKAGE__->mk_classdata('foo');
+ }
+
+ {
+ package Child;
+ use base qw/BaseClass/;
+ }
+
+ BaseClass->foo('base class');
+ Child->foo('sub class');
+
+ use Test::More;
+ isnt(BaseClass->can('foo'), Child->can('foo'));
+
+=head2 Extending Catalyst::Request or other classes in an ad-hoc manor using mk_accessors
+
+Previously, it was possible to add additional accessors to Catalyst::Request
+(or other classes) by calling the mk_accessors class method.
+
+This is no longer supported - users should make a sub-class of the class whose
+behaviour they would like to change, rather than globally polluting the
+Catalyst objects.
+
+=head2 Confused multiple inheritance with Catalyst::Component::COMPONENT
+
+Previously, Catalyst's COMPONENT method would delegate to the method on the
+right hand side, which could then delegate back again with NEXT. This (as it
+is insane AND makes no sense with C3 method dispatch order), and is therefore
+no longer supported.
+
+If a COMPONENT method is detected in the inheritance hierarchy to the right
+hand side of Catalyst::Component::COMPONENT, then the following warning
+message will be emitted:
+
+ There is a COMPONENT method resolving after Catalyst::Component
+ in ${next_package}.
+
+The correct fix is to re-arrange your class' inheritance hierarchy so that the
+COMPONENT method you would like to inherit is the first (left-hand most)
+COMPONENT method in your @ISA.
+
+=head1 WARNINGS
+
+=head2 Methods in Catalyst::Dispatcher
+
+The following methods in Catalyst::Dispatcher are both an implementation
+detail, which may change in the 5.8X release series, and therefore their use
+is highly deprecated.
+
+=over
+
+=item tree
+
+=item dispatch_types
+
+=item registered_dispatch_types
+
+=item method_action_class
+
+=item action_hash
+
+=item container_hash
+
+=back
+
+The first time one of these methods is called, a warning will be emitted:
+
+ Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name,
+ this will be removed in Catalyst 5.9X
+
+You should B<NEVER> be calling any of these methods from application code.
+
+Plugins authors and maintainers whose plugins currently call these methods
+should change to using the public API, or, if you do not feel the public API
+adequately supports your use-case, please email the development list to
+discuss what API features you need so that you can be appropriately supported.
+
+=head2 Class naming to packages defined does not correspond.
+
+In this version of Catalyst, if a component is loaded from disk, but no
+symbols are defined in that component's name space after it is loaded, this
+warning will be issued:
+
+ require $class was successful but the package is not defined.
+
+This is to protect against confusing bugs caused by mis-typing package names,
+and will become a fatal error in a future version.
+
+Please note that 'inner packages' (via L<Devel::InnerPackage>) are still fully
+supported, this warning is only issued when component file naming does not map
+to B<any> of the packages defined within that component.
+
+=head2 $c->plugin method
+
+Calling the plugin method is deprecated, and calling it at runtime is B<highly
+deprecated>.
+
+Instead you are recommended to use L< Catalyst::Model::Adaptor > or similar to
+compose the functionality you need outside of the main application name space.
+
+Calling the plugin method at runtime will not be supported past Catalyst 5.81.
+
+=cut
use HTTP::Request;
use Path::Class;
use URI;
-use Class::Inspector;
use Carp qw/croak/;
use Cwd;
+use namespace::clean;
+
=head1 NAME
Catalyst::Utils - The Catalyst Utils
croak "ensure_class_loaded should be given a classname, not a filename ($class)"
if $class =~ m/\.pm$/;
+ # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
+ # if it already has symbol table entries. This is to support things like Schema::Loader, which
+ # part-generate classes in memory, but then also load some of their contents from disk.
return if !$opts->{ ignore_loaded }
- && Class::Inspector->loaded( $class ); # if a symbol entry exists we don't load again
+ && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
# this hack is so we don't overwrite $@ if the load did not generate an error
my $error;
}
die $error if $error;
- die "require $class was successful but the package is not defined"
- unless Class::Inspector->loaded($class);
+
+ warn "require $class was successful but the package is not defined."
+ unless Class::MOP::is_class_loaded($class);
return 1;
}
package Catalyst::View;
-use strict;
-use base qw/Catalyst::Component/;
+use Moose;
+extends qw/Catalyst::Component/;
=head1 NAME
=cut
+no Moose;
+__PACKAGE__->meta->make_immutable();
+
1;
use Test::More;
+eval "use Pod::Coverage 0.19";
+plan skip_all => 'Pod::Coverage 0.19 required' if $@;
eval "use Test::Pod::Coverage 1.04";
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
-include = CodeLayout::ProhibitHardTabs
-only = 1
-
-[CodeLayout::ProhibitHardTabs]
-allow_leading_tabs = 0
\ No newline at end of file
plan skip_all => 'Critic test only for developers.';
}
else {
- eval { require Test::Perl::Critic };
+ eval { require Test::NoTabs };
if ( $@ ) {
plan tests => 1;
- fail( 'You must install Test::Perl::Critic to run 04critic.t' );
+ fail( 'You must install Test::NoTabs to run 04critic.t' );
exit;
}
}
-my $rcfile = File::Spec->catfile( 't', '04critic.rc' );
-Test::Perl::Critic->import( -profile => $rcfile );
-all_critic_ok();
\ No newline at end of file
+Test::NoTabs->import;
+all_perl_files_ok(qw/lib/);
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::Aggregate;
+
+my $tests = Test::Aggregate->new({
+ dirs => 't/aggregate',
+ verbose => 0,
+ set_filenames => 1,
+ findbin => 1,
+});
+
+$tests->run;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 141*$iters;
+use Test::More tests => 143*$iters;
use Catalyst::Test 'TestApp';
if ( $ENV{CAT_BENCHMARK} ) {
is( $response->header('X-Catalyst-Executed'),
$expected, 'Executed actions' );
}
+
+ #
+ # */search
+ # doc/*
+ #
+ # request for doc/search should end up in doc/*
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->doc_star
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/doc/search'),
+ "we prefer static path parts earlier in the chain" );
+ TODO: {
+ local $TODO = 'gbjk never got off his ass and fixed this';
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ }
+ }
}
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
is( $response->content, '/action/forward/foo/bar',
'forward_to_uri_check correct namespace');
}
-
+
# test forwarding to Catalyst::Action objects
{
ok( my $response = request(
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
my $content = q/foo
bar
}
else {
for ( 1 .. $iters ) {
- run_tests();
+ run_tests($content);
}
}
sub run_tests {
+ my ($content) = @_;
+
# Local
{
ok(
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
skip "Using remote server", 5;
}
- my $file = "$FindBin::Bin/lib/TestApp/Controller/Action/Streaming.pm";
+ my $file = "$FindBin::Bin/../lib/TestApp/Controller/Action/Streaming.pm";
my $fh = IO::File->new( $file, 'r' );
my $buffer;
if ( defined $fh ) {
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use URI::Escape;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Test::More tests => 2;
+use Catalyst::Test 'TestApp';
+
+{
+ my $response = request('http://localhost/moose/get_attribute');
+ ok($response->is_success);
+ is($response->content, '42', 'attribute default values get set correctly');
+}
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 7;
use Catalyst::Test 'TestApp';
#!perl
-
use strict;
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
-use Test::More tests => 18;
+use Test::More tests => 23;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
isa_ok( $creq, 'Catalyst::Request' );
is( $creq->method, 'POST', 'Catalyst::Request method' );
is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
+ is( $creq->{__body_type}, 'File::Temp' );
is( $creq->content_length, $request->content_length,
'Catalyst::Request Content-Length' );
}
isa_ok( $creq, 'Catalyst::Request' );
is( $creq->method, 'POST', 'Catalyst::Request method' );
is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
+ is( $creq->{__body_type}, 'File::Temp' );
is( $creq->content_length, $request->content_length,
'Catalyst::Request Content-Length' );
}
+
+# 5.80 regression, see note in Catalyst::Plugin::Test::Plugin
+{
+ my $request = GET(
+ 'http://localhost/have_req_body_in_prepare_action',
+ 'Content-Type' => 'text/plain',
+ 'Content' => 'x' x 100_000
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ like( $response->content, qr/^[1-9]/, 'Has body' );
+}
+
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 8;
use Catalyst::Test 'TestAppOnDemand';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 13;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 17;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 53;
use Catalyst::Test 'TestApp';
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
isa_ok( $creq, 'Catalyst::Request' );
is( $creq->method, 'GET', 'Catalyst::Request method' );
- is_deeply( $creq->{parameters}, $parameters,
+ is_deeply( $creq->parameters, $parameters,
'Catalyst::Request parameters' );
}
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
ok( eval '$creq = ' . $response->content );
- is $creq->{parameters}->{q}, 'foo+bar', '%2b not double decoded';
+ is $creq->parameters->{q}, 'foo+bar', '%2b not double decoded';
}
{
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
ok( eval '$creq = ' . $response->content );
- is $creq->{parameters}->{q}, 'foo=bar', '= not ignored';
+ is $creq->parameters->{q}, 'foo=bar', '= not ignored';
}
{
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
isa_ok( $creq, 'Catalyst::Request' );
is( $creq->method, 'POST', 'Catalyst::Request method' );
- is_deeply( $creq->{parameters}, $parameters,
+ is_deeply( $creq->parameters, $parameters,
'Catalyst::Request parameters' );
is_deeply( $creq->arguments, [qw(a b)], 'Catalyst::Request arguments' );
- is_deeply( $creq->{uploads}, {}, 'Catalyst::Request uploads' );
+ is_deeply( $creq->uploads, {}, 'Catalyst::Request uploads' );
is_deeply( $creq->cookies, {}, 'Catalyst::Request cookie' );
}
ok( my $response = request($request), 'Request' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
+ is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' );
}
# raw query string support
ok( my $response = request($request), 'Request' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->{uri}->query, 'query+string', 'Catalyst::Request POST query_string' );
+ is( $creq->uri->query, 'query+string', 'Catalyst::Request POST query_string' );
is( $creq->query_keywords, 'query string', 'Catalyst::Request query_keywords' );
- is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
+ is_deeply( $creq->parameters, $parameters, 'Catalyst::Request parameters' );
ok( $response = request('http://localhost/dump/request/a/b?x=1&y=1&z=1'), 'Request' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->{uri}->query, 'x=1&y=1&z=1', 'Catalyst::Request GET query_string' );
+ is( $creq->uri->query, 'x=1&y=1&z=1', 'Catalyst::Request GET query_string' );
}
{
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
-use Test::More tests => 88;
+use Test::More tests => 105;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
use Catalyst::Request::Upload;
+use HTTP::Body::OctetStream;
use HTTP::Headers;
use HTTP::Headers::Util 'split_header_words';
use HTTP::Request::Common;
my $disposition = $part->header('Content-Disposition');
my %parameters = @{ ( split_header_words($disposition) )[0] };
- my $upload = $creq->{uploads}->{ $parameters{filename} };
+ my $upload = $creq->uploads->{ $parameters{filename} };
isa_ok( $upload, 'Catalyst::Request::Upload' );
is( $upload->size, length( $part->content ), 'Upload Content-Length' );
# make sure upload is accessible via legacy params->{$file}
- is( $creq->{parameters}->{ $upload->filename },
+ is( $creq->parameters->{ $upload->filename },
$upload->filename, 'legacy param method ok' );
SKIP:
my $disposition = $part->header('Content-Disposition');
my %parameters = @{ ( split_header_words($disposition) )[0] };
- my $upload = $creq->{uploads}->{ $parameters{name} }->[$i];
+ my $upload = $creq->uploads->{ $parameters{name} }->[$i];
isa_ok( $upload, 'Catalyst::Request::Upload' );
is( $upload->type, $part->content_type, 'Upload Content-Type' );
is( $upload->filename, $parameters{filename}, 'Upload filename' );
is( $upload->size, length( $part->content ), 'Upload Content-Length' );
+ is( $upload->basename, $parameters{filename}, 'Upload basename' );
SKIP:
{
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
is( $response->content, ( $request->parts )[0]->content, 'Content' );
+
+ # XXX: no way to test that temporary file for this test was deleted
}
{
'http://localhost/dump/request',
'Content-Type' => 'multipart/form-data',
'Content' =>
- [ 'file' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
+ [ 'file' => ["$FindBin::Bin/../catalyst_130pix.gif"], ]
);
# LWP will auto-correct Content-Length when using a remote server
'http://localhost/dump/request',
'Content-Type' => 'multipart/form-data',
'Content' =>
- [ 'file1' => ["$FindBin::Bin/catalyst_130pix.gif"],
- 'file2' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
+ [ 'file1' => ["$FindBin::Bin/../catalyst_130pix.gif"],
+ 'file2' => ["$FindBin::Bin/../catalyst_130pix.gif"], ]
);
ok( my $response = request($request), 'Request' );
is( $response->content_type, 'text/plain', 'Response Content-Type' );
like( $response->content, qr/file1 => bless/, 'Upload with name file1');
like( $response->content, qr/file2 => bless/, 'Upload with name file2');
+
+ my $creq;
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ for my $file ( $creq->upload ) {
+ my $upload = $creq->upload($file);
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Not testing for deleted file on remote server', 1;
+ }
+ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
+ }
+ }
}
{
'Content-Type' => 'form-data',
'Content' => [
'testfile' => 'textfield value',
- 'testfile' => ["$FindBin::Bin/catalyst_130pix.gif"],
+ 'testfile' => ["$FindBin::Bin/../catalyst_130pix.gif"],
]
);
is( $creq->content_length, $request->content_length,
'Catalyst::Request Content-Length' );
- my $param = $creq->{parameters}->{testfile};
+ my $param = $creq->parameters->{testfile};
ok( @$param == 2, '2 values' );
is( $param->[0], 'textfield value', 'correct value' );
next unless exists $parameters{filename};
- my $upload = $creq->{uploads}->{ $parameters{name} };
+ my $upload = $creq->uploads->{ $parameters{name} };
isa_ok( $upload, 'Catalyst::Request::Upload' );
is( $upload->type, $part->content_type, 'Upload Content-Type' );
is( $upload->size, length( $part->content ), 'Upload Content-Length' );
- is( $upload->filename, 'catalyst_130pix.gif' );
+ is( $upload->filename, 'catalyst_130pix.gif', 'Upload Filename' );
+ is( $upload->basename, 'catalyst_130pix.gif', 'Upload basename' );
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Not testing for deleted file on remote server', 1;
+ }
+ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
+ }
+ }
+}
+
+# Test PUT request with application/octet-stream file gets deleted
+
+{
+ my $body;
+
+ my $request = PUT(
+ 'http://localhost/dump/body/',
+ 'Content-Type' => 'application/octet-stream',
+ 'Content' => 'foobarbaz',
+ 'Content-Length' => 9,
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/bless\( .* 'HTTP::Body::OctetStream' \)/s,
+ 'Content is a serialized HTTP::Body::OctetStream'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$body = ' . substr( $response->content, 8 ), # FIXME - substr not needed in other test cases?
+ 'Unserialize HTTP::Body::OctetStream'
+ ) or warn $@;
+ }
+
+ isa_ok( $body, 'HTTP::Body::OctetStream' );
+ isa_ok($body->body, 'File::Temp');
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Not testing for deleted file on remote server', 1;
+ }
+ ok( !-e $body->body->filename, 'Upload temp file was deleted' );
}
}
SKIP:
{
if ( $ENV{CATALYST_SERVER} ) {
- skip 'Not testing uploadtmp on remote server', 13;
+ skip 'Not testing uploadtmp on remote server', 14;
}
my $creq;
is( $upload->size, length( $part->content ), 'Upload Content-Length' );
like( $upload->tempname, qr{\Q$dir\E}, 'uploadtmp' );
+
+ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
}
}
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
-use Test::More tests => 66;
+use Test::More tests => 68;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
ok( my $response = request('http://localhost/engine/request/uri?a=1;a=2;b=3'), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->{uri}->query, 'a=1;a=2;b=3', 'Query string ok' );
- is_deeply( $creq->{parameters}, $parameters, 'Parameters ok' );
+ is( $creq->uri->query, 'a=1;a=2;b=3', 'Query string ok' );
+ is_deeply( $creq->parameters, $parameters, 'Parameters ok' );
}
# test that query params are unescaped properly
ok( my $response = request('http://localhost/engine/request/uri?text=Catalyst%20Rocks'), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->{uri}->query, 'text=Catalyst%20Rocks', 'Query string ok' );
- is( $creq->{parameters}->{text}, 'Catalyst Rocks', 'Unescaped param ok' );
+ is( $creq->uri->query, 'text=Catalyst%20Rocks', 'Query string ok' );
+ is( $creq->parameters->{text}, 'Catalyst Rocks', 'Unescaped param ok' );
}
# test that uri_with adds params
is( $response->header( 'X-Catalyst-Param-c' ), '1', 'param "c" ok' );
}
+# Test an overridden uri method which calls the base method, SmartURI does this.
+SKIP:
+{
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 2;
+ }
+
+ require TestApp::RequestBaseBug;
+ TestApp->request_class('TestApp::RequestBaseBug');
+ ok( my $response = request('http://localhost/engine/request/uri'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ TestApp->request_class('Catalyst::Request');
+}
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 15;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 18;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 18;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 6;
use Catalyst::Test 'TestApp';
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Test::More tests => 9;
+use Catalyst::Test 'TestApp';
+
+my $expected = {
+ one => "foo",
+ two => "foobar",
+ three => "foo,bar,baz",
+};
+
+for my $action ( sort keys %{$expected} ) {
+ ok( my $response = request('http://localhost/engine/response/print/' . $action ),
+ 'Request' );
+ ok( $response->is_success, "Response $action successful 2xx" );
+
+ is( $response->content, $expected->{$action}, "Content $action OK" );
+}
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 26;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 30;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 1;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 2;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 3;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 5;
use Catalyst::Test 'TestApp';
Catalyst::Plugin::Test::Headers
Catalyst::Plugin::Test::Inline
Catalyst::Plugin::Test::Plugin
+ TestApp::Plugin::AddDispatchTypes
TestApp::Plugin::FullyQualified
];
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 28;
use Catalyst::Test 'TestApp';
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 3;
use Catalyst::Test 'TestApp';
ok( !$response->is_success, 'Response Not Successful' );
is( $response->header('X-Catalyst-Error'), 'Deep recursion detected calling "/recursion_test"', 'Deep Recursion Detected' );
}
-
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More;
-plan tests => 3;
+plan tests => 4;
use_ok('TestApp');
is(TestApp->controller('Args')->action_for('args')->code,
TestApp::Controller::Args->can('args'),
'action_for on controller ok');
+ is(TestApp->controller('Args')->action_for('args').'',
+ 'args/args',
+ 'action stringifies');
-use Test::More tests => 5;
+use Test::More tests => 6;
use strict;
use warnings;
use lib 't/lib';
can_ok($model_foo_bar, 'model_foo_bar_method_from_foo');
can_ok($model_foo_bar, 'model_foo_bar_method_from_foo_bar');
+
+TestApp->setup;
+
+is($model_foo->model_quux_method, 'chunkybacon', 'Model method getting $self->{quux} from config');
+
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
use Test::More;
# More Chained with Context Tests
#
{
- sub __action { $dispatcher->get_action_by_path( @_ ) }
+ sub __action { shift->get_action_by_path( @_ ) }
- is( $context->uri_for( __action( '/action/chained/endpoint2' ), [1,2], (3,4), { x => 5 } ),
+ is( $context->uri_for( __action( $dispatcher, '/action/chained/endpoint2' ), [1,2], (3,4), { x => 5 } ),
'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/4?x=5',
'uri_for correct for chained with multiple captures and args' );
- is( $context->uri_for( __action( '/action/chained/three_end' ), [1,2,3], (4,5,6) ),
+ is( $context->uri_for( __action( $dispatcher, '/action/chained/three_end' ), [1,2,3], (4,5,6) ),
'http://127.0.0.1/foo/chained/one/1/two/2/3/three/4/5/6',
'uri_for correct for chained with multiple capturing actions' );
- my $action_needs_two = __action( '/action/chained/endpoint2' );
+ my $action_needs_two = __action( $dispatcher, '/action/chained/endpoint2' );
ok( ! defined( $context->uri_for($action_needs_two, [1], (2,3)) ),
'uri_for returns undef for not enough captures' );
'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/',
'uri_for returns uri with empty arg on undef last argument' );
- my $complex_chained = __action( '/action/chained/empty_chain_f' );
+ my $complex_chained = __action( $dispatcher, '/action/chained/empty_chain_f' );
is( $context->uri_for( $complex_chained, [23], (13), {q => 3} ),
'http://127.0.0.1/foo/chained/empty/23/13?q=3',
'uri_for returns correct uri for chain with many empty path parts' );
use warnings;
use FindBin;
-use File::Spec;
-use lib File::Spec->catfile($FindBin::Bin, 'lib');
+use lib "$FindBin::Bin/../lib";
use Test::More tests => 5;
use Test::More;
require Catalyst;
require Module::Pluggable::Object;
-
-eval "require Class::C3";
-plan skip_all => "This test requires Class::C3" if $@;
+use MRO::Compat;
# Get a list of all Catalyst:: packages in blib via M::P::O
my @cat_mods;
#
foreach my $cat_mod (@cat_mods) {
eval " require $cat_mod ";
- eval { Class::C3::calculateMRO($cat_mod) };
- ok(!$@, "calculateMRO for $cat_mod");
+ eval { mro::get_linear_isa($cat_mod, 'c3') };
+ ok(!$@, "calculateMRO for $cat_mod: $@");
}
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use Class::MOP ();
+use Moose::Util ();
+
+# List of everything which used Class::Accessor::Fast in 5.70.
+my @modules = qw/
+ Catalyst::Action
+ Catalyst::ActionContainer
+ Catalyst::Component
+ Catalyst::Dispatcher
+ Catalyst::DispatchType
+ Catalyst::Engine::HTTP::Restarter::Watcher
+ Catalyst::Engine
+ Catalyst::Log
+ Catalyst::Request::Upload
+ Catalyst::Request
+ Catalyst::Response
+/;
+
+plan tests => scalar @modules;
+
+foreach my $module (@modules) {
+ Class::MOP::load_class($module);
+ ok Moose::Util::does_role($module => 'MooseX::Emulate::Class::Accessor::Fast'),
+ "$module has Class::Accessor::Fast back-compat";
+}
--- /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/perl
+
+use strict;
+use warnings;
+use FindBin qw/$Bin/;
+use lib "$Bin/lib";
+use Test::More tests => 4;
+use Test::MockObject;
+
+my $warnings;
+BEGIN { # Do this at compile time in case we generate a warning when use
+ # DeprecatedTestApp
+ $SIG{__WARN__} = sub { $warnings++ if $_[0] =~ /trying to use NEXT/ };
+}
+use Catalyst; # Cause catalyst to be used so I can fiddle with the logging.
+my $mvc_warnings;
+BEGIN {
+ my $logger = Test::MockObject->new;
+ $logger->mock('warn', sub { $mvc_warnings++ if $_[1] =~ /switch your class names/ });
+ Catalyst->log($logger);
+}
+
+use Catalyst::Test 'DeprecatedTestApp';
+is( $mvc_warnings, 1, 'Get the ::MVC:: warning' );
+
+ok( my $response = request('http://localhost/'), 'Request' );
+is( $response->header('X-Catalyst-Plugin-Deprecated'), '1', 'NEXT plugin ran correctly' );
+
+SKIP: {
+ skip 'non-dev release', 1 unless Catalyst::_IS_DEVELOPMENT_VERSION();
+ is( $warnings, 1, 'Got one and only one Adopt::NEXT warning');
+}
--- /dev/null
+package CDICompatTestPlugin;
+
+# This plugin specificially tests an edge case of C::D::I compat,
+# where you load a plugin which creates an accessor with the same
+# name as a class data accessor (_config in this case)..
+
+# This is what happens if you use the authentication back-compat
+# stuff, as C::A::Plugin::Credential::Password is added to the plugin
+# list, and that uses base C::A::C::P class, does the mk_accessors.
+
+# If a class data method called _config hasn't been created in
+# MyApp ($app below), then our call to ->config gets our accessor
+# (rather than the class data one), and we fail..
+
+use strict;
+use warnings;
+use base qw/Class::Accessor::Fast/;
+use MRO::Compat;
+__PACKAGE__->mk_accessors(qw/_config/);
+
+sub setup {
+ my $app = shift;
+
+ $app->config;
+ $app->next::method(@_);
+}
+
+# However, if we are too enthusiastic about adding accessors to the
+# MyApp package, then this method isn't called (as there is a local
+# symbol already).
+
+# Note - use a different package here, so that Moose's
+# package detection code doesn't get confused..
+$CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED = 0;
+
+sub setup_finished {
+ my $app = shift;
+ $CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED = 1;
+ $app->next::method(@_);
+}
+
+1;
sub execute {
my $self = shift;
my ( $controller, $c ) = @_;
- $self->NEXT::execute( @_ );
+ $self->next::method( @_ );
$c->res->header( 'X-Action-After', $c->stash->{after_message} );
}
my $self = shift;
my ( $controller, $c ) = @_;
$c->stash->{test} = 'works';
- $self->NEXT::execute( @_ );
+ $self->next::method( @_ );
}
1;
--- /dev/null
+package Catalyst::Plugin::Test::Deprecated;
+
+use strict;
+use warnings;
+use NEXT;
+
+use base qw/Catalyst::Base/;
+
+sub prepare {
+ my $class = shift;
+ # Note: This use of NEXT is deliberately left here (without a use NEXT)
+ # to ensure back compat, as NEXT always used to be loaded, but
+ # is now replaced by Class::C3::Adopt::NEXT.
+ my $c = $class->NEXT::prepare(@_);
+ $c->response->header( 'X-Catalyst-Plugin-Deprecated' => 1 );
+
+ return $c;
+}
+
+1;
package Catalyst::Plugin::Test::Errors;
use strict;
+use MRO::Compat;
sub error {
my $c = shift;
unless ( $_[0] ) {
- return $c->NEXT::error(@_);
+ return $c->next::method(@_);
}
if ( $_[0] =~ /^(Unknown resource|No default action defined)/ ) {
$c->response->headers->push_header( 'X-Catalyst-Error' => $error );
- $c->NEXT::error(@_);
+ $c->next::method(@_);
}
1;
package Catalyst::Plugin::Test::Headers;
use strict;
+use MRO::Compat;
sub prepare {
my $class = shift;
- my $c = $class->NEXT::prepare(@_);
+ my $c = $class->next::method(@_);
$c->response->header( 'X-Catalyst-Engine' => $c->engine );
$c->response->header( 'X-Catalyst-Debug' => $c->debug ? 1 : 0 );
sub prepare_action {
my $c = shift;
- $c->NEXT::prepare_action(@_);
+ $c->next::method(@_);
$c->res->header( 'X-Catalyst-Action' => $c->req->action );
}
package Catalyst::Plugin::Test::Plugin;
use strict;
+use warnings;
+use MRO::Compat;
use base qw/Catalyst::Base Class::Data::Inheritable/;
$c->ran_setup('1');
}
-sub prepare {
-
+sub prepare {
my $class = shift;
- my $c = $class->NEXT::prepare(@_);
+ my $c = $class->next::method(@_);
$c->response->header( 'X-Catalyst-Plugin-Setup' => $c->ran_setup );
return $c;
+}
+# Note: This is horrible, but Catalyst::Plugin::Server forces the body to
+# be parsed, by calling the $c->req->body method in prepare_action.
+# We need to test this, as this was broken by 5.80. See also
+# t/aggregate/live_engine_request_body.t. Better ways to test this
+# appreciated if you have suggestions :)
+{
+ my $have_req_body = 0;
+ sub prepare_action {
+ my $c = shift;
+ $have_req_body++ if $c->req->body;
+ $c->next::method(@_);
+ }
+ sub have_req_body_in_prepare_action : Local {
+ my ($self, $c) = @_;
+ $c->res->body($have_req_body);
+ }
}
sub end : Private {
--- /dev/null
+package DeprecatedTestApp;
+
+use strict;
+use Catalyst qw/
+ Test::Deprecated
+/;
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config( name => 'DeprecatedTestApp', root => '/some/dir' );
+
+__PACKAGE__->setup;
+
+1;
--- /dev/null
+package DeprecatedTestApp::C::Root;
+use strict;
+use warnings;
+use base qw/Catalyst::Controller/;
+
+__PACKAGE__->config->{namespace} = '';
+
+sub index : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body('root index');
+}
+
+1;
--- /dev/null
+package NullPackage;
+# Do nothing class, there should be no code or symbols defined here..
+# Loading this works fine in 5.70, but a die was introduced in 5.80 which caused
+# it to fail. This has been changed to a warning to maintain back-compat.
+# See Catalyst::Utils::ensure_class_loaded() for more info.
+1;
+
Test::Plugin
Test::Inline
+TestApp::Plugin::FullyQualified
+ +TestApp::Plugin::AddDispatchTypes
/;
use Catalyst::Utils;
TestApp->config( name => 'TestApp', root => '/some/dir' );
-unless (eval 'require Moose; 1') {
- TestApp->config(setup_components => { except => 'TestApp::Controller::Moose' });
-}
-
TestApp->setup;
sub index : Private {
sub execute {
my $c = shift;
my $class = ref( $c->component( $_[0] ) ) || $_[0];
- my $action = "$_[1]";
+ my $action = $_[1]->reverse;
my $method;
sub finalize_error {
my $c = shift;
- $c->NEXT::finalize_error(@_);
+ $c->next::method(@_);
$c->res->status(500);
$c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) );
my $self = shift;
my ( $controller, $c, $test ) = @_;
$c->res->header( 'X-TestAppActionTestBefore', $test );
- $self->NEXT::execute( @_ );
+ $self->next::method( @_ );
}
1;
my $self = shift;
my ( $controller, $c, $test ) = @_;
$c->res->header( 'X-TestAppActionTestMyAction', 'MyAction works' );
- $self->NEXT::execute(@_);
+ $self->next::method(@_);
}
1;
sub static_end : Chained('korv') Args(0) { }
sub capture_end : Chained('wurst') Args(0) PathPart('') { }
+
+# */search vs doc/*
+sub view : Chained('/') PathPart('chained') CaptureArgs(1) {}
+sub star_search : Chained('view') PathPart('search') Args(0) { }
+sub doc_star : Chained('/') PathPart('chained/doc') Args(1) {}
+
sub end :Private {
my ($self, $c) = @_;
return if $c->stash->{no_end};
$c->forward( qw/TestApp::Controller::Action::Forward args/, [qq/new/] );
$c->res->body( $c->req->args->[0] );
}
-
+
sub to_action_object : Local {
my ( $self, $c ) = @_;
$c->forward($self->action_for('embed'), [qw/mtfnpy/]);
}
-
sub args : Local {
my ( $self, $c, $val ) = @_;
die "Expected argument 'new', got '$val'" unless $val eq 'new';
sub body : Local {
my ( $self, $c ) = @_;
- my $file = "$FindBin::Bin/lib/TestApp/Controller/Action/Streaming.pm";
+ my $file = "$FindBin::Bin/../lib/TestApp/Controller/Action/Streaming.pm";
my $fh = IO::File->new( $file, 'r' );
if ( defined $fh ) {
$c->res->body( $fh );
sub env : Action Relative {
my ( $self, $c ) = @_;
- $c->stash( env => \%ENV );
- $c->forward('TestApp::View::Dump');
+ $c->forward('TestApp::View::Dump', [\%ENV]);
}
sub parameters : Action Relative {
$c->forward('TestApp::View::Dump::Response');
}
+sub body : Action Relative {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Body');
+}
+
1;
--- /dev/null
+package TestApp::Controller::Engine::Response::Print;
+
+use strict;
+use base 'Catalyst::Base';
+
+sub one :Relative {
+ my ( $self, $c ) = @_;
+
+ $c->res->print("foo");
+}
+
+sub two :Relative {
+ my ( $self, $c ) = @_;
+
+ $c->res->print(qw/foo bar/);
+}
+
+sub three :Relative {
+ my ( $self, $c ) = @_;
+
+ local $, = ',';
+ $c->res->print(qw/foo bar baz/);
+}
+
+1;
use strict;
use warnings;
use base 'Catalyst::Controller';
-use YAML;
+
+eval 'use YAML';
sub system : Local {
my ($self, $c, $ls) = @_;
--- /dev/null
+package TestApp::Controller::Immutable;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
--- /dev/null
+package TestApp::Controller::Immutable::HardToReload::Role;
+use Moose::Role; # Role metaclass does not have make_immutable..
+no Moose::Role;
+
+package TestApp::Controller::Immutable::HardToReload;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
+package # Standard PAUSE hiding technique
+ TestApp::Controller::Immutable::HardToReload::PAUSEHide;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
+# Not an inner package
+package TestApp::Controller::Immutable2;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
+# Not even in the app namespace
+package Frobnitz;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
use Moose;
+use namespace::clean -except => 'meta';
+
BEGIN { extends qw/Catalyst::Controller/; }
-has attribute => ( # Test defaults work
+has attribute => (
is => 'ro',
default => 42,
);
-has other_attribute => ( # Test BUILD method is called
- is => 'rw'
-);
-
-has punctuation => ( # Test BUILD method gets merged config
- is => 'rw'
-);
-
-has space => ( # Test that attribute slots get filled from merged config
- is => 'ro'
-);
-
-no Moose;
-
-__PACKAGE__->config(the_punctuation => ':');
-__PACKAGE__->config(space => ' '); # i am pbp, icm5ukp
-
-sub BUILD {
- my ($self, $config) = @_;
- # Note, not an example of something you would ever
- $self->other_attribute('the meaning of life');
- $self->punctuation( $config->{the_punctuation} );
-}
-
-sub the_answer : Local {
+sub get_attribute : Local {
my ($self, $c) = @_;
- $c->response->body($self->other_attribute . $self->punctuation . $self->space . $self->attribute);
+ $c->response->body($self->attribute);
}
1;
$c->forward('TestApp::View::Dump::Request');
}
-sub chain_to_self : Chained('chain_to_self') PathPart('') CaptureArgs(1) { }
-
-sub chain_recurse_endoint : Chained('chain_to_self') Args(0) { }
-
1;
--- /dev/null
+package TestApp::DispatchType::CustomPostLoad;
+use strict;
+use warnings;
+use base qw/Catalyst::DispatchType::Path/;
+
+# Never match anything..
+sub match { }
+
+1;
+
--- /dev/null
+package TestApp::DispatchType::CustomPreLoad;
+use strict;
+use warnings;
+use base qw/Catalyst::DispatchType::Path/;
+
+# Never match anything..
+sub match { }
+
+1;
+
use base qw/ Catalyst::Model /;
+__PACKAGE__->config( 'quux' => 'chunkybacon' );
+
sub model_foo_method { 1 }
+sub model_quux_method { shift->{quux} }
+
package TestApp::Model::Foo::Bar;
sub model_foo_bar_method_from_foo { 1 }
--- /dev/null
+package TestApp::Plugin::AddDispatchTypes;
+use strict;
+use warnings;
+use MRO::Compat;
+
+sub setup_dispatcher {
+ my $class = shift;
+
+ ### Load custom DispatchTypes, as done by Catalyst::Plugin::Server
+ # There should be a waaay less ugly method for doing this,
+ # FIXME in 5.9
+ $class->next::method( @_ );
+ $class->dispatcher->preload_dispatch_types(
+ @{$class->dispatcher->preload_dispatch_types},
+ qw/ +TestApp::DispatchType::CustomPreLoad /
+ );
+ $class->dispatcher->postload_dispatch_types(
+ @{$class->dispatcher->postload_dispatch_types},
+ qw/ +TestApp::DispatchType::CustomPostLoad /
+ );
+
+ return $class;
+}
+
+1;
+
--- /dev/null
+package TestApp::RequestBaseBug;
+
+use base 'Catalyst::Request';
+
+sub uri {
+ my $self = shift;
+
+# this goes into infinite mutual recursion
+ $self->base;
+
+ $self->SUPER::uri(@_)
+}
+
+1;
use base 'Catalyst::View';
use Data::Dumper ();
-use Scalar::Util qw(weaken);
+use Scalar::Util qw(blessed weaken);
sub dump {
my ( $self, $reference ) = @_;
# Force processing of on-demand data
$c->prepare_body;
- # Remove context from reference if needed
- my $context = delete $reference->{_context};
-
# Remove body from reference if needed
+ $reference->{__body_type} = blessed $reference->body
+ if (blessed $reference->{_body});
my $body = delete $reference->{_body};
+ # Remove context from reference if needed
+ my $context = delete $reference->{_context};
+
if ( my $output =
- $self->dump( $reference || $c->stash->{dump} || $c->stash ) )
+ $self->dump( $reference ) )
{
$c->res->headers->content_type('text/plain');
weaken( $reference->{_context} );
# Repair body
+ delete $reference->{__body_type};
$reference->{_body} = $body;
return 1;
--- /dev/null
+package TestApp::View::Dump::Body;
+
+use strict;
+use base qw[TestApp::View::Dump];
+
+sub process {
+ my ( $self, $c ) = @_;
+ return $self->SUPER::process( $c, $c->request->{_body} ); # FIXME, accessor doesn't work?
+}
+
+1;
sub execute {
my $c = shift;
my $class = ref( $c->component( $_[0] ) ) || $_[0];
- my $action = "$_[1]";
+ my $action = $_[1]->reverse();
my $method;
--- /dev/null
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use Catalyst::Test 'TestApp', {default_host => 'default.com'};
+use Catalyst::Request;
+
+use Test::More tests => 8;
+
+content_like('/',qr/root/,'content check');
+action_ok('/','Action ok ok','normal action ok');
+action_redirect('/engine/response/redirect/one','redirect check');
+action_notfound('/engine/response/status/s404','notfound check');
+contenttype_is('/action/local/one','text/plain','Contenttype check');
+
+my $creq;
+my $req = '/dump/request';
+
+{
+ eval '$creq = ' . request($req)->content;
+ is( $creq->uri->host, 'default.com', 'request targets default host set via import' );
+}
+
+{
+ local $Catalyst::Test::default_host = 'localized.com';
+ eval '$creq = ' . request($req)->content;
+ is( $creq->uri->host, 'localized.com', 'target host is mutable via package var' );
+}
+
+{
+ my %opts = ( host => 'opthash.com' );
+ eval '$creq = ' . request($req, \%opts)->content;
+ is( $creq->uri->host, $opts{host}, 'target host is mutable via options hashref' );
+}
+++ /dev/null
-use strict;
-use warnings;
-use Test::More;
-
-BEGIN {
- if (eval 'require Moose; 1') {
- plan tests => 2;
- }
- else {
- plan skip_all => 'Moose is required for this test';
- }
-}
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Catalyst::Test 'TestApp';
-
-{
- my $response = request('http://localhost/moose/the_answer');
- ok($response->is_success);
- is($response->content, 'the meaning of life: 42', 'attr defaults + BUILD works correctly');
-}
#!/usr/bin/perl
-# live_fork.t
+# live_fork.t
# Copyright (c) 2006 Jonathan Rockway <jrockway@cpan.org>
=head1 SYNOPSIS
use strict;
use warnings;
use Test::More;
-use YAML;
use FindBin;
use lib "$FindBin::Bin/lib";
use Catalyst::Test qw(TestApp);
-plan skip_all => 'Using remote server'
- if $ENV{CATALYST_SERVER};
-
+eval 'use YAML';
+plan skip_all => 'YAML required' if $@;
+
+plan skip_all => 'Using remote server (and REMOTE_FORK not set)'
+ if $ENV{CATALYST_SERVER} && !$ENV{REMOTE_FORK};
+
plan skip_all => 'Skipping fork tests: no /bin/ls'
if !-e '/bin/ls'; # see if /bin/ls exists
-
+
plan tests => 13; # otherwise
{
ok(my $result = get('/fork/system/%2Fbin%2Fls'), 'system');
my @result = split /$/m, $result;
$result = join q{}, @result[-4..-1];
-
+
my $result_ref = eval { Load($result) };
ok($result_ref, 'is YAML');
is($result_ref->{result}, 0, 'exited OK');
}
-{
+{
backticks:
ok(my $result = get('/fork/backticks/%2Fbin%2Fls'), '`backticks`');
my @result = split /$/m, $result;
$result = join q{}, @result[-4..-1];
-
+
my $result_ref = eval { Load($result) };
ok($result_ref, 'is YAML');
is($result_ref->{code}, 0, 'exited successfully');
like($result_ref->{result}, qr{^/bin/ls[^:]}, 'contains ^/bin/ls$');
like($result_ref->{result}, qr{\n.*\n}m, 'contains two newlines');
}
-{
+{
fork:
ok(my $result = get('/fork/fork'), 'fork');
my @result = split /$/m, $result;
$result = join q{}, @result[-4..-1];
-
+
my $result_ref = eval { Load($result) };
ok($result_ref, 'is YAML');
isnt($result_ref->{pid}, 0, q{fork's "pid" wasn't 0});
{
ok( my $response = request('http://localhost/'), 'Request' );
ok( $response->is_success, 'Response Successful 2xx' );
- ok( $response->content =~ m/\/default.*?[\d.]+s.*- test.*[\d.]+s/s, 'Stats report');
+ like( $response->content, qr/\/default.*?[\d.]+s.*- test.*[\d.]+s/s, 'Stats report');
}
--- /dev/null
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Test::Exception;
+use Carp ();
+$SIG{__DIE__} = \&Carp::confess; # Stacktrace please.
+
+# Doing various silly things, like for example
+# use CGI qw/:stanard/ in your conrtoller / app
+# will overwrite your meta method, therefore Catalyst
+# can't depend on it being there correctly.
+
+# This is/was demonstrated by Catalyst::Controller::WrapCGI
+# and Catalyst::Plugin::Cache::Curried
+
+{
+ package TestAppWithMeta;
+ use Catalyst;
+ no warnings 'redefine';
+ sub meta {}
+}
+
+lives_ok { TestAppWithMeta->setup } 'Can setup an app which defines its own meta method';
die "ERROR: Please run test from the Catalyst-Runtime directory\n";
}
-push @ARGV, glob( 't/live_*' );
+push @ARGV, glob( 't/aggregate/live_*' );
Apache::TestRun->new->run(@ARGV);
die "ERROR: Please run test from the Catalyst-Runtime directory\n";
}
-push @ARGV, glob( 't/live_*' );
+push @ARGV, glob( 't/aggregate/live_*' );
Apache::TestRun->new->run(@ARGV);
die "ERROR: Please run test from the Catalyst-Runtime directory\n";
}
-push @ARGV, glob( 't/live_*' );
+push @ARGV, glob( 't/aggregate/live_*' );
Apache::TestRun->new->run(@ARGV);
die "ERROR: Please run test from the Catalyst-Runtime directory\n";
}
-push @ARGV, glob( 't/live_*' );
+push @ARGV, glob( 't/aggregate/live_*' );
Apache::TestRun->new->run(@ARGV);
use strict;
use warnings;
+use Test::More;
+BEGIN {
+ plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
+}
+
use File::Path;
use FindBin;
use LWP::Simple;
use IO::Socket;
use IPC::Open3;
-use Test::More;
+use Catalyst::Engine::HTTP::Restarter::Watcher;
use Time::HiRes qw/sleep/;
eval "use Catalyst::Devel 1.0;";
-plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
plan skip_all => 'Catalyst::Devel required' if $@;
plan skip_all => 'Catalyst::Devel >= 1.04 required' if $Catalyst::Devel::VERSION <= 1.03;
eval "use File::Copy::Recursive";
mkdir $tmpdir;
chdir $tmpdir;
-system( 'perl', "-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' );
my( $server, $pid );
$pid = open3( undef, $server, undef,
- 'perl', "-I$FindBin::Bin/../lib",
+ $^X, "-I$FindBin::Bin/../lib",
"$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port',
$port, '-restart' )
or die "Unable to spawn standalone HTTP server: $!";
my @files = (
"$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/Engine/Request/URI.pm",
+ "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable.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 ) {
} qw/Action Engine/;
$pid = open3( undef, $server, undef,
- 'perl', "-I$FindBin::Bin/../lib",
+ $^X, "-I$FindBin::Bin/../lib",
"$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port',
$port, '-restart', $restartdirs )
or die "Unable to spawn standalone HTTP server: $!";
sleep 0.1;
if ( $count++ > 100 ) {
fail "Server restarted";
- SKIP_NO_RESTART_2: {
+ SKIP: {
skip "Server didn't restart, no sense in checking response", 1;
}
next MULTI_DIR_RESTART;
use strict;
use warnings;
+use Test::More;
+BEGIN {
+ plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
+}
+
use File::Path;
use FindBin;
use IPC::Open3;
use IO::Socket;
-use Test::More;
-plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
eval "use Catalyst::Devel 1.0";
plan skip_all => 'Catalyst::Devel required' if $@;
eval "use File::Copy::Recursive";
# create a TestApp and copy the test libs into it
mkdir $tmpdir;
chdir $tmpdir;
-system( 'perl', "-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' );
# spawn the standalone HTTP server
my $port = 30000 + int rand(1 + 10000);
my $pid = open3( undef, my $server, undef,
- 'perl', "-I$FindBin::Bin/../lib",
+ $^X, "-I$FindBin::Bin/../lib",
"$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', $port )
or die "Unable to spawn standalone HTTP server: $!";
my $return;
if ( $single_test ) {
- $return = system( "perl -Ilib/ $single_test" );
+ $return = system( "$^X -Ilib/ $single_test" );
}
else {
- $return = system( 'prove -r -Ilib/ t/live_*.t' );
+ $return = prove( '-r', '-Ilib/', glob('t/aggregate/live_*.t') );
}
# shut it down
return 0;
}
}
+
+sub prove {
+ if (!(my $pid = fork)) {
+ require App::Prove;
+ my $prove = App::Prove->new;
+ $prove->process_args(@_);
+ exit( $prove->run ? 0 : 1 );
+ } else {
+ waitpid $pid, 0;
+ return $?;
+ }
+}
use strict;
use warnings;
+use Test::More;
+BEGIN {
+ plan skip_all => 'set TEST_LIGHTTPD to enable this test'
+ unless $ENV{TEST_LIGHTTPD};
+}
+
use File::Path;
use FindBin;
use IO::Socket;
-use Test::More;
-plan skip_all => 'set TEST_LIGHTTPD to enable this test'
- unless $ENV{TEST_LIGHTTPD};
-
eval "use FCGI";
plan skip_all => 'FCGI required' if $@;
# create a TestApp and copy the test libs into it
mkdir "$FindBin::Bin/../t/tmp";
chdir "$FindBin::Bin/../t/tmp";
-system "perl -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' );
# run the testsuite against the server
$ENV{CATALYST_SERVER} = "http://localhost:$port/deep/path";
-my @tests = (shift) || glob('t/live_*');
+my @tests = (shift) || glob('t/aggregate/live_*');
eval {
runtests(@tests);
};
use strict;
use warnings;
+use Test::More;
+BEGIN {
+ plan skip_all => 'set TEST_LIGHTTPD to enable this test'
+ unless $ENV{TEST_LIGHTTPD};
+}
+
use File::Path;
use FindBin;
use IO::Socket;
-use Test::More;
-plan skip_all => 'set TEST_LIGHTTPD to enable this test'
- unless $ENV{TEST_LIGHTTPD};
-
eval "use FCGI";
plan skip_all => 'FCGI required' if $@;
# create a TestApp and copy the test libs into it
mkdir "$FindBin::Bin/../t/tmp";
chdir "$FindBin::Bin/../t/tmp";
-system "perl -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' );
# run the testsuite against the server
$ENV{CATALYST_SERVER} = "http://localhost:$port";
-my @tests = (shift) || glob('t/live_*');
+my @tests = (shift) || glob('t/aggregate/live_*');
eval {
runtests(@tests);
};
use strict;
use warnings;
+use Test::More;
+BEGIN {
+ plan skip_all => 'set TEST_MEMLEAK to enable this test'
+ unless $ENV{TEST_MEMLEAK};
+}
+
use FindBin;
use lib "$FindBin::Bin/lib";
-
-use Test::More;
use Catalyst::Test 'TestApp';
-use YAML;
-eval "use Proc::ProcessTable";
-plan skip_all => 'set TEST_MEMLEAK to enable this test'
- unless $ENV{TEST_MEMLEAK};
+eval "use Proc::ProcessTable";
plan skip_all => 'Proc::ProcessTable required for this test' if $@;
eval "use HTTP::Body 0.03";
plan skip_all => 'HTTP::Body >= 0.03 required for this test' if $@;
+eval "use YAML";
+plan skip_all => 'YAML required for this test' if $@;
+
our $t = Proc::ProcessTable->new( cache_ttys => 1 );
our ( $initial, $final ) = ( 0, 0 );
our $tests = YAML::LoadFile("$FindBin::Bin/optional_stress.yml");
print "Final Size: $final\n";
if ( $final > $initial ) {
- print "Leaked: " . ($final - $initial) . " K\n";
+ print "Leaked: " . ($final - $initial) . "K\n";
}
is( $final, $initial, "'$uri' memory is not leaking" );
use strict;
use warnings;
+use Test::More;
+BEGIN {
+ plan skip_all => 'set TEST_STRESS to enable this test'
+ unless $ENV{TEST_STRESS};
+}
+
use FindBin;
use lib "$FindBin::Bin/lib";
-
-use Test::More;
use Catalyst::Test 'TestApp';
-use YAML;
our ( $iters, $tests );
BEGIN {
- plan skip_all => 'set TEST_STRESS to enable this test'
- unless $ENV{TEST_STRESS};
+ eval "use YAML";
+ plan skip_all => 'YAML is required for this test' if $@;
$iters = $ENV{TEST_STRESS} || 10;
$tests = YAML::LoadFile("$FindBin::Bin/optional_stress.yml");
use strict;
use warnings;
+use Test::More;
+BEGIN {
+ plan skip_all => 'set TEST_THREADS to enable this test'
+ unless $ENV{TEST_THREADS};
+}
+
use FindBin;
use lib "$FindBin::Bin/lib";
-
-use Test::More;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
use Config;
use HTTP::Response;
-plan skip_all => 'set TEST_THREADS to enable this test'
- unless $ENV{TEST_THREADS};
-
if ( $Config{useithreads} && !$ENV{CATALYST_SERVER} ) {
require threads;
plan tests => 3;
--- /dev/null
+# Test that plugins with their own new method don't break applications.
+
+# 5.70 creates all of the request/response structure itself in prepare,
+# and as the new method in our plugin just blesses our args, that works nicely.
+
+# In 5.80, we rely on the new method to appropriately initialise data
+# structures, and therefore we need to inline a new method on MyApp to ensure
+# that plugins don't get it wrong for us.
+
+# Also tests method modifiers and etc in MyApp.pm still work as expected.
+use Test::More tests => 3;
+
+{
+ package NewTestPlugin;
+ use strict;
+ use warnings;
+ sub new {
+ my $class = shift;
+ return bless $_[0], $class;
+ }
+}
+
+{ # This is all in the same file so that the setup method on the
+ # application is called at runtime, rather than at compile time.
+ # This ensures that the end of scope hook has to happen at runtime
+ # correctly, otherwise the test will fail (ergo the switch from
+ # B::Hooks::EndOfScope to Sub::Uplevel)
+ package TestAppPluginWithNewMethod;
+ use Test::Exception;
+ use Catalyst qw/+NewTestPlugin/;
+
+ sub foo : Local {
+ my ($self, $c) = @_;
+ $c->res->body('foo');
+ }
+
+ use Moose; # Just testing method modifiers still work.
+ __PACKAGE__->setup;
+ our $MODIFIER_FIRED = 0;
+
+ lives_ok {
+ before 'dispatch' => sub { $MODIFIER_FIRED = 1 }
+ } 'Can apply method modifier';
+ no Moose;
+}
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Catalyst::Test qw/TestAppPluginWithNewMethod/;
+ok request('/foo')->is_success;
+is $TestAppPluginWithNewMethod::MODIFIER_FIRED, 1, 'Before modifier was fired correctly.';
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 3;
-
-
-use TestApp;
-
-my $dispatch_type = TestApp->dispatcher->dispatch_type('Chained');
-isa_ok($dispatch_type, "Catalyst::DispatchType::Chained", "got dispatch type");
-
-# This test was failing due to recursion/OOM. set up an alarm so things dont
-# runaway
-local $SIG{ALRM} = sub {
- ok(0, "Chained->list didn't loop");
- die "alarm expired - test probably looping";
-};
-alarm 10;
-
-$dispatch_type->list("TestApp");
-ok(1, "Chained->list didn't loop");
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Scalar::Util qw/refaddr blessed/;
+use Test::More tests => 37;
+
+{
+ package ClassDataTest;
+ use Moose;
+ with 'Catalyst::ClassData';
+
+ package ClassDataTest2;
+ use Moose;
+ extends 'ClassDataTest';
+
+}
+
+ my $scalar = '100';
+ my $arrayref = [];
+ my $hashref = {};
+ my $scalarref = \$scalar;
+ my $coderef = sub { "beep" };
+
+ my $scalar2 = '200';
+ my $arrayref2 = [];
+ my $hashref2 = {};
+ my $scalarref2 = \$scalar2;
+ my $coderef2 = sub { "beep" };
+
+ my $scalar3 = '300';
+ my $arrayref3 = [];
+ my $hashref3 = {};
+ my $scalarref3 = \$scalar3;
+ my $coderef3 = sub { "beep" };
+
+
+my @accessors = qw/_arrayref _hashref _scalarref _coderef _scalar/;
+ClassDataTest->mk_classdata($_) for @accessors;
+can_ok('ClassDataTest', @accessors);
+
+ClassDataTest2->mk_classdata("beep", "meep");
+is(ClassDataTest2->beep, "meep");
+
+ClassDataTest->_arrayref($arrayref);
+ClassDataTest->_hashref($hashref);
+ClassDataTest->_scalarref($scalarref);
+ClassDataTest->_coderef($coderef);
+ClassDataTest->_scalar($scalar);
+
+is(ref(ClassDataTest->_arrayref), 'ARRAY');
+is(ref(ClassDataTest->_hashref), 'HASH');
+is(ref(ClassDataTest->_scalarref), 'SCALAR');
+is(ref(ClassDataTest->_coderef), 'CODE');
+ok( !ref(ClassDataTest->_scalar) );
+is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref));
+is(refaddr(ClassDataTest->_hashref), refaddr($hashref));
+is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref));
+is(refaddr(ClassDataTest->_coderef), refaddr($coderef));
+is(ClassDataTest->_scalar, $scalar);
+
+
+is(ref(ClassDataTest2->_arrayref), 'ARRAY');
+is(ref(ClassDataTest2->_hashref), 'HASH');
+is(ref(ClassDataTest2->_scalarref), 'SCALAR');
+is(ref(ClassDataTest2->_coderef), 'CODE');
+ok( !ref(ClassDataTest2->_scalar) );
+is(refaddr(ClassDataTest2->_arrayref), refaddr($arrayref));
+is(refaddr(ClassDataTest2->_hashref), refaddr($hashref));
+is(refaddr(ClassDataTest2->_scalarref), refaddr($scalarref));
+is(refaddr(ClassDataTest2->_coderef), refaddr($coderef));
+is(ClassDataTest2->_scalar, $scalar);
+
+ClassDataTest2->_arrayref($arrayref2);
+ClassDataTest2->_hashref($hashref2);
+ClassDataTest2->_scalarref($scalarref2);
+ClassDataTest2->_coderef($coderef2);
+ClassDataTest2->_scalar($scalar2);
+
+is(refaddr(ClassDataTest2->_arrayref), refaddr($arrayref2));
+is(refaddr(ClassDataTest2->_hashref), refaddr($hashref2));
+is(refaddr(ClassDataTest2->_scalarref), refaddr($scalarref2));
+is(refaddr(ClassDataTest2->_coderef), refaddr($coderef2));
+is(ClassDataTest2->_scalar, $scalar2);
+
+is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref));
+is(refaddr(ClassDataTest->_hashref), refaddr($hashref));
+is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref));
+is(refaddr(ClassDataTest->_coderef), refaddr($coderef));
+is(ClassDataTest->_scalar, $scalar);
+
+ClassDataTest->_arrayref($arrayref3);
+ClassDataTest->_hashref($hashref3);
+ClassDataTest->_scalarref($scalarref3);
+ClassDataTest->_coderef($coderef3);
+ClassDataTest->_scalar($scalar3);
+
+is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref3));
+is(refaddr(ClassDataTest->_hashref), refaddr($hashref3));
+is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref3));
+is(refaddr(ClassDataTest->_coderef), refaddr($coderef3));
+is(ClassDataTest->_scalar, $scalar3);
{
my $args;
- no warnings;
- *MyApp::M::Model::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
+ {
+ no warnings 'once';
+ *MyApp::M::Model::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
+ }
+
+ my $c = bless {}, 'MyApp';
- MyApp->component('MyApp::M::Model', qw/foo bar/);
+ $c->component('MyApp::M::Model', qw/foo bar/);
is_deeply($args, [qw/foo bar/], 'args passed to ACCEPT_CONTEXT ok');
- MyApp->component('M::Model', qw/foo2 bar2/);
+ $c->component('M::Model', qw/foo2 bar2/);
is_deeply($args, [qw/foo2 bar2/], 'args passed to ACCEPT_CONTEXT ok');
- MyApp->component('Mode', qw/foo3 bar3/);
+ $c->component('Mode', qw/foo3 bar3/);
is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok');
}
use File::Spec;
use File::Path;
+use Test::MockObject;
+
my $libdir = 'test_trash';
unshift(@INC, $libdir);
write_component_file(\@dir_list, $name_final, <<EOF);
package $fullname;
+use MRO::Compat;
use base '$compbase';
sub COMPONENT {
- my \$self = shift->NEXT::COMPONENT(\@_);
+ my \$self = shift->next::method(\@_);
no strict 'refs';
*{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };
\$self;
$component->{name});
}
-eval "package $appclass; use Catalyst; __PACKAGE__->setup";
+my $shut_up_deprecated_warnings = q{
+ use Test::MockObject;
+ my $old_logger = __PACKAGE__->log;
+ my $logger = Test::MockObject->new;
+ $logger->mock('warn', sub {
+ my $self = shift;
+ return if $_[0] =~ /deprecated/;
+ $old_logger->warn(@_);
+ });
+ __PACKAGE__->log($logger);
+};
+
+eval "package $appclass; use Catalyst; $shut_up_deprecated_warnings __PACKAGE__->setup";
can_ok( $appclass, 'components');
eval qq(
package $appclass;
use Catalyst;
+$shut_up_deprecated_warnings
__PACKAGE__->config->{ setup_components } = {
search_extra => [ '::Extra' ],
except => [ "${appclass}::Controller::Foo" ]
use base 'Catalyst::Model';
sub COMPONENT {
- my \$self = shift->NEXT::COMPONENT(\@_);
+ my \$self = shift->next::method(\@_);
no strict 'refs';
*{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };
\$self;
use base 'Catalyst::Model';
no warnings 'redefine';
-sub COMPONENT { return shift->NEXT::COMPONENT(\@_); }
+sub COMPONENT { return shift->next::method(\@_); }
1;
EOF
--- /dev/null
+use Test::More tests => 1;
+use strict;
+use warnings;
+
+{
+ package MyApp::Component;
+ use Test::More;
+
+ sub COMPONENT {
+ fail 'This no longer gets dispatched to';
+ }
+
+ package MyApp::MyComponent;
+
+ use base 'Catalyst::Component', 'MyApp::Component';
+
+}
+
+my $warn = '';
+{
+ local $SIG{__WARN__} = sub {
+ $warn .= $_[0];
+ };
+ MyApp::MyComponent->COMPONENT('MyApp');
+}
+
+like($warn, qr/after Catalyst::Component in MyApp::Component/,
+ 'correct warning thrown');
+
{
my $args;
- no warnings;
- *MyApp::Model::M::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
- *MyApp::View::V::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
+ {
+ no warnings 'once';
+ *MyApp::Model::M::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
+ *MyApp::View::V::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
+ }
+
+ my $c = bless {}, 'MyApp';
# test accept-context with class rather than instance
MyApp->model('M', qw/foo bar/);
- is_deeply($args, [qw/foo bar/], '$c->model args passed to ACCEPT_CONTEXT ok');
+ is_deeply($args, [qw/foo bar/], 'MyApp->model args passed to ACCEPT_CONTEXT ok');
- MyApp->model('M', qw/foo bar/);
+ $c->model('M', qw/foo bar/);
is_deeply($args, [qw/foo bar/], '$c->model args passed to ACCEPT_CONTEXT ok');
- my $x = MyApp->view('V', qw/foo2 bar2/);
+ my $x = $c->view('V', qw/foo2 bar2/);
is_deeply($args, [qw/foo2 bar2/], '$c->view args passed to ACCEPT_CONTEXT ok');
# regexp fallback
- MyApp->view('::View::V', qw/foo3 bar3/);
+ $c->view('::View::V', qw/foo3 bar3/);
is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok');
+
+
}
use strict;
use warnings;
+use Test::MockObject::Extends;
-use Test::More tests => 22;
+use Test::More tests => 24;
use lib 't/lib';
sub count { $count++ }
}
+my $warnings = 0;
+
+use PluginTestApp;
+my $logger = Test::MockObject::Extends->new(PluginTestApp->log);
+$logger->mock('warn', sub {
+ if ($_[1] =~ /plugin method is deprecated/) {
+ $warnings++;
+ return;
+ }
+ die "Caught unexpected warning: " . $_[1];
+});
+#PluginTestApp->log($logger);
+
use Catalyst::Test qw/PluginTestApp/;
ok( get("/compile_time_plugins"), "get ok" );
+is( $warnings, 0, 'no warnings' );
+# FIXME - Run time plugin support is insane, and should be removed
+# for Catalyst 5.9
ok( get("/run_time_plugins"), "get ok" );
+is( $warnings, 1, '1 warning' );
+
use_ok 'TestApp';
my @expected = qw(
Catalyst::Plugin::Test::Errors
Catalyst::Plugin::Test::Headers
Catalyst::Plugin::Test::Inline
Catalyst::Plugin::Test::Plugin
+ TestApp::Plugin::AddDispatchTypes
TestApp::Plugin::FullyQualified
);
--- /dev/null
+use strict;
+use warnings;
+use Catalyst::Runtime;
+
+use Test::More tests => 20;
+
+{
+ # Silence the log.
+ no warnings 'redefine';
+ *Catalyst::Log::_send_to_log = sub {};
+}
+
+TESTDEBUG: {
+ package MyTestDebug;
+ use base qw/Catalyst/;
+ __PACKAGE__->setup(
+ '-Debug',
+ );
+}
+
+ok my $c = MyTestDebug->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 disabled';
+ok !$log->is_error, 'Errors should be disabled';
+ok !$log->is_fatal, 'Fatal errors should be disabled';
+ok !$log->is_info, 'Info should be disabled';
+ok $log->is_debug, 'Debugging should be enabled';
+can_ok 'MyTestDebug', 'debug';
+ok +MyTestDebug->debug, 'And it should return true';
+
+
+TESTAPP: {
+ package MyTestLog;
+ use base qw/Catalyst/;
+ __PACKAGE__->setup(
+ '-Log=warn,error,fatal'
+ );
+}
+
+ok $c = MyTestLog->new, 'Get log app object';
+ok $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';
+ok $log->is_error, 'Errors should be enabled';
+ok $log->is_fatal, 'Fatal errors should be enabled';
+ok !$log->is_info, 'Info should be disabled';
+ok !$log->is_debug, 'Debugging should be disabled';
+
+TESTOWNLOGGER: {
+ package MyTestAppWithOwnLogger;
+ use base qw/Catalyst/;
+ use Test::MockObject;
+ my $log = Test::MockObject->new;
+ $log->set_false(qw/debug error fatal info warn/);
+ __PACKAGE__->log($log);
+ __PACKAGE__->setup('-Debug');
+}
+
+ok $c = MyTestAppWithOwnLogger->new, 'Get with own logger app object';
+ok $c->debug, '$c->debug is true';
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More tests => 16;
use URI;
use_ok('Catalyst');
is( $warnings, 0, "no warnings emitted" );
}
+# Test with parameters '/', 'foo', 'bar' - should not generate a //
+is( Catalyst::uri_for( $context, qw| / foo bar | )->as_string,
+ 'http://127.0.0.1/foo/bar', 'uri is /foo/bar, not //foo/bar'
+);
+
--- /dev/null
+# Insane test case for the behavior needed by Plugin::Auhorization::ACL
+
+# We have to localise $c->request->{arguments} in
+# Catalyst::Dispatcher::_do_forward, rather than using save and restore,
+# as otherwise, the calling $c->detach on an action which says
+# die $Catalyst:DETACH causes the request arguments to not get restored,
+# and therefore sub gorch gets the wrong string $frozjob parameter.
+
+# Please feel free to break this behavior once a sane hook for safely
+# executing another action from the dispatcher (i.e. wrapping actions)
+# is present, so that the Authorization::ACL plugin can be re-written
+# to not be full of such crazy shit.
+{
+ package ACLTestApp;
+ use Test::More;
+
+ use strict;
+ use warnings;
+ use MRO::Compat;
+ use Scalar::Util ();
+
+ use base qw/Catalyst Catalyst::Controller/;
+ use Catalyst qw//;
+
+ sub execute {
+ my $c = shift;
+ my ( $class, $action ) = @_;
+
+ if ( Scalar::Util::blessed($action)
+ and $action->name ne "foobar" ) {
+ eval { $c->detach( 'foobar', [$action, 'foo'] ) };
+ }
+
+ $c->next::method( @_ );
+ }
+
+ sub foobar : Private {
+ die $Catalyst::DETACH;
+ }
+
+ sub gorch : Local {
+ my ( $self, $c, $frozjob ) = @_;
+ is $frozjob, 'wozzle';
+ $c->res->body("gorch");
+ }
+
+ __PACKAGE__->setup;
+}
+
+use strict;
+use warnings;
+use FindBin qw/$Bin/;
+use lib "$Bin/lib";
+use Catalyst::Test 'ACLTestApp';
+use Test::More tests => 1;
+
+request('http://localhost/gorch/wozzle');
use FindBin;
use lib "$FindBin::Bin/lib";
-use Test::More tests => 48;
-
+use Test::More tests => 56;
+use FindBin qw/$Bin/;
+use lib "$Bin/lib";
+use Catalyst::Utils;
+use HTTP::Request::Common;
+use Test::Exception;
my $Class = 'Catalyst::Test';
my $App = 'TestApp';
ok( $c->action, " Action object accessible" );
} }
}
+
+# FIXME - These vhosts in tests tests should be somewhere else...
+
+sub customize { Catalyst::Test::_customize_request(@_) }
+
+{
+ my $req = Catalyst::Utils::request('/dummy');
+ customize( $req );
+ is( $req->header('Host'), undef, 'normal request is unmodified' );
+}
+
+{
+ my $req = Catalyst::Utils::request('/dummy');
+ customize( $req, { host => 'customized.com' } );
+ like( $req->header('Host'), qr/customized.com/, 'request is customizable via opts hash' );
+}
+
+{
+ my $req = Catalyst::Utils::request('/dummy');
+ local $Catalyst::Test::default_host = 'localized.com';
+ customize( $req );
+ like( $req->header('Host'), qr/localized.com/, 'request is customizable via package var' );
+}
+
+{
+ my $req = Catalyst::Utils::request('/dummy');
+ local $Catalyst::Test::default_host = 'localized.com';
+ customize( $req, { host => 'customized.com' } );
+ like( $req->header('Host'), qr/customized.com/, 'opts hash takes precedence over package var' );
+}
+
+{
+ my $req = Catalyst::Utils::request('/dummy');
+ local $Catalyst::Test::default_host = 'localized.com';
+ customize( $req, { host => '' } );
+ is( $req->header('Host'), undef, 'default value can be temporarily cleared via opts hash' );
+}
+
+# Back compat test, extra args used to be ignored, now a hashref of options.
+use_ok('Catalyst::Test', 'TestApp', 'foobar');
+
+# Back compat test, ensure that request ignores anything which isn't a hash.
+lives_ok {
+ request(GET('/dummy'), 'foo');
+} 'scalar additional param to request method ignored';
+lives_ok {
+ request(GET('/dummy'), []);
+} 'array additional param to request method ignored';
+
$stats->profile(comment => "interleave 2");
push(@expected, [ 4, "- interleave 2", 0.2, 0 ]);
+ $fudge_t[1] = 550000;
+ $stats->profile(begin => "begin with no end");
+ push(@expected, [ 4, "begin with no end", 0.05, 1 ]);
+
$fudge_t[1] = 600000; # end badly nested block time
$stats->profile(end => "badly nested block 1");
my @report = $stats->report;
is_deeply(\@report, \@expected, "report");
+ # print scalar($stats->report);
+
is ($stats->elapsed, 14, "elapsed");
}
use strict;
use warnings;
-use Test::More tests => 16;
+use Test::More tests => 18;
+use Class::MOP;
use lib "t/lib";
}
my $warnings = 0;
-$SIG{__WARN__} = sub { $warnings++ };
+$SIG{__WARN__} = sub {
+ return if $_[0] =~ /Subroutine (?:un|re|)initialize redefined at .*C3\.pm/;
+ $warnings++;
+};
-ok( !Class::Inspector->loaded("TestApp::View::Dump"), "component not yet loaded" );
+ok( !Class::MOP::is_class_loaded("TestApp::View::Dump"), "component not yet loaded" );
Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump");
-ok( Class::Inspector->loaded("TestApp::View::Dump"), "loaded ok" );
+ok( Class::MOP::is_class_loaded("TestApp::View::Dump"), "loaded ok" );
is( $warnings, 0, "no warnings emitted" );
$warnings = 0;
Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump");
is( $warnings, 0, "calling again doesn't reaload" );
-ok( !Class::Inspector->loaded("TestApp::View::Dump::Request"), "component not yet loaded" );
+ok( !Class::MOP::is_class_loaded("TestApp::View::Dump::Request"), "component not yet loaded" );
Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump::Request");
-ok( Class::Inspector->loaded("TestApp::View::Dump::Request"), "loaded ok" );
+ok( Class::MOP::is_class_loaded("TestApp::View::Dump::Request"), "loaded ok" );
is( $warnings, 0, "calling again doesn't reaload" );
eval { Catalyst::Utils::ensure_class_loaded('Silly::File::Name.pm') };
like($@, qr/Malformed class Name/, 'errored sanely when given a classname ending in .pm');
+undef $@;
+$warnings = 0;
+Catalyst::Utils::ensure_class_loaded("NullPackage");
+is( $warnings, 1, 'Loading a package which defines no symbols warns');
+is( $@, undef, '$@ still undef' );
+
projects / catagits/Catalyst-Runtime.git / commitdiff