Hook::PrePostCall - Add actions before and after a routine (alpha 1.2)

HookPrePostCall documentation Contained in the HookPrePostCall distribution.

Index

Code Index:

NAME

Top

Hook::PrePostCall - Add actions before and after a routine (alpha 1.2)

SYNOPSIS

Top

  require 5.000;
  use Hook::PrePostCall;

  sub try {
    print STDERR "in try: @_\n";
    @_;
  }

  PrePostCall->new(
	     'try',
	     sub {
	       print STDERR "pre: @_\n";
	       # process the @_ content...if you want
	       @_;		# defines the 'try' arguments
	     },
	     sub {
	       print STDERR "post: @_\n";
	       # process the @_ content...if you want
	       @_;		# defines what the 'try' returns
	     }
	    );
  print try(10), "\n";

DESCRIPTION

Top

new() creates a new object of the Hook::PrePostCall class. Arguments of the new method are:

1. the name of the primary routine you want to "overload",

2. an anonymous routine to call before the primary routine,

3. an anonumous routine to call after the primary routine.

If the name of the primary subroutine has not an explicit package prefix, it is assumed to be the name of a subroutine in the current package of the caller of the new() method.

The pre routine acts as a filter of the primary routine arguments. The post routine acts as a filter of what the primary returns.

new() can be used as a class or an object method. When used as an object method the derived definition is built from the initial definition of the primary routine.

derived() Returns the overloaded routine.

pre() Returns or set the pre action part.

post() Returns or set the post action part.

primary() Returns the primary routine.

restore() Retore initial definition of the primary routine.

AUTHOR

Top

Philippe Verdret, pverdret@sonovision-itep.fr

HookPrePostCall documentation Contained in the HookPrePostCall distribution. 
# 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__