From: Guillermo Roditi <groditi@gmail.com>
Date: Mon, 23 Jun 2008 21:17:40 +0000 (+0000)
Subject: enabling immutable finishing porting Log and stats
X-Git-Tag: 5.8000_03~107
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=e5ecd5bc38bac3e2fcfaf643ea2a4c6ab46d7e57

enabling immutable finishing porting Log and stats
r17131@martha (orig r7537):  groditi | 2008-03-31 19:54:34 -0400
---

diff --git a/lib/Catalyst/Action.pm b/lib/Catalyst/Action.pm
index 9815391..a1e2e41 100644
--- a/lib/Catalyst/Action.pm
+++ b/lib/Catalyst/Action.pm
@@ -67,12 +67,17 @@ sub execute {
 
 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__
diff --git a/lib/Catalyst/ActionChain.pm b/lib/Catalyst/ActionChain.pm
index 60fd6db..e018280 100644
--- a/lib/Catalyst/ActionChain.pm
+++ b/lib/Catalyst/ActionChain.pm
@@ -57,6 +57,7 @@ sub from_chain {
     return $self->new({ %$final, chain => $actions });
 }
 
+__PACKAGE__->meta->make_immutable;
 1;
 
 __END__
diff --git a/lib/Catalyst/ActionContainer.pm b/lib/Catalyst/ActionContainer.pm
index ca36862..e2292e0 100644
--- a/lib/Catalyst/ActionContainer.pm
+++ b/lib/Catalyst/ActionContainer.pm
@@ -48,6 +48,8 @@ sub add_action {
     $self->actions->{$name} = $action;
 }
 
+__PACKAGE__->meta->make_immutable;
+
 1;
 
 __END__
@@ -83,7 +85,7 @@ Provided by Moose
 
 =head1 AUTHOR
 
-Matt S. Trout 
+Matt S. Trout
 
 =head1 COPYRIGHT
 
diff --git a/lib/Catalyst/Base.pm b/lib/Catalyst/Base.pm
index 5d8a4e6..24f730e 100644
--- a/lib/Catalyst/Base.pm
+++ b/lib/Catalyst/Base.pm
@@ -1,7 +1,8 @@
 package Catalyst::Base;
 
-use strict;
-use base qw/Catalyst::Controller/;
+use Moose;
+BEGIN{ extends qw/Catalyst::Controller/ };
+
 
 1;
 
@@ -31,4 +32,4 @@ Matt S Trout, C<mst@shadowcatsystems.co.uk>
 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
diff --git a/lib/Catalyst/DispatchType.pm b/lib/Catalyst/DispatchType.pm
index e885824..b368473 100644
--- a/lib/Catalyst/DispatchType.pm
+++ b/lib/Catalyst/DispatchType.pm
@@ -71,4 +71,6 @@ the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/DispatchType/Chained.pm b/lib/Catalyst/DispatchType/Chained.pm
index 257f7fb..267240d 100644
--- a/lib/Catalyst/DispatchType/Chained.pm
+++ b/lib/Catalyst/DispatchType/Chained.pm
@@ -3,8 +3,6 @@ package Catalyst::DispatchType::Chained;
 use Moose;
 extends 'Catalyst::DispatchType';
 
-#use strict;
-#use base qw/Catalyst::DispatchType/;
 use Text::SimpleTable;
 use Catalyst::ActionChain;
 use URI;
@@ -121,20 +119,21 @@ Calls C<recurse_match> to see if a chain matches the 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 );
 
@@ -329,6 +328,8 @@ sub uri_for_action {
 
 }
 
+__PACKAGE__->meta->make_immutable;
+
 =head1 USAGE
 
 =head2 Introduction
