From: Tyler Riddle <t.riddle@shadowcat.co.uk>
Date: Thu, 13 Sep 2012 15:00:58 +0000 (-0700)
Subject: refactor into log routing
X-Git-Tag: v0.005000_01~16
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FLog-Contextual.git;a=commitdiff_plain;h=8112b6998fcdab96fa5f63c59b8d493b1de34076

refactor into log routing
---

diff --git a/Makefile.PL b/Makefile.PL
index 192dd02..57bd0d9 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -9,6 +9,7 @@ requires 'Data::Dumper::Concise';
 requires 'Exporter::Declare' => 0.105;
 requires 'Carp';
 requires 'Scalar::Util';
+requires 'Moo';
 
 test_requires 'Test::Fatal';
 
diff --git a/lib/Log/Contextual.pm b/lib/Log/Contextual.pm
index 1d0a1dc..df533e9 100644
--- a/lib/Log/Contextual.pm
+++ b/lib/Log/Contextual.pm
@@ -11,6 +11,7 @@ use Exporter::Declare;
 use Exporter::Declare::Export::Generator;
 use Data::Dumper::Concise;
 use Scalar::Util 'blessed';
+use Log::Contextual::Router;
 
 my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels));
 
@@ -35,140 +36,84 @@ export_tag dlog => ('____');
 export_tag log  => ('____');
 import_arguments qw(logger package_logger default_logger);
 
+sub arg_router { return $_[1] if defined $_[1]; our $Router_Instance ||= Log::Contextual::Router->new }
+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 before_import {
    my ($class, $importer, $spec) = @_;
+   my $router = $class->arg_router;
 
    die 'Log::Contextual does not have a default import list'
       if $spec->config->{default};
 
+   $router->before_import(@_);
+
    my @levels = @{$class->arg_levels($spec->config->{levels})};
    for my $level (@levels) {
       if ($spec->config->{log}) {
          $spec->add_export("&log_$level", sub (&@) {
-            _do_log( $level => _get_logger( caller ), shift @_, @_)
+            my ($code, @args) = @_;
+            my @loggers = $router->get_loggers(scalar(caller), $level);
+            foreach my $logger (@loggers) {
+               $logger->$level($code->(@args));     
+            }
+            return @args;
          });
          $spec->add_export("&logS_$level", sub (&@) {
-            _do_logS( $level => _get_logger( caller ), $_[0], $_[1])
+            my $code = shift;
+            my @loggers = $router->get_loggers(scalar(caller), $level);
+            foreach my $logger (@loggers) {
+               $logger->$level($code->(@_));     
+            }
+            return shift;
          });
       }
       if ($spec->config->{dlog}) {
          $spec->add_export("&Dlog_$level", sub (&@) {
-           my ($code, @args) = @_;
-           return _do_log( $level => _get_logger( caller ), sub {
-              local $_ = (@args?Data::Dumper::Concise::Dumper @args:'()');
-              $code->(@_)
-           }, @args );
+            my ($code, @args) = @_;
+            my $dumped = (@args?Data::Dumper::Concise::Dumper @args:'()');
+            my @loggers = $router->get_loggers(scalar(caller), $level);
+            foreach my $logger (@loggers) {
+               $logger->$level(do { local $_ = $dumped; $code->(@args); });    
+            }
+            return @args;
          });
          $spec->add_export("&DlogS_$level", sub (&$) {
-           my ($code, $ref) = @_;
-           _do_logS( $level => _get_logger( caller ), sub {
-              local $_ = Data::Dumper::Concise::Dumper $ref;
-              $code->($ref)
-           }, $ref )
+            my ($code, $ref) = @_;
+            my $dumped = Data::Dumper::Concise::Dumper $ref;
+            my @loggers = $router->get_loggers(scalar(caller), $level); 
+            foreach my $logger (@loggers) {
+               $logger->$level(do { local $_ = $dumped; $code->($ref); });
+            }
+            return $ref;
          });
       }
    }
 }
 
