File Coverage

blib/lib/Sub/Methodical.pm

Criterion	Covered	Total	%
statement	79	82	96.3
branch	13	16	81.2
condition	8	11	72.7
subroutine	16	16	100.0
pod			n/a
total	116	125	92.8

use strict;
use warnings;

package Sub::Methodical;

our $VERSION = '0.002';

my %methodical;
my %wrapped;
my %auto_methodical;

use B;
use PadWalker;
use Filter::EOF;
use Sub::Install ();
use Sub::Exporter -setup => {
  exports => [
    MODIFY_CODE_ATTRIBUTES => \&_build_MODIFY,
    AUTOLOAD => \&_build_AUTOLOAD,
  ],
  groups => {
    default => [qw(MODIFY_CODE_ATTRIBUTES)],
    inherit => [qw(AUTOLOAD)],
  },
  collectors => {
    -auto => sub {
      my ($col, $arg) = @_;
      $auto_methodical{$arg->{into}} = 1;
      push @{ $arg->{import_args} }, (
        [ 'MODIFY_CODE_ATTRIBUTES', undef ],
      );
    },
  },
};

sub _build_MODIFY {
  Filter::EOF->on_eof_call(sub {
    for my $pkg (keys %methodical) {
      for my $sub (@{ $methodical{$pkg} }) {
        _wrap($pkg, $sub);
      }
    }
    for my $pkg (keys %auto_methodical) {
      no strict 'refs';
      for my $subname (grep {
        !/^MODIFY_.+_ATTRIBUTES$/ &&
        $_ ne 'AUTOLOAD' &&
        !/^_/ &&
        *{$pkg . '::' . $_}{CODE}
      } keys %{$pkg . '::'}) {
        my $sub = \&{$pkg . '::' . $subname};
        next unless B::svref_2object($sub)->STASH->NAME eq $pkg;
        _wrap($pkg, $sub);
      }
    }
  });
  return sub {
    my ($pkg, $ref, @attrs) = @_;

    if (ref $ref eq 'CODE' and grep { $_ eq 'Methodical' } @attrs) {
      push @{ $methodical{$pkg} ||= [] }, $ref;
      @attrs = grep { $_ ne 'Methodical' } @attrs;
    }
    return @attrs;
  };
}

sub _build_AUTOLOAD {
  return sub {
    our $AUTOLOAD;
    my ($pkg, $method) = $AUTOLOAD =~ /^(.+)::(.+)$/;
    my ($wrap_pkg) = grep { $pkg->isa($_) && $wrapped{$_}{$method} }
      keys %wrapped;
    if ($wrap_pkg) {
      no strict 'refs';
      goto &{$wrap_pkg . '::' . $method};
    }
    require Carp;
    Carp::croak "Undefined subroutine &$AUTOLOAD called";
  };
}

sub _wrap {
  my ($pkg, $sub) = @_;
  require B;
  my $name = B::svref_2object($sub)->GV->NAME;
  (my $as = $name) =~ s/.*:://;
  #warn "wrapping $name ($pkg\::$as)\n";
  $wrapped{$pkg}{$as} = $sub;
  Sub::Install::reinstall_sub({
    into => $pkg,
    as   => $as,
    code => sub {
      if (eval { $_[0]->isa($pkg) }) {
        #warn "calling $name directly: @_\n";
        return $sub->(@_);
      }
      my $pad = PadWalker::peek_my(1);
      my $self = $pad->{'$self'};
      unless ($self) {
        die "can't find \$self!";
      }
      unless (eval { $$self->isa($pkg) }) {
        require Carp;
        Carp::croak sprintf
          "Methodical '%s' called with incorrect invocant '%s' (wanted '%s')",
          $as, $$self, $pkg;
      }
      #warn "calling $name with self = $$self, @_\n";
      $$self->$as(@_);
    },
  });
}

1;
__END__