Stop depending on XS module Sub::Identify

[p5sagit/Log-Contextual.git] / lib / Log / Contextual.pm

diff --git a/lib/Log/Contextual.pm b/lib/Log/Contextual.pm
index e01f048..54f33f4 100644 (file)
--- a/lib/Log/Contextual.pm
+++ b/lib/Log/Contextual.pm
@@ -12,10 +12,36 @@ use Exporter::Declare::Export::Generator;
 use Data::Dumper::Concise;
 use Scalar::Util 'blessed';
 
+use B qw(svref_2object);
+
+sub stash_name {
+   my ($coderef) = @_;
+   ref $coderef or return;
+   my $cv = B::svref_2object($coderef);
+   $cv->isa('B::CV') or return;
+   # bail out if GV is undefined
+   $cv->GV->isa('B::SPECIAL') and return;
+
+   return $cv->GV->STASH->NAME;
+}
+
 my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels));
 
 my @log = ((map "log_$_", @levels), (map "logS_$_", @levels));
 
+sub _maybe_export {
+   my ($spec, $target, $name, $new_code) = @_;
+
+   if (my $code = $target->can($name)) {
+
+      # this will warn
+      $spec->add_export("&$name", $new_code)
+        unless (stash_name($code) eq __PACKAGE__);
+   } else {
+      $spec->add_export("&$name", $new_code)
+   }
+}
+
 eval {
    require Log::Log4perl;
    die if $Log::Log4perl::VERSION < 1.29;
@@ -78,21 +104,27 @@ sub before_import {
       die ref($router) . " does not support set_logger()"
         unless $router->does('Log::Contextual::Role::Router::SetLogger');
 
-      $spec->add_export('&set_logger', sub { $router->set_logger(@_) })
+      _maybe_export($spec, $importer, 'set_logger',
+         sub { $router->set_logger(@_) },
+      );
    }
 
    if ($exports->{'&with_logger'}) {
       die ref($router) . " does not support with_logger()"
         unless $router->does('Log::Contextual::Role::Router::WithLogger');
 
-      $spec->add_export('&with_logger', sub { $router->with_logger(@_) })
+      _maybe_export($spec, $importer, 'with_logger',
+         sub { $router->with_logger(@_) },
+      );
    }
 
    my @levels = @{$class->arg_levels($spec->config->{levels})};
    for my $level (@levels) {
       if ($spec->config->{log} || $exports->{"&log_$level"}) {
-         $spec->add_export(
-            "&log_$level",
+         _maybe_export(
+            $spec,
+            $importer,
+            "log_$level",
             sub (&@) {
                my ($code, @args) = @_;
                $router->handle_log_request(
@@ -104,11 +136,14 @@ sub before_import {
                   message_args   => \@args,
                );
                return @args;
-            });
+            },
+         );
       }
       if ($spec->config->{log} || $exports->{"&logS_$level"}) {
-         $spec->add_export(
-            "&logS_$level",
+         _maybe_export(
+            $spec,
+            $importer,
+            "logS_$level",
             sub (&@) {
                my ($code, @args) = @_;
                $router->handle_log_request(
@@ -120,11 +155,14 @@ sub before_import {
                   message_args   => \@args,
                );
                return $args[0];
-            });
+            },
+         );
       }
       if ($spec->config->{dlog} || $exports->{"&Dlog_$level"}) {
-         $spec->add_export(
-            "&Dlog_$level",
+         _maybe_export(
+            $spec,
+            $importer,
+            "Dlog_$level",
             sub (&@) {
                my ($code, @args) = @_;
                my $wrapped = sub {
@@ -140,11 +178,14 @@ sub before_import {
                   message_args   => \@args,
                );
                return @args;
-            });
+            },
+         );
       }
       if ($spec->config->{dlog} || $exports->{"&DlogS_$level"}) {
-         $spec->add_export(
-            "&DlogS_$level",
+         _maybe_export(
+            $spec,
+            $importer,
+            "DlogS_$level",
             sub (&$) {
                my ($code, $ref) = @_;
                my $wrapped = sub {