File Coverage

blib/lib/Devel/Profiler/Plugins/Template.pm

Criterion	Covered	Total	%
statement	21	42	50.0
branch	0	4	0.0
condition	1	2	50.0
subroutine	7	9	77.7
pod			n/a
total	29	57	50.8

package Devel::Profiler::Plugins::Template;

use 5.006_001;

use Devel::Profiler::Plugins::Template::Context;

use strict;
use warnings FATAL => qw(all);

#---------------------------------------------------------------------
# constants and global variables
#---------------------------------------------------------------------
our $VERSION = 0.01;

use constant DEBUG => $ENV{DEVEL_PROFILER_PLUGIN_DEBUG} || 0;


#---------------------------------------------------------------------
# make sure that a named subroutine consists of only characters
# perl likes in subroutines.
# stolen directly from ModPerl::RegistryCooker
#---------------------------------------------------------------------
sub _tidy_sub {

  my $name = shift;

  # translate the name into a suitable name for a perl subroutine
  # stolen directly from ModPerl::RegistryCooker
  $name =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
  $name =~ s/^(\d)/_$1/;

  print STDERR __PACKAGE__ . join ' ', "::_tidy_sub() returned",
                                       "$name\n"
    if DEBUG;

  return $name;
}


#---------------------------------------------------------------------
# call Devel::Profiler::instrument()
#---------------------------------------------------------------------
sub _instrument {

  my $package = shift;
  my $sub     = shift;
  my $name    = shift;

  our $cv     = shift;

  # don't re-instrument the block - it throws off our counts
  {
    no strict;
    return if defined *{$sub}{CODE};
  }

  # stick the BLOCK in its own package so Devel::Profiler has
  # something to wrap

  my $eval = <<"EOF";
    package $package;
    sub $name { shift; \$cv->(\@_) };
    1;
EOF

  print STDERR __PACKAGE__ . join ' ', "::_instrument() eval'ing",
                                       "$eval\n"
    if DEBUG;

  eval $eval;

  die $@ if $@;

  # finally, call instrument()
  {
    no strict;
    Devel::Profiler::instrument("${package}::", $name, *{$sub}{CODE});
  }

  print STDERR __PACKAGE__ . join ' ', "::_instrument() instrumented",
                                       "${package}::${name}\n"
    if DEBUG;
}

1;


__END__