diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index 37f7a7b..9d59022 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -37,6 +37,7 @@ sub import { my $imported = _find_option('alias', $args, $caller, 'p'); { no strict 'refs'; + no warnings 'redefine'; *{"$caller\::$imported"} = $exported; *{"$caller\::np"} = \&np; } diff --git a/lib/Data/Printer/Object.pm b/lib/Data/Printer/Object.pm index 4263f55..a91fc5c 100644 --- a/lib/Data/Printer/Object.pm +++ b/lib/Data/Printer/Object.pm @@ -64,7 +64,7 @@ use Data::Printer::Filter::GenericClass; my @method_names =qw( name show_tainted show_unicode show_readonly show_lvalue show_refcount show_memsize memsize_unit print_escapes scalar_quotes escape_chars - caller_info caller_message caller_message_newline caller_message_position + caller_info caller_message caller_message_newline caller_plugin caller_message_position string_max string_overflow string_preserve resolve_scalar_refs array_max array_overflow array_preserve hash_max hash_overflow hash_preserve unicode_charnames colored theme show_weak @@ -156,6 +156,7 @@ sub _init { $self->{'caller_message_newline'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'caller_message_newline', 1); $self->{'caller_message_position'} = Data::Printer::Common::_fetch_anyof($props, 'caller_message_position', 'before', [qw(before after)]); $self->{'resolve_scalar_refs'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'resolve_scalar_refs', 0); + $self->{'caller_plugin'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'caller_plugin', undef); $self->{'string_max'} = Data::Printer::Common::_fetch_scalar_or_default($props, 'string_max', 4096); $self->{'string_preserve'} = Data::Printer::Common::_fetch_anyof( $props, @@ -763,10 +764,29 @@ sub _write_label { my @caller = caller 1; my $message = $self->caller_message; - - $message =~ s/\b__PACKAGE__\b/$caller[0]/g; - $message =~ s/\b__FILENAME__\b/$caller[1]/g; - $message =~ s/\b__LINE__\b/$caller[2]/g; + if ( $self->caller_plugin ) { + my $name = "Data::Printer::Plugin::Caller::" . $self->caller_plugin; + my $req_name = $name; + $req_name =~ s{::}{/}g; + eval { + require "${req_name}.pm"; + }; + if ($@) { + warn "$@"; + warn "Failed to load caller plugin: $name\n"; + warn "Maybe you need to install the module?\n"; + return ""; + } + my $plugin = $name->new( + parent => $self, template => $message, caller => \@caller + ); + $message = $plugin->get_message(); + } + else { + $message =~ s/\b__PACKAGE__\b/$caller[0]/g; + $message =~ s/\b__FILENAME__\b/$caller[1]/g; + $message =~ s/\b__LINE__\b/$caller[2]/g; + } my $separator = $self->caller_message_newline ? "\n" : ' '; $message = $self->maybe_colorize($message, 'caller_info'); @@ -1018,6 +1038,11 @@ When true, skips a line when printing L. When false, only a single space is added between the message and the data. (default: 1) +=head3 caller_plugin + +Name of caller plugin (default: undef). If you specify a name, +e.g. c, it will use c to print the caller information label. + =head3 caller_message_position This option controls where the L will appear diff --git a/t/025-caller_plugin.t b/t/025-caller_plugin.t new file mode 100644 index 0000000..d6c9e94 --- /dev/null +++ b/t/025-caller_plugin.t @@ -0,0 +1,44 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + use Data::Printer::Config; + no warnings 'redefine'; + *Data::Printer::Config::load_rc_file = sub { {} }; +}; + +use Data::Printer colored => 0, + use_prototypes => 0, + caller_info => 1, + caller_plugin => 'Foo'; + +if (!eval { require Capture::Tiny; 1; }) { + plan skip_all => 'Capture::Tiny not found'; +} +else { + plan tests => 1; +} + +{ + # Try to force require(..) for a caller plugin to fail.. + + # In the case the user by chance should have installed a module with + # the same name as the caller plugin, make sure it will not be found + # by erasing @INC : + local @INC = ('./lib'); + + # NOTE: local $INC{'Data/Printer/Plugin/Caller/Foo.pm'} does not work + # it just sets $INC{'Data/Printer/Plugin/Caller/Foo.pm'} to undef + # but that is enough for require "Data/Printer/Plugin/Caller/Foo.pm" not + # to fail, so we have to delete the key (and the value): + my $save = delete $INC{'Data/Printer/Plugin/Caller/Foo.pm'}; + my $var = 1; + my ($stdout, $stderr) = Capture::Tiny::capture( + sub { + p \$var, output => *STDOUT; + } + ); + like $stderr, qr/Failed to load caller plugin/, 'missing plugin'; + $INC{'Data/Printer/Plugin/Caller/Foo.pm'} = $save if defined $save; +}