From: John Napiorkowski Date: Tue, 27 May 2014 15:21:10 +0000 (-0400) Subject: merge new log stuff X-Git-Tag: 5.90070~26 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=1b526dcc8437ccd8c55e8e313f3fe247b6741969 merge new log stuff --- diff --git a/Changes b/Changes index 6175a9c..f682c35 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ # This file documents the revision history for Perl extension Catalyst. +5.90069_001 + - The Catalyst::Log object now has 'autoflush' (which defaults to true) and + causes log messages to be written out in real-time. This is helpful for the + test/dev server to be able to see messages during startup as well as before + the end of the request when the log is flushed. - Set encoding on STDERR when encoding is set in config - Fix spelling, grammar and structural errors in POD - Remove redundant ->setup call in t/head_middleware.t RT#95361 diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 48f4949..2a40bc5 100755 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -126,7 +126,7 @@ __PACKAGE__->stats_class('Catalyst::Stats'); # Remember to update this in Catalyst::Runtime as well! -our $VERSION = '5.90064'; +our $VERSION = '5.90069_001'; sub import { my ( $class, @arguments ) = @_; @@ -1252,9 +1252,10 @@ EOF } $class->setup_finalize; - # Should be the last thing we do so that user things hooking - # setup_finalize can log.. + + # Flush the log for good measure (in case something turned off 'autoflush' early) $class->log->_flush() if $class->log->can('_flush'); + return $class || 1; # Just in case someone named their Application 0... } @@ -2593,18 +2594,15 @@ sub locate_components { my $class = shift; my $config = shift; - my @paths = qw( ::Controller ::C ::Model ::M ::View ::V ); + my @paths = qw( ::M ::Model ::V ::View ::C ::Controller ); my $extra = delete $config->{ search_extra } || []; - push @paths, @$extra; + unshift @paths, @$extra; - my $locator = Module::Pluggable::Object->new( - search_path => [ map { s/^(?=::)/$class/; $_; } @paths ], - %$config - ); - - # XXX think about ditching this sort entirely - my @comps = sort { length $a <=> length $b } $locator->plugins; + my @comps = map { sort { length($a) <=> length($b) } Module::Pluggable::Object->new( + search_path => [ map { s/^(?=::)/$class/; $_; } ($_) ], + %$config + )->plugins } @paths; return @comps; } @@ -3952,6 +3950,8 @@ t0m: Tomas Doran Ulf Edvinsson +vanstyn: Henry Van Styn + Viljo Marrandi C Will Hawes C diff --git a/lib/Catalyst/Log.pm b/lib/Catalyst/Log.pm old mode 100644 new mode 100755 index b834a79..e70197f --- a/lib/Catalyst/Log.pm +++ b/lib/Catalyst/Log.pm @@ -13,6 +13,7 @@ our %LEVEL_MATCH = (); # Stored as additive, thus debug = 31, warn = 30 etc has level => (is => 'rw'); has _body => (is => 'rw'); has abort => (is => 'rw'); +has autoflush => (is => 'rw', default => sub {1}); has _psgi_logger => (is => 'rw', predicate => '_has_psgi_logger', clearer => '_clear_psgi_logger'); has _psgi_errors => (is => 'rw', predicate => '_has_psgi_errors', clearer => '_clear_psgi_errors'); @@ -118,6 +119,10 @@ sub _log { $body .= sprintf( "[%s] %s", $level, $message ); $self->_body($body); } + if( $self->autoflush && !$self->abort ) { + $self->_flush; + } + return 1; } sub _flush { @@ -284,6 +289,28 @@ to use Log4Perl or another logger, you should call it like this: $c->log->abort(1) if $c->log->can('abort'); +=head2 autoflush + +When enabled (default), messages are written to the log immediately instead +of queued until the end of the request. + +This option, as well as C, is provided for modules such as +L to be able to programmatically +suppress the output of log messages. By turning off C (application-wide +setting) and then setting the C flag within a given request, all log +messages for the given request will be suppressed. C can still be set +independently of turning off C, however. It just means any messages +sent to the log up until that point in the request will obviously still be emitted, +since C means they are written in real-time. + +If you need to turn off autoflush you should do it like this (in your main app +class): + + after setup_finalize => sub { + my $c = shift; + $c->log->autoflush(0) if $c->log->can('autoflush'); + }; + =head2 _send_to_log $log->_send_to_log( @messages ); diff --git a/lib/Catalyst/Runtime.pm b/lib/Catalyst/Runtime.pm index ea41e00..7559573 100644 --- a/lib/Catalyst/Runtime.pm +++ b/lib/Catalyst/Runtime.pm @@ -7,7 +7,7 @@ BEGIN { require 5.008003; } # Remember to update this in Catalyst as well! -our $VERSION = '5.90064'; +our $VERSION = '5.90069_001'; =head1 NAME diff --git a/t/aggregate/unit_core_log.t b/t/aggregate/unit_core_log.t old mode 100644 new mode 100755 index f488d48..9d50038 --- a/t/aggregate/unit_core_log.t +++ b/t/aggregate/unit_core_log.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 22; +use Test::More tests => 24; use Catalyst::Log; @@ -21,6 +21,9 @@ can_ok $LOG, 'new'; ok my $log = $LOG->new, '... and creating a new log object should succeed'; isa_ok $log, $LOG, '... and the object it returns'; +can_ok $log, "autoflush"; +$log->autoflush(0); + can_ok $log, 'is_info'; ok $log->is_info, '... and the default behavior is to allow info messages'; @@ -50,10 +53,13 @@ like $MESSAGES[0], qr/^\[info\] hello there!$/, my $SUBCLASS = 'Catalyst::Log::Subclass'; can_ok $SUBCLASS, 'new'; ok $log = Catalyst::Log::Subclass->new, - '... and the log subclass constructor shoudl return a new object'; + '... and the log subclass constructor should return a new object'; isa_ok $log, $SUBCLASS, '... and the object it returns'; isa_ok $log, $LOG, '... and it also'; +can_ok $log, "autoflush"; +$log->autoflush(0); + can_ok $log, 'info'; ok $log->info('hi there!'), '... passing it an info message should succeed'; diff --git a/t/aggregate/unit_core_log_autoflush.t b/t/aggregate/unit_core_log_autoflush.t new file mode 100755 index 0000000..530d475 --- /dev/null +++ b/t/aggregate/unit_core_log_autoflush.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More tests => 20; + +use Catalyst::Log; + +local *Catalyst::Log::_send_to_log; +local our @MESSAGES; +{ + no warnings 'redefine'; + *Catalyst::Log::_send_to_log = sub { + my $self = shift; + push @MESSAGES, @_; + }; +} + +my $LOG = 'Catalyst::Log'; + +can_ok $LOG, 'new'; +ok my $log = $LOG->new, '... and creating a new log object should succeed'; +isa_ok $log, $LOG, '... and the object it returns'; + +can_ok $log, 'is_info'; +ok $log->is_info, '... and the default behavior is to allow info messages'; + +can_ok $log, 'info'; +ok $log->info('hello there!'), + '... passing it an info message should succeed'; + +ok @MESSAGES, '... and immediately flush the log'; +is scalar @MESSAGES, 1, '... with one log message'; +like $MESSAGES[0], qr/^\[info\] hello there!$/, + '... which should match the format we expect'; + +{ + + package Catalyst::Log::Subclass; + use base qw/Catalyst::Log/; + + sub _send_to_log { + my $self = shift; + push @MESSAGES, '---'; + push @MESSAGES, @_; + } +} + +@MESSAGES = (); # clear the message log + +my $SUBCLASS = 'Catalyst::Log::Subclass'; +can_ok $SUBCLASS, 'new'; +ok $log = Catalyst::Log::Subclass->new, + '... and the log subclass constructor should return a new object'; +isa_ok $log, $SUBCLASS, '... and the object it returns'; +isa_ok $log, $LOG, '... and it also'; + +can_ok $log, 'info'; +ok $log->info('hi there!'), + '... passing it an info message should succeed'; + +ok @MESSAGES, '... and immediately flush the log'; +is scalar @MESSAGES, 2, '... with two log messages'; +is $MESSAGES[0], '---', '... with the first one being our new data'; +like $MESSAGES[1], qr/^\[info\] hi there!$/, + '... which should match the format we expect'; +