diff --git a/lib/Catalyst/DispatchType/Default.pm b/lib/Catalyst/DispatchType/Default.pm
index 50a1630..7981ac2 100644
--- a/lib/Catalyst/DispatchType/Default.pm
+++ b/lib/Catalyst/DispatchType/Default.pm
@@ -61,4 +61,6 @@ the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/DispatchType/Index.pm b/lib/Catalyst/DispatchType/Index.pm
index ca68118..63b864d 100644
--- a/lib/Catalyst/DispatchType/Index.pm
+++ b/lib/Catalyst/DispatchType/Index.pm
@@ -69,4 +69,6 @@ the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/DispatchType/Path.pm b/lib/Catalyst/DispatchType/Path.pm
index 36aaa1f..95cf445 100644
--- a/lib/Catalyst/DispatchType/Path.pm
+++ b/lib/Catalyst/DispatchType/Path.pm
@@ -140,4 +140,6 @@ the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/DispatchType/Regex.pm b/lib/Catalyst/DispatchType/Regex.pm
index 61740da..ed26885 100644
--- a/lib/Catalyst/DispatchType/Regex.pm
+++ b/lib/Catalyst/DispatchType/Regex.pm
@@ -161,4 +161,6 @@ the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/Dispatcher.pm b/lib/Catalyst/Dispatcher.pm
index 067f721..86ac3b9 100644
--- a/lib/Catalyst/Dispatcher.pm
+++ b/lib/Catalyst/Dispatcher.pm
@@ -170,6 +170,7 @@ sub forward {
 
     no warnings 'recursion';
 
+    #moose todo: reaching inside another object is bad
     local $c->request->{arguments} = \@args;
     $action->dispatch( $c );
 
@@ -529,6 +530,8 @@ sub _load_dispatch_types {
     return @loaded;
 }
 
+__PACKAGE__->meta->make_immutable;
+
 =head2 meta
 
 Provided by Moose
diff --git a/lib/Catalyst/Exception.pm b/lib/Catalyst/Exception.pm
index 02610a4..7a59a57 100644
--- a/lib/Catalyst/Exception.pm
+++ b/lib/Catalyst/Exception.pm
@@ -60,6 +60,8 @@ it under the same terms as Perl itself.
 
 =cut
 
+Catalyst::Exception::Base->meta->make_immutable;
+
 package Catalyst::Exception;
 
 use Moose;
@@ -69,4 +71,6 @@ BEGIN {
     extends($CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base');
 }
 
+Catalyst::Exception->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/Log.pm b/lib/Catalyst/Log.pm
index 01ff75f..c1ba85a 100644
--- a/lib/Catalyst/Log.pm
+++ b/lib/Catalyst/Log.pm
@@ -1,21 +1,14 @@
 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 ];
 
@@ -43,12 +36,13 @@ has abort => (is => 'rw');
     }
 }
 
-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 ) = @_;
@@ -221,8 +215,8 @@ Is the log level active?
 
 =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:
@@ -256,4 +250,6 @@ it under the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/Model.pm b/lib/Catalyst/Model.pm
index 356745e..0cd5dd2 100644
--- a/lib/Catalyst/Model.pm
+++ b/lib/Catalyst/Model.pm
@@ -1,7 +1,7 @@
 package Catalyst::Model;
 
-use strict;
-use base qw/Catalyst::Component/;
+use Moose;
+extends qw/Catalyst::Component/;
 
 =head1 NAME
 
diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm
index e134fbe..dfec6d0 100644
--- a/lib/Catalyst/Request.pm
+++ b/lib/Catalyst/Request.pm
@@ -23,7 +23,7 @@ has captures          => (is => 'rw', default => sub { [] });
 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)],
 );
