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 0195e69..54f33f4 100644 (file)
--- a/lib/Log/Contextual.pm
+++ b/lib/Log/Contextual.pm
@@ -1,11 +1,10 @@
 package Log::Contextual;
 
+# ABSTRACT: Simple logging interface with a contextual log
+
 use strict;
 use warnings;
 
-our $VERSION = '0.005005';
-$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
-
 my @levels = qw(debug trace warn info error fatal);
 
 use Exporter::Declare;
@@ -13,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;
@@ -27,10 +52,7 @@ eval {
 # export anything but the levels selected
 sub ____ { }
 
-exports ('____',
-   @dlog, @log,
-   qw( set_logger with_logger )
-);
+exports('____', @dlog, @log, qw( set_logger with_logger ));
 
 export_tag dlog => ('____');
 export_tag log  => ('____');
@@ -82,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(
@@ -108,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(
@@ -124,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 {
@@ -144,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 {
@@ -183,20 +220,16 @@ for (qw(set with)) {
    no strict 'refs';
    my $sub = "${_}_logger";
    *{"Log::Contextual::$sub"} = sub {
-      die "$sub is no longer a direct sub in Log::Contextual.  " .
-      'Note that this feature was never tested nor documented.  ' .
-      "Please fix your code to import $sub instead of trying to use it directly"
-   }
+      die "$sub is no longer a direct sub in Log::Contextual.  "
+        . 'Note that this feature was never tested nor documented.  '
+        . "Please fix your code to import $sub instead of trying to use it directly"
+     }
 }
 
 1;
 
 __END__
 
-=head1 NAME
-
-Log::Contextual - Simple logging interface with a contextual log
-
 =head1 SYNOPSIS
 
  use Log::Contextual qw( :log :dlog set_logger with_logger );
@@ -674,10 +707,6 @@ functions. The router singleton is available as the return value of the router()
 of Log::Contextual may overload router() to return instances of custom log routers that
 could for example work with loggers that use a different interface.
 
-=head1 AUTHOR
-
-frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
-
 =head1 CONTRIBUTORS
 
 =encoding utf8
@@ -690,15 +719,5 @@ voj - Jakob Voß <voss@gbv.de>
 
 mst - Matt S. Trout <mst@shadowcat.co.uk>
 
-=head1 COPYRIGHT
-
-Copyright (c) 2012 the Log::Contextual L</AUTHOR> and L</DESIGNER> as listed
-above.
-
-=head1 LICENSE
-
-This library is free software and may be distributed under the same terms as
-Perl 5 itself.
-
 =cut