File Coverage

blib/lib/Rose/Object/MakeMethods.pm

Criterion	Covered	Total	%
statement	107	112	95.5
branch	33	48	68.7
condition	15	33	45.4
subroutine	12	12	100.0
pod	2	4	50.0
total	169	209	80.8

package Rose::Object::MakeMethods;

use strict;

use Carp();

our $VERSION = '0.856';

__PACKAGE__->allow_apparent_reload(1);

our %Made_Method_Custom;

sub import
{
  my($class) = shift;

  return 1  unless(@_);

  my($options, $args) = $class->_normalize_args(@_);

  $options->{'target_class'} ||= (caller)[0];

  $class->make_methods($options, $args);

  return 1;
}

sub make_methods
{
  my($class) = shift;

  my($options, $args) = $class->_normalize_args(@_);

  $options->{'target_class'} ||= (caller)[0];

  #use Data::Dumper;
  #print STDERR Dumper($options);
  #print STDERR Dumper($args);

  while(@$args)
  {
    $class->__make_methods($options, shift(@$args), shift(@$args));
  }

  return 1;
}

# Can't use the class method maker easily here due to a chicken/egg
# situation, so this code is manually inlined.
my %Inheritable_Scalar;

sub allow_apparent_reload
{
  my($class) = ref($_[0]) ? ref(shift) : shift;

  if(@_)
  {
    return $Inheritable_Scalar{$class}{'allow_apparent_reload'} = shift;
  }

  return $Inheritable_Scalar{$class}{'allow_apparent_reload'}
    if(exists $Inheritable_Scalar{$class}{'allow_apparent_reload'});

  my @parents = ($class);

  while(my $parent = shift(@parents))
  {
    no strict 'refs';
    foreach my $subclass (@{$parent . '::ISA'})
    {
      push(@parents, $subclass);

      if(exists $Inheritable_Scalar{$subclass}{'allow_apparent_reload'})
      {
        return $Inheritable_Scalar{$subclass}{'allow_apparent_reload'}
      }
    }
  }

  return undef;
}

# XXX: This nasty hack should be unneeded now and will probably
# XXX: be removed some time in the future.
our $Preserve_Existing = 0;

sub __make_methods
{
  my($class) = shift;

  #my $options;

  #if(ref $_[0] eq 'HASH')
  #{
  #  $options = shift;
  #}
  #else { $options = {} }

  #$options->{'target_class'} ||= (caller)[0];

  my $options     = shift;
  my $method_type = shift;
  my $methods     = shift;

  my $target_class = $options->{'target_class'};

  while(@$methods)
  {
    my $method_name = shift(@$methods);
    my $method_args = shift(@$methods);

    my $make = $class->$method_type($method_name => $method_args, $options ||= {});

    Carp::croak "${class}::method_type(...) didn't return a hash ref!"
      unless(ref $make eq 'HASH');

    no strict 'refs';

    METHOD: while(my($name, $code) = each(%$make))
    {
      Carp::croak "${class}::method_type(...) - key for $name is not a code ref!"
        unless(ref $code eq 'CODE' || (ref $code eq 'HASH' && $code->{'make_method'}));

      if(my $code = $target_class->can($name))
      {
        if($options->{'preserve_existing'} || $Preserve_Existing)
        {
          next METHOD;
        }

        unless($options->{'override_existing'})
        {
          if($class->allow_apparent_reload && $class->apparently_made_method($code))
          {
            next METHOD;
          }

          Carp::croak "Cannot create method ${target_class}::$name - method already exists";
        }
      }

      no warnings;

      if(ref $code eq 'CODE')
      {
        *{"${target_class}::$name"} = $code;
      }
      else
      {
        # XXX: Must track these separately because they do not show up as
        # XXX: being named __ANON__ when fetching the sub_identity()
        $Made_Method_Custom{$target_class}{$name}++;
        $code->{'make_method'}($name, $target_class, $options);
      }
    }
  }

  return 1;
}

