slightly more complicated resolver

[scpubgit/Object-Builder.git] / lib / Object / Builder.pm

package Object::Builder;

use Module::Runtime qw(use_module);
use List::Util qw(reduce);
use Scalar::Util qw(weaken);
use Moo;

our $VERSION = '0.000001'; # 0.0.1

$VERSION = eval $VERSION;

has class => (
  is => 'rw', lazy => 1, builder => 1,
  trigger => sub { shift->_clear_final_class },
);

sub _build_class { die "No default class set" }

has roles => (
  is => 'rw', lazy => 1, builder => 1, clearer => 1,
  trigger => sub { shift->_clear_final_class },
  coerce => sub { ref($_[0]) eq 'ARRAY' ? { '' => $_[0] } : $_[0] },
);

sub set_roles_for {
  my ($self, $for, @roles) = @_;
  $self->roles({ %{$self->roles}, $for => \@roles });
  return;
}

after clear_roles => sub { shift->_clear_final_class };

sub _build_roles { {} }

sub _role_list {
  my ($self) = @_;
  my $roles = $self->roles;
  map @{$roles->{$_}}, sort keys %$roles;
}

has _final_class => (is => 'lazy', clearer => 1);

sub _build__final_class {
  my ($self) = @_;

  # This path will only be taken if class => undef was intentionally passed
  # to our constructor; this allows for a subref constructor which of course
  # doesn't necessarily need a class at all.

  return unless defined($self->class);

  my $class = use_module($self->class);
  if (my @roles = $self->_role_list) {
    require Moo::Role;
    return Moo::Role->create_class_with_roles($class, @roles);
  } else {
    return $class;
  }
}

after _clear_final_class => sub { shift->clear_object };

has constructor => (is => 'ro', default => sub { 'new' });

has arguments => (
  is => 'rw', builder => 1, clearer => 1,
  trigger => sub { shift->_clear_final_arguments },
);

sub set_argument {
  my ($self, $name, @arg) = @_;
  $self->arguments({ %{$self->arguments}, $name => \@arg });
}

sub set_argument_weaken {
  my ($self, $name, @arg) = @_;
  weaken($arg[0]);
  $self->arguments({ %{$self->arguments}, $name => \@arg });
}

sub _build_arguments { {} }

after clear_arguments => sub { shift->_clear_final_arguments };

has _final_arguments => (is => 'lazy', clearer => 1);

after _clear_final_arguments => sub { shift->clear_object };

sub _build__final_arguments {
  my ($self) = @_;
  my %arguments = %{$self->arguments};
  map +($_ => $self->_resolve($arguments{$_})), keys %arguments;
}

sub _resolve {
  my ($self, $to_resolve) = @_;

  # [ $x ] -> $x
  # [ $inv, 'x', 'y' ] -> $inv->x->y
  # [ $inv, [ 'x', [ 'y' ] ], 'z' ] -> $inv->x('y')->z
  # [ $inv, [ 'x', [ $other, 'y' ] ], 'z' ] -> $inv->x($other->y)->z

  no warnings 'once'; # $a

  return reduce {
    my ($meth, @arg) = (ref($b) eq 'ARRAY' ? @$b : $b);
    $a->$meth(map $self->_resolve($_), @arg);
  } @$to_resolve;
}

has object => (is => 'lazy', clearer => 1);

sub _build_object {
  my ($self) = @_;
  $self->_final_class->${\$self->constructor}($self->_final_arguments);
}

sub fresh_object {
  my ($self) = @_;
  $self->_build_object;
}

sub BUILD {
  my ($self, $args) = @_;
  unless (
    $args->{object} or exists $args->{class}
    or ($self->can('_build_class') ne __PACKAGE__->can('_build_class'))
  ) {
    die "No static object passed, and no class supplied or defaulted";
  }
}

1;

=head1 NAME

Object::Builder - An object for building other objects.

=head1 SYNOPSIS

=head1 DESCRIPTION

=head1 AUTHOR

 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>

=head1 CONTRIBUTORS

None yet - maybe this software is perfect! (ahahahahahahahahaha)

=head1 COPYRIGHT

Copyright (c) 2012 the Object::Builder L</AUTHOR> and L</CONTRIBUTORS>
as listed above.

=head1 LICENSE

This library is free software and may be distributed under the same terms
as perl itself.