File Coverage

Hook/PrePostCall.pm

Criterion	Covered	Total	%
statement	66	89	74.1
branch	10	20	50.0
condition	2	5	40.0
subroutine	11	14	78.5
pod	0	7	0.0
total	89	135	65.9

# Copyright (C) 1997 Philippe Verdret
require 5.000;

package Hook::PrePostCall;
use strict;
$Hook::PrePostCall::VERSION = '1.2';
sub new {
  my $receiver = shift;
  my $class = '';

  my $callfrom = '';
  my $self = '';
  my $primary = '';

				# The primary routine
  my $name = shift;
  if ($name =~ /^(.*)::/) {
    $callfrom = ($1 or 'main');
  } else {
    $callfrom = (caller(0))[0];
    $name = "${callfrom}::" . $name;
  }

  if ($class = ref $receiver) {	# Object method
    $self = $receiver;
    $primary = ${$self->{primary}}; # initial definition
  } else {			# Class method
    $self = bless {}, $receiver;
    $primary = \&{"$name"};	# current definition
    $self->{primary} = \$primary;
  }


				# Pre and Post hooks
  my $pre = shift;
  my $post = shift;
  my $derived = '';

  $self->{callfrom} = \$callfrom;
  $self->{name} = \$name;
  $self->{pre} = \$pre;
  $self->{post} = \$post;
  $self->{derived} = \$derived;

  if ($pre and $post) {
  } elsif ($pre) {
    $post = sub { @_ };
  } elsif ($post) {
    $pre = sub{ @_ };
  } else {
    $pre = $post = sub{ @_ };
  }

  my @result = ();
  my $sub = $derived =
  sub {
    @result = &$pre;
    if (wantarray) {		# preserve the calling context
      &$post(&$primary(@result));
    } else {
      &$post(scalar &$primary(@result));
    }
  };

  $self->install($name, $sub);
  $self;
}
sub restore {
  my $self = shift;
  my $name = ${$self->{name}};
  my $sub = ${$self->{primary}};
  $self->install($name, $sub);
}
sub install {
  my $self = shift;
  my $name = shift;
  my $sub = shift;
  no strict qw(refs);		# some hackery and surgery
  my $CW = $^W; $^W = 0;
  *{$name} = $sub;
  $^W = $CW;
  use strict qw(refs);		# end of operation
  $self;
}
sub pre {
  my $self = shift;
  if (@_) {
    ${$self->{pre}} = shift;
  } else {
    ${$self->{pre}};
  }
}
sub post {
  my $self = shift;
  if (@_) {
    ${$self->{post}} = shift;
  } else {
    ${$self->{post}};
  }
}
sub primary {
  my $self = shift;
  if (@_) {
    ${$self->{primary}} = shift;
  } else {
    ${$self->{primary}};
  }
}
sub derived {
  my $self = shift;
  if (@_) {
    ${$self->{derived}} = shift;
  } else {
    ${$self->{derived}};
  }
}

1;
__END__