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   my $class = use_module($self->class);
  46   if (my @roles = $self->_role_list) {
  47     require Moo::Role;
  48     return Moo::Role->create_class_with_roles($class, @roles);
  49   } else {
  50     return $class;
  51   }
  52 }
  53
  54 after _clear_final_class => sub { shift->clear_object };
  55
  56 has constructor => (is => 'ro', default => sub { 'new' });
  57
  58 has arguments => (
  59   is => 'rw', builder => 1, clearer => 1,
  60   trigger => sub { shift->_clear_final_arguments },
  61 );
  62
  63 sub set_argument {
  64   my ($self, $name, @arg) = @_;
  65   $self->arguments({ %{$self->arguments}, $name => \@arg });
  66 }
  67
  68 sub set_argument_weaken {
  69   my ($self, $name, @arg) = @_;
  70   weaken($arg[0]);
  71   $self->arguments({ %{$self->arguments}, $name => \@arg });
  72 }
  73
  74 sub _build_arguments { {} }
  75
  76 after clear_arguments => sub { shift->_clear_final_arguments };
  77
  78 has _final_arguments => (is => 'lazy', clearer => 1);
  79
  80 after _clear_final_arguments => sub { shift->clear_object };
  81
  82 sub _build__final_arguments {
  83   my ($self) = @_;
  84   my %arguments = %{$self->arguments};
  85   map +($_ => $self->_resolve($arguments{$_})), keys %arguments;
  86 }
  87
  88 sub _resolve {
  89   my ($self, $to_resolve) = @_;
  90
  91   # [ $x ] -> $x
  92   # [ $inv, 'x', 'y' ] -> $inv->x->y
  93   # [ $inv, [ 'x', 'y' ], 'z' ] -> $inv->x('y')->z
  94
  95   return reduce {
  96     my ($meth, @arg) = (ref($b) eq 'ARRAY' ? @$b : $b);
  97     $a->$meth(@arg);
  98   } @$to_resolve;
  99 }
 100
 101 has object => (is => 'lazy', clearer => 1);
 102
 103 sub _build_object {
 104   my ($self) = @_;
 105   $self->_final_class->${\$self->constructor}($self->_final_arguments);
 106 }
 107
 108 sub fresh_object {
 109   my ($self) = @_;
 110   $self->_build_object;
 111 }
 112
 113 sub BUILD {
 114   my ($self, $args) = @_;
 115   unless (
 116     $args->{object} or $args->{class}
 117     or ($self->can('_build_class') ne __PACKAGE__->can('_build_class')
 118   ) {
 119     die "No static object passed, and no class supplied or defaulted";
 120   }
 121 }
 122
 123 1;
 124
 125 =head1 NAME
 126
 127 Object::Builder - An object for building other objects.
 128
 129 =head1 SYNOPSIS
 130
 131 =head1 DESCRIPTION
 132
 133 =head1 AUTHOR
 134
 135  mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 136
 137 =head1 CONTRIBUTORS
 138
 139 None yet - maybe this software is perfect! (ahahahahahahahahaha)
 140
 141 =head1 COPYRIGHT
 142
 143 Copyright (c) 2012 the Object::Builder L</AUTHOR> and L</CONTRIBUTORS>
 144 as listed above.
 145
 146 =head1 LICENSE
 147
 148 This library is free software and may be distributed under the same terms
 149 as perl itself.