File Coverage

blib/lib/Package/Debug/Object.pm

Criterion	Covered	Total	%
statement	110	154	71.4
branch	49	62	79.0
condition	1	3	33.3
subroutine	31	48	64.5
pod	40	40	100.0
total	231	307	75.2

use strict;
use warnings;

package Package::Debug::Object;
BEGIN {
  $Package::Debug::Object::AUTHORITY = 'cpan:KENTNL';
}
{
  $Package::Debug::Object::VERSION = '0.2.2';
}

# ABSTRACT: Object oriented guts to Package::Debug


my %env_key_styles = ( default => 'env_key_from_package', );


my %env_key_prefix_styles = ( default => 'env_key_prefix_from_package', );


my %log_prefix_styles = (
  short => 'log_prefix_from_package_short',
  long  => 'log_prefix_from_package_long',
);


my %debug_styles = (
  'prefixed_lines' => 'debug_prefixed_lines',
  'verbatim'       => 'debug_verbtaim',
);


sub new {
  my ( $self, %args ) = @_;
  return bless \%args, $self;
}


sub debug_style {
  return $_[0]->{debug_style} if exists $_[0]->{debug_style};
  return ( $_[0]->{debug_style} = 'prefixed_lines' );
}

sub set_debug_style {
  $_[0]->{debug_style} = $_[1];
  return $_[0];
}


sub env_key_aliases {
  return $_[0]->{env_key_aliases} if exists $_[0]->{env_key_aliases};
  return ( $_[0]->{env_key_aliases} = [] );
}

sub set_env_key_aliases {
  $_[0]->{env_key_aliases} = $_[1];
  return $_[0];
}


sub env_key_prefix_style {
  return $_[0]->{env_key_prefix_style} if exists $_[0]->{env_key_prefix_style};
  return ( $_[0]->{env_key_prefix_style} = 'default' );
}

sub set_env_key_prefix_style {
  $_[0]->{env_key_prefix_style} = $_[1];
  return $_[0];
}


sub env_key_style {
  return $_[0]->{env_key_style} if exists $_[0]->{env_key_style};
  return ( $_[0]->{env_key_style} = 'default' );
}

sub set_env_key_style {
  $_[0]->{env_key_style} = $_[1];
  return $_[0];
}


sub into {
  return $_[0]->{into} if exists $_[0]->{into};
  die 'Cannot vivify ->into automatically, pass to constructor or ->set_into() or ->auto_set_into()';
}

sub set_into {
  $_[0]->{into} = $_[1];
  return $_[0];
}


sub into_level {
  return $_[0]->{into_level} if exists $_[0]->{into_level};
  return ( $_[0]->{into_level} = 0 );
}

sub set_into_level {
  $_[0]->{into_level} = $_[1];
  return $_[0];
}


sub sub_name {
  return $_[0]->{sub_name} if exists $_[0]->{sub_name};
  return ( $_[0]->{sub_name} = 'DEBUG' );
}

sub set_sub_name {
  $_[0]->{sub_name} = $_[1];
  return $_[0];
}


sub value_name {
  return $_[0]->{value_name} if exists $_[0]->{value_name};
  return ( $_[0]->{value_name} = 'DEBUG' );
}

sub set_value_name {
  $_[0]->{value_name} = $_[1];
  return $_[0];
}


sub env_key {
  return $_[0]->{env_key} if exists $_[0]->{env_key};
  my $style = $_[0]->env_key_style;
  if ( not exists $env_key_styles{$style} ) {
    die "No such env_key_style $style, options are @{ keys %env_key_styles }";
  }
  my $method = $env_key_styles{$style};
  return ( $_[0]->{env_key} = $_[0]->$method() );
}

sub set_env_key {
  $_[0]->{env_key} = $_[1];
  return $_[0];
}


sub env_key_prefix {
  return $_[0]->{env_key_prefix} if exists $_[0]->{env_key_prefix};
  my $style = $_[0]->env_key_prefix_style;
  if ( not exists $env_key_prefix_styles{$style} ) {
    die "No such env_key_prefix_style $style, options are @{ keys %env_key_prefix_styles }";
  }
  my $method = $env_key_prefix_styles{$style};
  return ( $_[0]->{env_key_prefix} = $_[0]->$method() );
}

sub set_env_key_prefix {
  $_[0]->{env_key_prefix} = $_[1];
  return $_[0];
}


sub debug_sub {
  return $_[0]->{debug_sub} if exists $_[0]->{debug_sub};
  my $style = $_[0]->debug_style;
  if ( not exists $debug_styles{$style} ) {
    die "No such debug_style $style, options are @{ keys %debug_styles }";
  }
  my $method = $debug_styles{$style};
  return ( $_[0]->{debug_sub} = $_[0]->$method() );
}

sub set_debug_sub {
  $_[0]->{debug_sub} = $_[1];
  return $_[0];
}