@@ -68,7 +68,7 @@ before parameters => sub {
   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;
@@ -223,7 +223,7 @@ be either a scalar or an arrayref containing scalars.
     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.
@@ -290,7 +290,7 @@ Returns an L<HTTP::Headers> object containing the headers for the current reques
 =head2 $req->hostname
 
 Returns the hostname of the client.
-    
+
 =head2 $req->input
 
 Alias for $req->body.
@@ -301,7 +301,7 @@ Contains the keywords portion of a query string, when no '=' signs are
 present.
 
     http://localhost/path?some+keywords
-    
+
     $c->request->query_keywords will contain 'some keywords'
 
 =head2 $req->match
@@ -316,7 +316,7 @@ Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
 
 =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' );
@@ -425,7 +425,7 @@ be either a scalar or an arrayref containing scalars.
 
     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
@@ -518,7 +518,7 @@ sub upload {
 =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};
@@ -538,7 +538,7 @@ preserved.
 
 sub uri_with {
     my( $self, $args ) = @_;
-    
+
     carp( 'No arguments passed to uri_with()' ) unless $args;
 
     for my $value ( values %$args ) {
@@ -548,9 +548,9 @@ sub uri_with {
             utf8::encode( $_ ) if utf8::is_utf8($_);
         }
     };
-    
+
     my $uri = $self->uri->clone;
-    
+
     $uri->query_form( {
         %{ $uri->query_form_hash },
         %$args
@@ -585,4 +585,6 @@ it under the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/Request/Upload.pm b/lib/Catalyst/Request/Upload.pm
index d496aa1..02848b2 100644
--- a/lib/Catalyst/Request/Upload.pm
+++ b/lib/Catalyst/Request/Upload.pm
@@ -1,14 +1,12 @@
 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');
@@ -103,7 +101,7 @@ Returns an L<HTTP::Headers> object for the request.
 
 =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');
@@ -186,4 +184,6 @@ it under the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/Response.pm b/lib/Catalyst/Response.pm
index 1a723dc..3b57cab 100644
--- a/lib/Catalyst/Response.pm
+++ b/lib/Catalyst/Response.pm
@@ -84,7 +84,7 @@ The keys of the hash reference on the right correspond to the L<CGI::Cookie>
 parameters of the same name, except they are used without a leading dash.
 Possible parameters are:
 
-=over 
+=over
 
 =item value
 
@@ -144,7 +144,7 @@ Sets or returns the HTTP 'Location'.
 Sets or returns the HTTP status.
 
     $c->response->status(404);
-    
+
 =head2 $res->write( $data )
 
 Writes $data to the output stream.
@@ -165,9 +165,11 @@ Marcus Ramberg, C<mramberg@cpan.org>
 
 =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;
diff --git a/lib/Catalyst/Stats.pm b/lib/Catalyst/Stats.pm
index 7a9776c..5fadca6 100644
--- a/lib/Catalyst/Stats.pm
+++ b/lib/Catalyst/Stats.pm
@@ -1,86 +1,81 @@
 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;
 }
@@ -92,14 +87,13 @@ sub elapsed {
 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;
@@ -109,7 +103,7 @@ sub report {
                       $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);
                 }
@@ -122,9 +116,9 @@ sub _get_uid {
 
     my $visitor = Tree::Simple::Visitor::FindByUID->new;
     $visitor->searchForUID($uid);
-    $self->{tree}->accept($visitor);
+    $self->tree->accept($visitor);
     return $visitor->getResult;
-} 
+}
 
 1;
 
@@ -174,7 +168,7 @@ be like this:
     $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
@@ -201,7 +195,7 @@ part 0.111s.
 
 =head2 new
 
-Constructor. 
+Constructor.
 
     $stats = Catalyst::Stats->new;
 
@@ -220,7 +214,7 @@ Enable or disable stats collection.  By default, stats are enabled after object
 
 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:
@@ -309,4 +303,6 @@ it under the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/lib/Catalyst/View.pm b/lib/Catalyst/View.pm
index 40ed724..f4e8cad 100644
--- a/lib/Catalyst/View.pm
+++ b/lib/Catalyst/View.pm
@@ -1,7 +1,7 @@
 package Catalyst::View;
 
-use strict;
-use base qw/Catalyst::Component/;
+use Moose;
+extends qw/Catalyst::Component/;
 
 =head1 NAME
 
@@ -19,15 +19,15 @@ Catalyst::View - Catalyst View base class
 
 =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>
diff --git a/t/unit_stats.t b/t/unit_stats.t
index 35d1646..a8579eb 100644
--- a/t/unit_stats.t
+++ b/t/unit_stats.t
@@ -80,7 +80,6 @@ $stats->profile(end => "block", comment => "end block");
 
 push(@expected, [ 2, "- attach to uid", 0.1, 0 ]);
 
-
 my @report = $stats->report;
 is_deeply(\@report, \@expected, "report");