File Coverage

blib/lib/MRO/Magic.pm

Criterion	Covered	Total	%
statement	81	82	98.7
branch	18	20	90.0
condition	4	5	80.0
subroutine	17	18	94.4
pod			n/a
total	120	125	96.0

package MRO::Magic 0.100002;
use 5.010; # uvar magic does not work prior to version 10
use strict;
use warnings;
# ABSTRACT: write your own method dispatcher

use mro;
use MRO::Define;
use Scalar::Util qw(reftype);
use Variable::Magic qw/wizard cast/;

#pod =head1 WARNING
#pod
#pod First off, at present (2009-05-25) this code requires a development version of
#pod perl.  It should run on perl5 v10.1, but that isn't out yet, so be patient or
#pod install a development perl.
#pod
#pod Secondly, the API is not guaranteed to change in massive ways.  This code is
#pod the result of playing around, not of careful design.
#pod
#pod Finally, using MRO::Magic anywhere will impact the performance of I of
#pod your program.  Every time a method is called via MRO::Magic, the entire method
#pod resolution class for all classes is cleared.
#pod
#pod B
#pod
#pod =head1 USAGE
#pod
#pod First you write a method dispatcher.
#pod
#pod   package MRO::Classless;
#pod   use MRO::Magic
#pod     metamethod => \'invoke_method',
#pod     passthru   => [ qw(VERSION import unimport DESTROY) ];
#pod
#pod   sub invoke_method {
#pod     my ($invocant, $method_name, $args) = @_;
#pod
#pod     ...
#pod
#pod     return $rv;
#pod   }
#pod
#pod In a class using this dispatcher, any method not in the passthru specification
#pod is redirected to C, which can do any kind of ridiculous thing it
#pod wants.
#pod
#pod Now you use the dispatcher:
#pod
#pod   package MyDOM;
#pod   use MRO::Classless;
#pod   use mro 'MRO::Classless';
#pod   1;
#pod
#pod ...and...
#pod
#pod   use MyDOM;
#pod
#pod   my $dom = MyDOM->new(type => 'root');
#pod
#pod The C call will actually result in a call to C in the form:
#pod
#pod   invoke_method('MyDOM', 'new', [ type => 'root' ]);
#pod
#pod Assuming it returns an object blessed into MyDOM, then:
#pod
#pod   $dom->children;
#pod
#pod ...will redispatch to:
#pod
#pod   invoke_method($dom, 'children', []);
#pod
#pod For examples of more practical use, look at the test suite.
#pod
#pod =cut

sub import {
  my $self = shift;
  my $arg;

  if (@_ == 1 and reftype $_[0] eq 'CODE') {
    $arg = { metamethod => $_[0] };
  } else {
    $arg = { @_ };
  }

  my $caller     = caller;
  my %to_install;

  my $code       = $arg->{metamethod};
  my $metamethod = $arg->{metamethod_name} || '__metamethod__';

  if (reftype $code eq 'SCALAR') {
    Carp::confess("can't find metamethod via name ${ $arg->{metamethod} }")
      unless $code = $caller->can($$code);
  }

  if (do { no strict 'refs'; defined *{"$caller\::$metamethod"}{CODE} }) {
    Carp::confess("can't install metamethod as $metamethod; already defined");
  }

  my $method_name;

  my $wiz = wizard
    copy_key => 1,
    data     => sub { \$method_name },
    fetch    => $self->_gen_fetch_magic({
      metamethod => $metamethod,
      passthru   => $arg->{passthru},
    });

  $to_install{ $metamethod } = sub {
    my $invocant = shift;
    $code->($invocant, $method_name, \@_);
  };

  no strict 'refs';
  for my $key (keys %to_install) {
    *{"$caller\::$key"} = $to_install{ $key };
  }

  if ($arg->{overload}) {
    my %copy = %{ $arg->{overload} };
    for my $ol (keys %copy) {
      next if $ol eq 'fallback';
      next if ref $copy{ $ol };

      my $name = $copy{ $ol };
      $copy{ $ol } = sub {
        $_[0]->$name(@_[ 1 .. $#_ ]);
      };
    }

    # We need string eval to set the caller to a variable. -- rjbs, 2009-03-26
    # We must do this before casting magic so that overload.pm can find the
    # right entries in the stash to muck with. -- rjbs, 2009-03-26
    die unless eval qq{
      package $caller;
      use overload %copy;
      1;
    };
  }

  MRO::Define::register_mro($caller, sub {
    return [ undef, $caller ];
  });

  cast %{"::$caller\::"}, $wiz;
}

sub _gen_fetch_magic {
  my ($self, $arg) = @_;

  my $metamethod = $arg->{metamethod};
  my $passthru   = $arg->{passthru};

  use Data::Dumper;
  return sub {
    return if $_[2] ~~ $passthru;

    return if substr($_[2], 0, 1) eq '(';

    ${ $_[1] } = $_[2];
    $_[2] = $metamethod;
    mro::method_changed_in('UNIVERSAL');

    return;
  };
}

1;

__END__