File Coverage

blib/lib/Devel/TraceLoad/Hook.pm

Criterion	Covered	Total	%
statement	51	51	100.0
branch	13	14	92.8
condition			n/a
subroutine	10	10	100.0
pod	1	1	100.0
total	75	76	98.6

package Devel::TraceLoad::Hook;

use strict;
use warnings;

=head1 NAME

Devel::TraceLoad::Hook - Install a hook function to be called for each require.

=head1 VERSION

This document describes Devel::TraceLoad::Hook version 1.04

=head1 SYNOPSIS

    register_require_hook( sub {
        my ( $when, $depth, $arg, $p, $f, $l, $rc, $err ) = @_;
        # ... do stuff ...
    } );

=head1 DESCRIPTION

Allows hook functions that will be called before and after each
C (and C) to be registered.

=head1 INTERFACE

=cut

use base qw(Exporter);
use vars qw/$VERSION @EXPORT_OK/;

@EXPORT_OK = qw( register_require_hook );
$VERSION   = '1.04';

my @hooks;

{
  my $installed = 0;

  sub _install_hook {
    return if $installed;
    my $depth = 0;
    no warnings 'redefine';
    *CORE::GLOBAL::require = sub {

      my ( $p, $f, $l ) = caller;
      my $arg = @_ ? $_[0] : $_;
      my $rc;

      $depth++;

      # If a 'before' hook throws an error we'll still call the
      # 'after' hooks - to keep everything in balance.
      eval { _call_hooks( 'before', $depth, $arg, $p, $f, $l ) };

      # Only call require if the 'before' hooks succeeded.
      $rc = eval { CORE::require $arg } unless $@;

      # Save the error for later
      my $err = $@;

      # Call the 'after' hooks whatever happened.
      {
        local $@;    # Things break if we trample on $@
        eval {
          _call_hooks( 'after', $depth, $arg, $p, $f, $l, $rc, $err );
        };
        if ( my $err = $@ ) {
          $err =~ s/\s+/ /g;
          warn "Unexpected error $err in require hook\n";
        }
      }

      $depth--;

      if ( $err ) {

       # TODO: We don't seem to get the expected line number fix up here
        $err =~ s/at \s+ .*? \s+ line \s+ \d+/at $f line $l/x;
        die $err;
      }
      return $rc;
    };
    $installed++;
  }
}

sub import {
  my $pkg = shift;
  _install_hook();
  local $Exporter::ExportLevel += 1;
  return $pkg->SUPER::import( @_ );
}

sub _call_hooks {
  my @errs = ();

  for my $hook ( @hooks ) {
    eval { $hook->( @_ ) };
    push @errs, $@ if $@;
  }

  # Rethrow after calling all the hooks. We assume that usually only
  # one hook will fail and that we'll be rethrowing that error here -
  # but we concatenate all the errors so that when multiple hooks fail
  # someone gets to see the diagnostic.

  die join( ', ', @errs ) if @errs;
}

=head2 C<< register_require_hook >>

Register a function to be called immediately before and after each
C (and C).

The registered function should look something like this:

    sub done_require {
        my ( $when, $depth, $arg, $p, $f, $l, $rc, $err ) = @_;
        # ... do stuff ...
    }

The arguments are as follows:

=over

=item C<$when>

The hook function is called both before and after the require is
executed. The first argument will contain either 'before' or 'after' as
appropriate.

=item C<$depth>

How deeply nested this require is.

=item C<$arg>

The argument to C.

=item C<$p>, C<$f>, C<$l>

The package, file and line where the calling C or C is.

=item C<$rc>, C<$err>

When the hook function is called after a C C<$rc> and
C<$err> will contain the return value of the require and any error
that it raised.

=back

You may throw an error (using C) from the hook function. If an
error is thrown during 'before' processing the real call to C
will not take place. In this way it is possible to simulate a module
being unavailable.

See L for a complete example of this interface.

=cut

sub register_require_hook { push @hooks, @_ }

1;

__END__