File Coverage

blib/lib/Rose/Object/MixIn.pm

Criterion	Covered	Total	%
statement	60	76	78.9
branch	23	44	52.2
condition	13	29	44.8
subroutine	10	10	100.0
pod	2	5	40.0
total	108	164	65.8

package Rose::Object::MixIn;

use strict;

use Carp;

our $Debug = 0;

our $VERSION = '0.856';

use Rose::Class::MakeMethods::Set
(
  inheritable_set =>
  [
    '_export_tag' =>
    {
      list_method    => '_export_tags',
      clear_method   => 'clear_export_tags',
      add_method     => '_add_export_tag',
      delete_method  => 'delete_export_tag',
      deletes_method => 'delete_export_tags',
    },

    '_pre_import_hook',
    {
      clear_method   => 'clear_pre_import_hooks',
      add_method     => 'add_pre_import_hook',
      adds_method    => 'add_pre_import_hooks',
      delete_method  => 'delete_pre_import_hook',
      deletes_method => 'delete_pre_import_hooks',
    },
  ],
);

sub import
{
  my($class) = shift;

  my $target_class = (caller)[0];

  my($force, @methods, %import_as);

  foreach my $arg (@_)
  {
    if(!defined $target_class && $arg !~ /^-/)
    {
      $target_class = $arg;
      next;
    }

    if($arg =~ /^-?-force$/)
    {
      $force = 1;
    }
    elsif($arg =~ /^-?-target[-_]class$/)
    {
      $target_class = undef; # set on next iteration...lame
      next;
    }
    elsif($arg =~ /^:(.+)/)
    {
      my $methods = $class->export_tag($1) or
        croak "Unknown export tag - '$arg'";

      push(@methods, @$methods);
    }
    elsif(ref $arg eq 'HASH')
    {
      while(my($method, $name) = each(%$arg))
      {
        push(@methods, $method);
        $import_as{$method} = $name;
      }
    }
    else
    {
      push(@methods, $arg);
    }
  }

  foreach my $method (@methods)
  {
    my $code = $class->can($method) or
      croak "Could not import method '$method' from $class - no such method";

    my $import_as = $import_as{$method} || $method;

    if($target_class->can($import_as) && !$force)
    {
      croak "Could not import method '$import_as' from $class into ",
            "$target_class - a method by that name already exists. ",
            "Pass a '-force' argument to import() to override ",
            "existing methods."
    }

    if(my $hooks = $class->pre_import_hooks($method))
    {
      foreach my $code (@$hooks)
      {
        my $error;

        TRY:
        {
          local $@;
          eval { $code->($class, $method, $target_class, $import_as) };
          $error = $@;
        }

        if($error)
        {
          croak "Could not import method '$import_as' from $class into ",
                "$target_class - $error";
        }
      }
    }

    no strict 'refs';
    $Debug && warn "${target_class}::$import_as = ${class}->$method\n";
    *{$target_class . '::' . $import_as} = $code;
  }
}

sub export_tag
{
  my($class, $tag) = (shift, shift);

  if(index($tag, ':') == 0)
  {
    croak 'Tag name arguments to export_tag() should not begin with ":"';
  }

  if(@_ && !$class->_export_tag_value($tag))
  {
    $class->_add_export_tag($tag);
  }

  if(@_ && (@_ > 1 || (ref $_[0] || '') ne 'ARRAY'))
  {
    croak 'export_tag() expects either a single tag name argument, ',
          'or a tag name and a reference to an array of method names';
  }

  my $ret = $class->_export_tag_value($tag, @_);

  croak "No such tag: $tag"  unless($ret);

  return wantarray ? @$ret : $ret;
}

sub export_tags
{
  my($class) = shift;
  return $class->_export_tags  unless(@_);
  $class->clear_export_tags;
  $class->add_export_tags(@_);
}

sub add_export_tags
{
  my($class) = shift;

  while(@_)
  {
    my($tag, $arg) = (shift, shift);
    $class->export_tag($tag, $arg);
  }
}

sub pre_import_hook
{
  my($class, $method) = (shift, shift);

  if(@_ && !$class->_pre_import_hook_value($method))
  {
    $class->add_pre_import_hook($method);
  }

  if(@_ && (@_ > 1 || (ref $_[0] && (ref $_[0] || '') !~ /\A(?:ARRAY|CODE)\z/)))
  {
    croak 'pre_import_hook() expects either a single method name argument, ',
          'or a method name and a code reference or a reference to an array ',
          'of code references';
  }

  if(@_)
  {
    unless(ref $_[0] eq 'ARRAY')
    {
      $_[0] = [ $_[0] ];
    }
  }

  my $ret = $class->_pre_import_hook_value($method, @_) || [];

  return wantarray ? @$ret : $ret;
}

sub pre_import_hooks { shift->pre_import_hook(shift) }

1;

__END__