-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 after_import {
-   my ($class, $importer, $specs) = @_;
-
-   if (my $l = $class->arg_logger($specs->config->{logger})) {
-      set_logger($l)
-   }
-
-   if (my $l = $class->arg_package_logger($specs->config->{package_logger})) {
-      _set_package_logger_for($importer, $l)
-   }
-
-   if (my $l = $class->arg_default_logger($specs->config->{default_logger})) {
-      _set_default_logger_for($importer, $l)
-   }
-}
-
-our $Get_Logger;
-our %Default_Logger;
-our %Package_Logger;
-
-sub _set_default_logger_for {
-   my $logger = $_[1];
-   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 } }
-   }
-   $Default_Logger{$_[0]} = $logger
-}
-
-sub _set_package_logger_for {
-   my $logger = $_[1];
-   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 } }
-   }
-   $Package_Logger{$_[0]} = $logger
-}
-
-sub _get_logger($) {
-   my $package = shift;
-   (
-      $Package_Logger{$package} ||
-      $Get_Logger ||
-      $Default_Logger{$package} ||
-      die q( no logger set!  you can't try to log something without a logger! )
-   )->($package, { caller_level => 2 });
-}
+sub after_import { return arg_router()->after_import(@_) }
 
 sub set_logger {
-   my $logger = $_[0];
-   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 } }
-   }
+   my $router = arg_router();
+   my $meth = $router->can('set_logger');
 
-   warn 'set_logger (or -logger) called more than once!  This is a bad idea!'
-      if $Get_Logger;
-   $Get_Logger = $logger;
-}
+   die ref($router) . " does not support set_logger()"
+      unless defined $meth;
 
-sub with_logger {
-   my $logger = $_[0];
-   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 } }
-   }
-   local $Get_Logger = $logger;
-   $_[1]->();
+   return $router->$meth(@_);
 }
 
