File Coverage

blib/lib/Function/Override.pm

Criterion	Covered	Total	%
statement	89	92	96.7
branch	24	42	57.1
condition			n/a
subroutine	11	11	100.0
pod	0	4	0.0
total	124	149	83.2

package Function::Override;

use Carp;
use strict;
use vars qw( $Debug $VERSION @EXPORT );

use base qw(Exporter);

$VERSION = '0.03';
@EXPORT = qw(override);

$Debug = $ENV{PERL_FUNCTION_OVERRIDE_DEBUG} || 0 unless defined $Debug;

sub override {
    my($sym, $callback, $pkg) = @_;
    $pkg = caller() unless defined $pkg;
    &_override_function($sym, $callback, $pkg);
};

sub fill_protos {
  my $proto = shift;
  my ($n, $isref, @out, @out1, $seen_semi) = -1;
  while ($proto =~ /\S/) {
    $n++;
    push(@out1,[$n,@out]) if $seen_semi;
    push(@out, $1 . "{\$_[$n]}"),   next if $proto =~ s/^\s*\\([\@%\$\&])//;
    push(@out, "\$_[$n]"),          next if $proto =~ s/^\s*([*\$&_])//;
    push(@out, "\@_[$n..\$#_]"),    last if $proto =~ s/^\s*(;\s*)?\@//;
    $seen_semi = 1, $n--,           next if $proto =~ s/^\s*;//; # XXXX ????
    die "Unknown prototype letters: \"$proto\"";
  }
  push(@out1,[$n+1,@out]);
  @out1;
}

sub write_invocation {
  my ($core, $call, $name, @argvs) = @_;
  if (@argvs == 1) {		# No optional arguments
    my @argv = @{$argvs[0]};
    shift @argv;
    return "\t" . one_invocation($core, $call, $name, @argv) . ";\n";
  } else {
    my $else = "\t";
    my (@out, @argv, $n);
    while (@argvs) {
      @argv = @{shift @argvs};
      $n = shift @argv;
      push @out, "$ {else}if (\@_ == $n) {\n";
      $else = "\t} els";
      push @out,
          "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n";
    }
    push @out, <
	}
	die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
EOC
    return join '', @out;
  }
}

sub one_invocation {
  my ($core, $call, $name, @argv) = @_;
  local $" = ', ';
  return qq{$call(@argv)};
}

sub _override_function {
    my($sub, $callback, $pkg) = @_;
    my($name, $code, $sref, $real_proto, $proto, $core, $call);
    my $ini = $sub;

    $sub = "${pkg}::$sub" unless $sub =~ /::/;
    $name = $sub;
    $name =~ s/.*::// or $name =~ s/^&//;
    print "# _override_function: sub=$sub pkg=$pkg name=$name\n" if $Debug;
    croak "Bad subroutine name for Function::Override: $name"
      unless $name =~ /^\w+$/;
    if (defined(&$sub)) {	# user subroutine
	$sref = \&$sub;
	$proto = prototype $sref;
	$call = '&$sref';
    } elsif ($sub eq $ini) {	# Stray user subroutine
	die "$sub is not a Perl subroutine"
    } else {			# CORE subroutine
        $proto = eval { prototype "CORE::$name" };
	die "$name is neither a builtin, nor a Perl subroutine"
	  if $@;
	die "Cannot override the non-overridable builtin '$name'"
	  if not defined $proto;
	$core = 1;
	$call = "CORE::$name";
    }
    if (defined $proto) {
      $real_proto = " ($proto)";
    } else {
      $real_proto = '';
      $proto = '@';
    }
    $code = <
sub$real_proto {
	local(\$", \$!) = (', ', 0);
        \$callback->(\@_);
EOS
    my @protos = fill_protos($proto);
    $code .= write_invocation($core, $call, $name, @protos);
    $code .= "}\n";
    {
      no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
      $code = <<"CODE";
package $pkg;
$code
CODE

      print $code if $Debug;

      $code = eval($code);
      die if $@;
      local($^W) = 0;   # to avoid: Subroutine foo redefined ...
      *{$sub} = $code;
    }
}

1;

__END__