view release on metacpan or  search on metacpan

lib/Rose/Object/MakeMethods.pm  view on Meta::CPAN

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;
}