-sub _do_log {
-   my $level  = shift;
-   my $logger = shift;
-   my $code   = shift;
-   my @values = @_;
-
-   $logger->$level($code->(@_))
-      if $logger->${\"is_$level"};
-   @values
-}
+sub with_logger {
+   my $router = arg_router();
+   my $meth = $router->can('with_logger');
 
-sub _do_logS {
-   my $level  = shift;
-   my $logger = shift;
-   my $code   = shift;
-   my $value  = shift;
+   die ref($router) . " does not support with_logger()"
+      unless defined $meth;
 
-   $logger->$level($code->($value))
-      if $logger->${\"is_$level"};
-   $value
+   return $router->$meth(@_);
 }
 
 1;
diff --git a/lib/Log/Contextual/Role/Router.pm b/lib/Log/Contextual/Role/Router.pm
new file mode 100644
index 0000000..e127ea6
--- /dev/null
+++ b/lib/Log/Contextual/Role/Router.pm
@@ -0,0 +1,9 @@
+package Log::Contextual::Role::Router;
+
+use Moo::Role;
+
+requires 'before_import';
+requires 'after_import';
+requires 'get_loggers';
+
+1;
diff --git a/lib/Log/Contextual/Router.pm b/lib/Log/Contextual/Router.pm
new file mode 100644
index 0000000..cbab60e
--- /dev/null
+++ b/lib/Log/Contextual/Router.pm
@@ -0,0 +1,88 @@
+package Log::Contextual::Router;
+
+use Moo;
+use Scalar::Util 'blessed';
+
+with 'Log::Contextual::Role::Router';
+
+sub before_import { }
+
+sub after_import {
+   my ($self, $controller, $importer, $spec) = @_;
+   my $config = $spec->config;
+
+   if (my $l = $controller->arg_logger($config->{logger})) {
+      $self->set_logger($l)
+   }
+
+   if (my $l = $controller->arg_package_logger($config->{package_logger})) {
+      $self->_set_package_logger_for($importer, $l)
+   }
+
+   if (my $l = $controller->arg_default_logger($config->{default_logger})) {
+      $self->_set_default_logger_for($importer, $l)
+   }
+}
+
+sub with_logger {
+   my $logger = $_[1];
+   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 } }
+   }
+   local $_[0]->{Get_Logger} = $logger;
+   $_[2]->();
+}
+
+sub set_logger {
+   my $logger = $_[1];
+   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 (or -logger) called more than once!  This is a bad idea!'
+      if $_[0]->{Get_Logger};
+   $_[0]->{Get_Logger} = $logger;
+
+}
+
+sub _set_default_logger_for {
+   my $logger = $_[2];
+   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 } }
+   }
+   $_[0]->{Default_Logger}->{$_[1]} = $logger
+}
+
+sub _set_package_logger_for {
+   my $logger = $_[2];
+   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 } }
+   }
+   $_[0]->{Package_Logger}->{$_[1]} = $logger
+}
+
+sub get_loggers {
+   my ($self, $package, $level) = @_;
+   my $logger = (
+      $_[0]->{Package_Logger}->{$package} ||
+      $_[0]->{Get_Logger} ||
+      $_[0]->{Default_Logger}->{$package} ||
+      die q( no logger set!  you can't try to log something without a logger! )
+   );
+
+   $logger = $logger->($package, { caller_level => 2 });
+
+   return $logger if $logger->${\"is_$level"};
+   return (); 
+}
+
+1; 
+
diff --git a/t/arg.t b/t/arg.t
new file mode 100644
index 0000000..501bec3
--- /dev/null
+++ b/t/arg.t
@@ -0,0 +1,33 @@
+use strict;
+use warnings;
+
+use Log::Contextual::SimpleLogger;
+use Test::More 'no_plan';
+my $var_log;
+my $var;
+
+my @levels = qw(debug trace warn info error fatal);
+
+BEGIN {
+   $var_log = Log::Contextual::SimpleLogger->new({
+      levels  => [qw(trace debug info warn error fatal)],
+      coderef => sub { $var = shift }
+   })
+}
+
+use Log::Contextual qw{ :log :dlog}, -logger => $var_log;
+
+my @args = qw(fizz buzz fizzbuzz);
+
+for my $level (@levels) {
+    for my $prefix (qw(log logS Dlog DlogS)) {
+
+       my $original = local $_ = "don't tread on me";
+       my $method_name = "${prefix}_${level}";
+       my $ref = __PACKAGE__->can($method_name) or die "no ref found for method $method_name";
+
+       $ref->(sub { "$method_name" }, @args);
+       ok($_ eq $original, "\$_ was not disturbed by $method_name");
+       ok($var eq "[$level] $method_name\n", "log argument was correct");
+    }
+}
diff --git a/t/caller.t b/t/caller.t
index 3f78612..55391e7 100644
--- a/t/caller.t
+++ b/t/caller.t
@@ -16,5 +16,15 @@ my $warn_faker = sub {
    $var_log
 };
 set_logger($warn_faker);
-log_debug { 'test' };
-is($var, "[debug] test at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'fake warn');
+
+log_debug { 'test log_debug' };
+is($var, "[debug] test log_debug at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'fake warn');
+
+logS_debug { 'test logS_debug' };
+is($var, "[debug] test logS_debug at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'fake warn');
+
+logS_debug { 'test Dlog_debug' };
+is($var, "[debug] test Dlog_debug at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'fake warn');
+
+logS_debug { 'test DlogS_debug' };
+is($var, "[debug] test DlogS_debug at " . __FILE__ . " line " . (__LINE__-1) . ".\n", 'fake warn');
diff --git a/t/log-with-levels.t b/t/log-with-levels.t
index 4109750..e6371a5 100644
--- a/t/log-with-levels.t
+++ b/t/log-with-levels.t
@@ -45,7 +45,7 @@ is(
 ok( eq_array(\@foo, []), "Dlog_custom passes nothing through correctly");
 is( $DumbLogger::var, "nothing: ()", "Output for Dlog_custom is correct");
 
-ok(!main->can($_), "$_ not imported") 
+ok(!main->can($_), "$_ not imported")
    for map +( "log_$_", "logS_$_" ), qw(debug trace warn info error fatal);
 
 ok(!eval { Log::Contextual->import; 1 }, 'Blank Log::Contextual import dies');