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__
return $self->new({ %$final, chain => $actions });
}
+__PACKAGE__->meta->make_immutable;
1;
__END__
$self->actions->{$name} = $action;
}
+__PACKAGE__->meta->make_immutable;
+
1;
__END__
=head1 AUTHOR
-Matt S. Trout
+Matt S. Trout
=head1 COPYRIGHT
package Catalyst::Base;
-use strict;
-use base qw/Catalyst::Controller/;
+use Moose;
+BEGIN{ extends qw/Catalyst::Controller/ };
+
1;
This program is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.
-=cut
\ No newline at end of file
+=cut
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
use Moose;
extends 'Catalyst::DispatchType';
-#use strict;
-#use base qw/Catalyst::DispatchType/;
use Text::SimpleTable;
use Catalyst::ActionChain;
use URI;
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 );
}
+__PACKAGE__->meta->make_immutable;
+
=head1 USAGE
=head2 Introduction
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
no warnings 'recursion';
+ #moose todo: reaching inside another object is bad
local $c->request->{arguments} = \@args;
$action->dispatch( $c );
return @loaded;
}
+__PACKAGE__->meta->make_immutable;
+
=head2 meta
Provided by Moose
=cut
+Catalyst::Exception::Base->meta->make_immutable;
+
package Catalyst::Exception;
use Moose;
extends($CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base');
}
+Catalyst::Exception->meta->make_immutable;
+
1;
package Catalyst::Log;
-use strict;
-#use base 'Class::Accessor::Fast';
+use Moose;
use Data::Dump;
our %LEVELS = ();
-use Moose;
-
has level => (is => 'rw');
has _body => (is => 'rw');
has abort => (is => 'rw');
-#__PACKAGE__->mk_accessors('level');
-#__PACKAGE__->mk_accessors('body');
-#__PACKAGE__->mk_accessors('abort');
-
{
my @levels = qw[ debug info warn error fatal ];
}
}
-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 ) = @_;
=head2 abort
-Should Catalyst emit logs for this request? Will be reset at the end of
-each request.
+Should Catalyst emit logs for this request? Will be reset at the end of
+each request.
*NOTE* This method is not compatible with other log apis, so if you plan
to use Log4Perl or another logger, you should call it like this:
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::Model;
-use strict;
-use base qw/Catalyst::Component/;
+use Moose;
+extends qw/Catalyst::Component/;
=head1 NAME
has uri => (is => 'rw');
has user => (is => 'rw');
has headers => (
- is => 'rw',
+ is => 'rw',
isa => 'HTTP::Headers',
handles => [qw(content_encoding content_length content_type header referer user_agent)],
);
my ($self, $params) = @_;
$self->_context->prepare_body();
if ( $params && !ref $params ) {
- $self->_context->log->warn(
+ $self->_context->log->warn(
"Attempt to retrieve '$params' with req->params(), " .
"you probably meant to call req->param('$params')" );
$params = undef;
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.
=head2 $req->hostname
Returns the hostname of the client.
-
+
=head2 $req->input
Alias for $req->body.
present.
http://localhost/path?some+keywords
-
+
$c->request->query_keywords will contain 'some keywords'
=head2 $req->match
=head2 $req->param
-Returns GET and POST parameters with a CGI.pm-compatible param method. This
+Returns GET and POST parameters with a CGI.pm-compatible param method. This
is an alternative method for accessing parameters in $c->req->parameters.
$value = $c->request->param( 'foo' );
print $c->request->query_parameters->{field};
print $c->request->query_parameters->{field}->[0];
-
+
=head2 $req->read( [$maxlength] )
Reads a chunk of data from the request body. This method is intended to be
=head2 $req->uploads
Returns a reference to a hash containing uploads. Values can be either a
-L<Catalyst::Request::Upload> object, or an arrayref of
+L<Catalyst::Request::Upload> object, or an arrayref of
L<Catalyst::Request::Upload> objects.
my $upload = $c->request->uploads->{field};
sub uri_with {
my( $self, $args ) = @_;
-
+
carp( 'No arguments passed to uri_with()' ) unless $args;
for my $value ( values %$args ) {
utf8::encode( $_ ) if utf8::is_utf8($_);
}
};
-
+
my $uri = $self->uri->clone;
-
+
$uri->query_form( {
%{ $uri->query_form_hash },
%$args
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::Request::Upload;
-use strict;
+use Moose;
use Catalyst::Exception;
use File::Copy ();
use IO::File ();
use File::Spec::Unix;
-use Moose;
-
has filename => (is => 'rw');
has headers => (is => 'rw');
has size => (is => 'rw');
=head2 $upload->link_to
-Creates a hard link to the temporary file. Returns true for success,
+Creates a hard link to the temporary file. Returns true for success,
false for failure.
$upload->link_to('/path/to/target');
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
parameters of the same name, except they are used without a leading dash.
Possible parameters are:
-=over
+=over
=item value
Sets or returns the HTTP status.
$c->response->status(404);
-
+
=head2 $res->write( $data )
Writes $data to the output stream.
=head1 COPYRIGHT
-This program is free software, you can redistribute it and/or modify
+This program is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::Stats;
-use strict;
-use warnings;
+use Moose;
use Time::HiRes qw/gettimeofday tv_interval/;
use Text::SimpleTable ();
use Tree::Simple qw/use_weak_refs/;
use Tree::Simple::Visitor::FindByUID;
-sub new {
- my $class = shift;
-
- 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]}) }
+ );
+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;
}
sub report {
my $self = shift;
-# close any remaining open nodes
- for (my $i = $#{$self->{stack}}; $i > 0; $i--) {
- $self->profile(end => $self->{stack}->[$i]->getNodeValue->{action});
- }
+ # close any remaining open nodes
+ map { $self->profile(end => $_->getNodeValue->{action}) }
+ (reverse @{ $self->stack })[1 .. $#{$self->stack}];
my $t = Text::SimpleTable->new( [ 62, 'Action' ], [ 9, 'Time' ] );
my @results;
- $self->{tree}->traverse(
+ $self->tree->traverse(
sub {
my $action = shift;
my $stat = $action->getNodeValue;
$stat->{elapsed},
$stat->{action} ? 1 : 0,
);
- $t->row( ( q{ } x $r[0] ) . $r[1],
+ $t->row( ( q{ } x $r[0] ) . $r[1],
defined $r[2] ? sprintf("%fs", $r[2]) : '??');
push(@results, \@r);
}
my $visitor = Tree::Simple::Visitor::FindByUID->new;
$visitor->searchForUID($uid);
- $self->{tree}->accept($visitor);
+ $self->tree->accept($visitor);
return $visitor->getResult;
-}
+}
1;
$c->stats->profile("completed second part of critical bit");
# more code
...
- $c->stats->profile(end => "mysub");
+ $c->stats->profile(end => "mysub");
}
Supposing mysub was called from the action "process" inside a Catalyst
=head2 new
-Constructor.
+Constructor.
$stats = Catalyst::Stats->new;
Marks a profiling point. These can appear in pairs, to time the block of code
between the begin/end pairs, or by themselves, in which case the time of
-execution to the previous profiling point will be reported.
+execution to the previous profiling point will be reported.
The argument may be either a single comment string or a list of name-value
pairs. Thus the following are equivalent:
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
package Catalyst::View;
-use strict;
-use base qw/Catalyst::Component/;
+use Moose;
+extends qw/Catalyst::Component/;
=head1 NAME
=head1 DESCRIPTION
-This is the Catalyst View base class. It's meant to be used as
+This is the Catalyst View base class. It's meant to be used as
a base class by Catalyst views.
-As a convention, views are expected to read template names from
+As a convention, views are expected to read template names from
$c->stash->{template}, and put the output into $c->res->body.
Some views default to render a template named after the dispatched
action's private name. (See L<Catalyst::Action>.)
-=head1 METHODS
+=head1 METHODS
Implements the same methods as other Catalyst components, see
L<Catalyst::Component>
push(@expected, [ 2, "- attach to uid", 0.1, 0 ]);
-
my @report = $stats->report;
is_deeply(\@report, \@expected, "report");
projects / catagits/Catalyst-Runtime.git / commitdiff