File Coverage

blib/lib/Alien/Build/Plugin.pm

Criterion	Covered	Total	%
statement	79	84	94.0
branch	16	18	88.8
condition	2	3	66.6
subroutine	20	21	95.2
pod	5	5	100.0
total	122	131	93.1

package Alien::Build::Plugin;

use strict;
use warnings;
use 5.008004;
use Data::Dumper ();
use Carp ();
use Digest::SHA ();

our @CARP_NOT = qw( alienfile Alien::Build Alien::Build::Meta );

# ABSTRACT: Plugin base class for Alien::Build
our $VERSION = '2.47'; # VERSION


sub new
{
  my $class = shift;
  my %args = @_ == 1 ? ($class->meta->default => $_[0]) : @_;

  my $instance_id = Digest::SHA::sha1_hex(Data::Dumper->new([$class, \%args])->Sortkeys(1)->Dump);
  my $self = bless { instance_id => $instance_id }, $class;

  my $prop = $self->meta->prop;
  foreach my $name (keys %$prop)
  {
    $self->{$name} = defined $args{$name}
      ? delete $args{$name}
      : ref($prop->{$name}) eq 'CODE'
        ? $prop->{$name}->()
        : $prop->{$name};
  }

  foreach my $name (keys %args)
  {
    Carp::carp "$class has no $name property";
  }

  $self;
}


sub instance_id { shift->{instance_id} }


sub init
{
  my($self) = @_;
  $self;
}

sub import
{
  my($class) = @_;

  return if $class ne __PACKAGE__;

  my $caller = caller;
  { no strict 'refs'; @{ "${caller}::ISA" } = __PACKAGE__ }

  my $meta = $caller->meta;
  my $has = sub {
    my($name, $default) = @_;
    $meta->add_property($name, $default);
  };

  { no strict 'refs'; *{ "${caller}::has" } = $has }
}


sub subplugin
{
  my(undef, $name, %args) = @_;
  Carp::carp("subplugin method is deprecated");
  my $class = "Alien::Build::Plugin::$name";
  my $pm = "$class.pm";
  $pm =~ s/::/\//g;
  require $pm unless eval { $class->can('new') };
  delete $args{$_} for grep { ! defined $args{$_} } keys %args;
  $class->new(%args);
}


my %meta;
sub meta
{
  my($class) = @_;
  $class = ref $class if ref $class;
  $meta{$class} ||= Alien::Build::PluginMeta->new( class => $class );
}

package Alien::Build::PluginMeta;

sub new
{
  my($class, %args) = @_;
  my $self = bless {
    prop => {},
    %args,
  }, $class;
}

sub default
{
  my($self) = @_;
  $self->{default} || do {
    Carp::croak "No default for @{[ $self->{class} ]}";
  };
}

sub add_property
{
  my($self, $name, $default) = @_;
  my $single = $name =~ s{^(\+)}{};
  $self->{default} = $name if $single;
  $self->{prop}->{$name} = $default;

  my $accessor = sub {
    my($self, $new) = @_;
    $self->{$name} = $new if defined $new;
    $self->{$name};
  };

  # add the accessor
  { no strict 'refs'; *{ $self->{class} . '::' . $name} = $accessor }

  $self;
}

sub prop
{
  shift->{prop};
}

1;

__END__