lib/Object/Builder.pm

   1 package Object::Builder;
   2
   3 use Module::Runtime qw(use_module);
   4 use List::Util qw(reduce);
   5 use Scalar::Util qw(weaken);
   6 use Moo;
   7
   8 our $VERSION = '0.000001'; # 0.0.1
   9
  10 $VERSION = eval $VERSION;
  11
  12 has class => (
  13   is => 'rw', lazy => 1, builder => 1,
  14   trigger => sub { shift->_clear_final_class },
  15 );
  16
  17 sub _build_class { die "No default class set" }
  18
  19 has roles => (
  20   is => 'rw', lazy => 1, builder => 1, clearer => 1,
  21   trigger => sub { shift->_clear_final_class },
  22   coerce => sub { ref($_[0]) eq 'ARRAY' ? { '' => $_[0] } : $_[0] },
  23 );
  24
  25 sub set_roles_for {
  26   my ($self, $for, @roles) = @_;
  27   $self->roles({ %{$self->roles}, $for => \@roles });
  28   return;
  29 }
  30
  31 after clear_roles => sub { shift->_clear_final_class };
  32
  33 sub _build_roles { {} }
  34
  35 sub _role_list {
  36   my ($self) = @_;
  37   my $roles = $self->roles;
  38   map @{$roles->{$_}}, sort keys %$roles;
  39 }
  40
  41 has _final_class => (is => 'lazy', clearer => 1);
  42
  43 sub _build__final_class {
  44   my ($self) = @_;
  45
  46   # This path will only be taken if class => undef was intentionally passed
  47   # to our constructor; this allows for a subref constructor which of course
  48   # doesn't necessarily need a class at all.
  49
  50   return unless defined($self->class);
  51
  52   my $class = use_module($self->class);
  53   if (my @roles = $self->_role_list) {
  54     require Moo::Role;
  55     return Moo::Role->create_class_with_roles($class, @roles);
  56   } else {
  57     return $class;
  58   }
  59 }
  60
  61 after _clear_final_class => sub { shift->clear_object };
  62
  63 has constructor => (is => 'ro', default => sub { 'new' });
  64
  65 has arguments => (
  66   is => 'rw', builder => 1, clearer => 1,
  67   trigger => sub { shift->_clear_final_arguments },
  68 );
  69
  70 sub set_argument {
  71   my ($self, $name, @arg) = @_;
  72   $self->arguments({ %{$self->arguments}, $name => \@arg });
  73 }
  74
  75 sub set_argument_weaken {
  76   my ($self, $name, @arg) = @_;
  77   weaken($arg[0]);
  78   $self->arguments({ %{$self->arguments}, $name => \@arg });
  79 }
  80
  81 sub _build_arguments { {} }
  82
  83 after clear_arguments => sub { shift->_clear_final_arguments };
  84
  85 has _final_arguments => (is => 'lazy', clearer => 1);
  86
  87 after _clear_final_arguments => sub { shift->clear_object };
  88
  89 sub _build__final_arguments {
  90   my ($self) = @_;
  91   my %arguments = %{$self->arguments};
  92   map +($_ => $self->_resolve($arguments{$_})), keys %arguments;
  93 }
  94
  95 sub _resolve {
  96   my ($self, $to_resolve) = @_;
  97
  98   # [ $x ] -> $x
  99   # [ $inv, 'x', 'y' ] -> $inv->x->y
 100   # [ $inv, [ 'x', [ 'y' ] ], 'z' ] -> $inv->x('y')->z
 101   # [ $inv, [ 'x', [ $other, 'y' ] ], 'z' ] -> $inv->x($other->y)->z
 102
 103   no warnings 'once'; # $a
 104
 105   return reduce {
 106     my ($meth, @arg) = (ref($b) eq 'ARRAY' ? @$b : $b);
 107     $a->$meth(map $self->_resolve($_), @arg);
 108   } @$to_resolve;
 109 }
 110
 111 has object => (is => 'lazy', clearer => 1);
 112
 113 sub _build_object {
 114   my ($self) = @_;
 115   $self->_final_class->${\$self->constructor}($self->_final_arguments);
 116 }
 117
 118 sub fresh_object {
 119   my ($self) = @_;
 120   $self->_build_object;
 121 }
 122
 123 sub BUILD {
 124   my ($self, $args) = @_;
 125   unless (
 126     $args->{object} or exists $args->{class}
 127     or ($self->can('_build_class') ne __PACKAGE__->can('_build_class'))
 128   ) {
 129     die "No static object passed, and no class supplied or defaulted";
 130   }
 131 }
 132
 133 1;
 134
 135 =head1 NAME
 136
 137 Object::Builder - An object for building other objects.
 138
 139 =head1 SYNOPSIS
 140
 141 =head1 DESCRIPTION
 142
 143 =head1 AUTHOR
 144
 145  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 146
 147 =head1 CONTRIBUTORS
 148
 149 None yet - maybe this software is perfect! (ahahahahahahahahaha)
 150
 151 =head1 COPYRIGHT
 152
 153 Copyright (c) 2012 the Object::Builder L</AUTHOR> and L</CONTRIBUTORS>
 154 as listed above.
 155
 156 =head1 LICENSE
 157
 158 This library is free software and may be distributed under the same terms
 159 as perl itself.