sub log_prefix_style {
  return $_[0]->{log_prefix_style} if exists $_[0]->{log_prefix_style};
  my $style = 'short';
  $style = $ENV{PACKAGE_DEBUG_LOG_PREFIX_STYLE} if $ENV{PACKAGE_DEBUG_LOG_PREFIX_STYLE};
  return ( $_[0]->{log_prefix_style} = $style );
}

sub set_log_prefix_style {
  $_[0]->{log_prefix_style} = $_[1];
  return $_[0];
}


sub log_prefix {
  return $_[0]->{log_prefix} if exists $_[0]->{log_prefix};
  my $style = $_[0]->log_prefix_style;
  if ( not exists $log_prefix_styles{$style} ) {
    die "Unknown prefix style $style, should be one of @{ keys %log_prefix_styles }";
  }
  my $method = $log_prefix_styles{$style};
  return ( $_[0]->{log_prefix} = $_[0]->$method() );
}

sub set_log_prefix {
  $_[0]->{log_prefix} = $_[1];
  return $_[0];
}


sub is_env_debugging {
  return $_[0]->{is_env_debugging} if exists $_[0]->{is_env_debugging};
  if ( $ENV{PACKAGE_DEBUG_ALL} ) {
    return ( $_[0]->{is_env_debugging} = 1 );
  }
  for my $key ( $_[0]->env_key, @{ $_[0]->env_key_aliases } ) {
    next unless exists $ENV{$key};
    next unless $ENV{$key};
    return ( $_[0]->{is_env_debugging} = 1 );
  }
  return ( $_[0]->{is_env_debugging} = 0 );
}

sub set_is_env_debugging {
  $_[0]->{is_env_debugging} = $_[1];
  return $_[0];
}


sub into_stash {
  return $_[0]->{into_stash} if exists $_[0]->{into_stash};
  require Package::Stash;
  return ( $_[0]->{into_stash} = Package::Stash->new( $_[0]->into ) );
}

sub set_into_stash {
  $_[0]->{into_stash} = $_[1];
  return $_[0];
}


sub auto_set_into {
  my ( $self, $add ) = @_;
  $_[0]->{into} = [ caller( $self->into_level + $add ) ]->[0];
  return $self;
}


# Note: Heavy hand-optimisation going on here, this is the hotpath
sub debug_prefixed_lines {
  my $self   = shift;
  my $prefix = $self->log_prefix;
  return sub {
    my (@message) = @_;
    for my $line (@message) {
      *STDERR->print( '[' . $prefix . '] ' ) if defined $prefix;
      *STDERR->print($line);
      *STDERR->print("\n");
    }
  };
}


sub debug_verbatim {
  my $self = shift;
  return sub {
    *STDERR->print(@_);
  };
}


sub env_key_from_package {
  return $_[0]->env_key_prefix() . '_DEBUG';
}


sub env_key_prefix_from_package {
  my $package = $_[0]->into;
  $package =~ s{
    ::
  }{_}msxg;
  return uc $package;
}


sub log_prefix_from_package_short {
  my $package = $_[0]->into;
  if ( ( length $package ) < 10 ) {
    return $package;
  }
  my (@tokens) = split /::/msx, $package;
  my ($suffix) = pop @tokens;
  for (@tokens) {
    if ( $_ =~ /[[:upper:]]/msx ) {
      $_ =~ s/[[:lower:]]+//msxg;
      next;
    }
    $_ = substr $_, 0, 1;
  }
  my ($prefix) = join q{:}, @tokens;
  return $prefix . q{::} . $suffix;
}


sub log_prefix_from_package_long {
  return $_[0]->into;
}


sub inject_debug_value {
  my $value_name = $_[0]->value_name;
  return if not defined $value_name;
  my $value = $_[0]->is_env_debugging;
  my $stash = $_[0]->into_stash;
  if ( $stash->has_symbol( q[$] . $value_name ) ) {
    $value = $stash->get_symbol( q[$] . $value_name );
    $stash->remove_symbol( q[$] . $value_name );
  }
  $stash->add_symbol( q[$] . $value_name, \$value );
  return $_[0];
}

sub _wrap_debug_sub {
  my $sub_name = $_[0]->sub_name;
  return if not defined $sub_name;
  my $value_name       = $_[0]->value_name;
  my $is_env_debugging = $_[0]->is_env_debugging;
  if ( not defined $value_name and not $is_env_debugging ) {
    return sub { };
  }
  my $real_debug = $_[0]->debug_sub;
  my $symbol     = $_[0]->into_stash->get_symbol( q[$] . $value_name );
  return sub {
    return unless ${$symbol};
    goto $real_debug;
  };
}


sub inject_debug_sub {
  $_[0]->into_stash->add_symbol( q[&] . $_[0]->sub_name, $_[0]->_wrap_debug_sub );
  return $_[0];
}

1;

__END__