named logger support

diff --git a/lib/Log/Contextual.pm b/lib/Log/Contextual.pm
index 5b43622..350d8df 100644 (file)
--- a/lib/Log/Contextual.pm
+++ b/lib/Log/Contextual.pm
@@ -28,12 +28,12 @@ sub ____ {}
 
 exports ('____',
    @dlog, @log,
-   qw( set_logger with_logger )
+   qw( set_logger with_logger set_logger_for )
 );
 
 export_tag dlog => ('____');
 export_tag log  => ('____');
-import_arguments qw(logger package_logger default_logger);
+import_arguments qw(logger_for logger package_logger default_logger);
 
 sub before_import {
    my ($class, $importer, $spec) = @_;
@@ -74,10 +74,15 @@ sub arg_logger { $_[1] }
 sub arg_levels { $_[1] || [qw(debug trace warn info error fatal)] }
 sub arg_package_logger { $_[1] }
 sub arg_default_logger { $_[1] }
+sub arg_logger_for { $_[1] }
 
 sub after_import {
    my ($class, $importer, $specs) = @_;
 
+   if (my $l = $class->arg_logger_for($specs->config->{logger_for})) {
+      set_logger_for($_, $l->{$_}) for keys %$l
+   }
+
    if (my $l = $class->arg_logger($specs->config->{logger})) {
       set_logger($l)
    }
@@ -94,9 +99,20 @@ sub after_import {
 our $Get_Logger;
 our %Default_Logger;
 our %Package_Logger;
+our %Named_Logger;
 
 sub _set_default_logger_for {
    my $logger = $_[1];
+   warn "Setting default logger!";
+
+   if (!ref $logger) {
+      my $tag_name = $logger;
+      $logger = sub {
+         $Named_Logger{$tag_name}
+            or die "no such named logger '$tag_name'!"
+      }
+   }
+
    if(ref $logger ne 'CODE') {
       die 'logger was not a CodeRef or a logger object.  Please try again.'
          unless blessed($logger);
@@ -107,6 +123,14 @@ sub _set_default_logger_for {
 
 sub _set_package_logger_for {
    my $logger = $_[1];
+   if (!ref $logger) {
+      my $tag_name = $logger;
+      $logger = sub {
+         $Named_Logger{$tag_name}
+            or die "no such named logger '$tag_name'!"
+      }
+   }
+
    if(ref $logger ne 'CODE') {
       die 'logger was not a CodeRef or a logger object.  Please try again.'
          unless blessed($logger);
@@ -118,15 +142,36 @@ sub _set_package_logger_for {
 sub _get_logger($) {
    my $package = shift;
    (
-      $Package_Logger{$package} ||
+      ($Package_Logger{$package} && $Package_Logger{$package}->($package)) ||
       $Get_Logger ||
-      $Default_Logger{$package} ||
+      ($Default_Logger{$package} && $Default_Logger{$package}->($package)) ||
       die q( no logger set!  you can't try to log something without a logger! )
    )->($package);
 }
 
+sub set_logger_for {
+   my ($tag,$logger,$really_override) = @_;
+   if(ref $logger ne 'CODE') {
+      die 'logger was not a CodeRef or a logger object.  Please try again.'
+         unless blessed($logger);
+
+       $logger = do { my $l = $logger; sub { $l } }
+   }
+
+   warn "set_logger_for (or -logger_for) called more than once for this ($tag) tag!  " .
+      'this is generally a bad idea!'
+      if $Named_Logger{$tag} && !$really_override;
+   $Named_Logger{$tag} = $logger
+}
+
 sub set_logger {
    my $logger = $_[0];
+   if (!ref $logger) {
+      my $tag_name = $logger;
+      $logger = $Named_Logger{$logger}
+         or die "no such named logger '$tag_name'!"
+   }
+
    if(ref $logger ne 'CODE') {
       die 'logger was not a CodeRef or a logger object.  Please try again.'
          unless blessed($logger);
@@ -140,6 +185,13 @@ sub set_logger {
 
 sub with_logger {
    my $logger = $_[0];
+
+   if (!ref $logger) {
+      my $tag_name = $logger;
+      $logger = $Named_Logger{$logger}
+         or die "no such named logger '$tag_name'!"
+   }
+
    if(ref $logger ne 'CODE') {
       die 'logger was not a CodeRef or a logger object.  Please try again.'
          unless blessed($logger);

diff --git a/t/tagged-loggers.t b/t/tagged-loggers.t
new file mode 100644 (file)
index 0000000..68e94c3
--- /dev/null
+++ b/t/tagged-loggers.t
@@ -0,0 +1,94 @@
+use strict;
+use warnings;
+
+use Log::Contextual::SimpleLogger;
+
+my $var2;
+my $var_logger2;
+BEGIN {
+   $var_logger2 = Log::Contextual::SimpleLogger->new({
+      levels  => [qw(trace debug info warn error fatal)],
+      coderef => sub { $var2 = shift },
+   })
+}
+
+use Log::Contextual qw{:log with_logger set_logger set_logger_for},
+   -logger_for => { 'MyApp::View' => $var_logger2 },
+   -logger => 'MyApp::View';
+use Test::More qw(no_plan);
+
+my $var1;
+my $var3;
+BEGIN {
+   my $var_logger1 = Log::Contextual::SimpleLogger->new({
+      levels  => [qw(trace debug info warn error fatal)],
+      coderef => sub { $var1 = shift },
+   });
+
+   my $var_logger3 = Log::Contextual::SimpleLogger->new({
+      levels  => [qw(trace debug info warn error fatal)],
+      coderef => sub { $var3 = shift },
+   });
+
+   set_logger_for 'MyApp::Model' => $var_logger1;
+   set_logger_for 'MyApp::Controller' => sub {
+      my $package = shift;
+      Log::Contextual::SimpleLogger->new({
+         levels  => [qw(trace debug info warn error fatal)],
+         coderef => sub { $var3 = (shift @_) . $package },
+      })
+   };
+};
+
+log_debug { 'should log to $var2 from global' };
+is($var2, "[debug] should log to \$var2 from global\n", 'tag from -logger works');
+$var2 = '';
+
+with_logger 'MyApp::Model' => sub {
+   log_debug { 'should log to $var1' };
+};
+
+is($var1, "[debug] should log to \$var1\n", 'basic tag works');
+
+with_logger 'MyApp::View' => sub {
+   log_debug { 'should log to $var2' };
+};
+
+is($var2, "[debug] should log to \$var2\n", 'basic tag from -logger_for works');
+
+with_logger 'MyApp::Controller' => sub { Animorph::lol() };
+
+is($var3, "[debug] should log to \$var3\nAnimorph", 'with logger outside of package works');
+
+$var3 = '';
+
+Zilog::lol();
+
+is($var3, "[debug] should log to \$var3\nZilog", '-package_logger => "named_logger" works');
+
+$var3 = '';
+
+Mario::lol();
+
+is($var3, "[debug] should log to \$var3\nMario", '-default_logger => "named_logger" works');
+
+BEGIN {
+   package Animorph;
+   use Log::Contextual ':log';
+
+   sub lol { log_debug { 'should log to $var3' } }
+}
+
+BEGIN {
+   package Zilog;
+   use Log::Contextual ':log', -package_logger => 'MyApp::Controller';
+
+   sub lol { log_debug { 'should log to $var3' } }
+}
+
+BEGIN {
+   package Mario;
+   use Log::Contextual ':log', -default_logger => 'MyApp::Controller';
+
+   sub lol { warn "foo"; log_debug { 'should log to $var3' } }
+}