sub apparently_made_method
{
  my($class, $code) = @_;

  my($mm_class, $name) = $class->sub_identity($code);
  return 0  unless($class && $name);
  # XXX: RT 54444 - The formerly constant "__ANON__" sub name looks
  # XXX: like this in newer versions of perl when running under the
  # XXX: debugger: "__ANON__[/usr/lib/perl5/.../Some/Module.pm:123]"
  return (($mm_class eq $class && $name =~ /^__ANON__/) ||
          $Made_Method_Custom{$mm_class}{$name}) ? 1 : 0;
}

# Code from Sub::Identify
sub sub_identity
{
  my($class, $code) = @_;

  my @id;

  TRY:
  {
    local $@;

    eval # if this fails, the identity is undefined
    {
      require B;
      my $cv = B::svref_2object($code);
      return  unless($cv->isa('B::CV'));
      @id = ($cv->GV->STASH->NAME, $cv->GV->NAME);
    };

    # Ignore errors
  }

  return @id;
}

# Given the example method types "bitfield" and "scalar", _normalize_args()
# takes args in any of these forms:
#
#     { ... }, # Class options (optionally) go here
#
#     scalar => 'foo',
#
#     'bitfield --opt' => [ 'a', 'b' ],
#
#     'scalar --opt2=blah' => [ 'foo' => { opt => 4, opt2 => 'blee' } ],
#
#     scalar => [ 'a' => { default => 5 }, 'b' ],
#
#     bitfield =>
#     [
#       bar => { size => 8 },
#       baz => { size => 5, default => '00011' },
#     ],
#
# and returns an options hashref (possibly empty) and a reference
# to an array that is normalized to look like this:
#
# [
#   [
#     'scalar'   => [ 'foo' =>  {} ],
#
#     'bitfield' =>
#     [
#       'a' => { opt => 1 },
#       'b' => { opt => 1 }
#     ],
#
#     'scalar' => [ 'foo' => { 'opt' => 4, 'opt2' => 'blee' } ],
#
#     'scalar'=>
#     [
#       'a' => { 'default' => 5 },
#       'b' => {}
#     ],
#
#     'bitfield' =>
#     [
#       'bar' => { 'size' => 8 },
#       'baz' => { 'default' => '00011', 'size' => 5 }
#     ]
#   ]
# ]

sub _normalize_args
{
  my($class) = shift;

  my $i = 0;

  my(@normalized_args, $options);

  while(@_)
  {
    my $method_type = shift || last;

    if(ref $method_type)
    {
      if(ref $method_type eq 'HASH')
      {
        Carp::croak "Options hash ref provided more than once"
          if($options);

        $options = $method_type;
        next;
      }
      elsif(ref $method_type eq 'ARRAY')
      {
        unshift(@_, @$method_type);
        next;
      }
    }

    my %method_options;

    my $i = 0;

    while($method_type =~ s/\s+--(\w+)(?:=(\w+))?//)
    {
      if($i++ || defined $2)
      {
        $method_options{$1} = $2;
      }
      else
      {
        $method_options{'interface'} = $1;
      }
    }

    push(@normalized_args, $method_type);

    my $args = shift;

    if(!ref $args)
    {
      $args = [ $args ];
    }
    elsif(ref $args ne 'ARRAY')
    {
      Carp::croak "Bad invocation of Rose::Object::MakeMethods";
    }

    my @method_args;

    while(@$args)
    {
      my $method_name = shift(@$args);

      if(ref $args->[0])
      {
        unless(ref $args->[0] eq 'HASH')
        {
          Carp::croak "Expected hash ref or scalar after method name, but found $args->[0]";
        }

        push(@method_args, $method_name => { %method_options, %{shift(@$args)} });
      }
      else
      {
        push(@method_args, $method_name => { %method_options });
      }
    }

    push(@normalized_args, \@method_args);
  }

  return($options || {}, \@normalized_args);
}

1;

__END__