Commit | Line | Data |
ff402c4d |
1 | package Object::Builder; |
2 | |
3 | use Module::Runtime qw(use_module); |
322a6ab3 |
4 | use List::Util qw(reduce); |
5 | use Scalar::Util qw(weaken); |
ff402c4d |
6 | use Moo; |
7 | |
8 | our $VERSION = '0.000001'; # 0.0.1 |
9 | |
10 | $VERSION = eval $VERSION; |
11 | |
12 | has class => ( |
21dba240 |
13 | is => 'rw', lazy => 1, builder => 1, |
ff402c4d |
14 | trigger => sub { shift->_clear_final_class }, |
15 | ); |
16 | |
21dba240 |
17 | sub _build_class { die "No default class set" } |
18 | |
ff402c4d |
19 | has roles => ( |
322a6ab3 |
20 | is => 'rw', lazy => 1, builder => 1, clearer => 1, |
ff402c4d |
21 | trigger => sub { shift->_clear_final_class }, |
322a6ab3 |
22 | coerce => sub { ref($_[0]) eq 'ARRAY' ? { '' => $_[0] } : $_[0] }, |
ff402c4d |
23 | ); |
24 | |
322a6ab3 |
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 }; |
21dba240 |
32 | |
322a6ab3 |
33 | sub _build_roles { {} } |
34 | |
35 | sub _role_list { |
36 | my ($self) = @_; |
37 | my $roles = $self->roles; |
38 | map @{$roles->{$_}}, sort keys %$roles; |
39 | } |
ff402c4d |
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); |
322a6ab3 |
46 | if (my @roles = $self->_role_list) { |
ff402c4d |
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 => ( |
322a6ab3 |
59 | is => 'rw', builder => 1, clearer => 1, |
ff402c4d |
60 | trigger => sub { shift->_clear_final_arguments }, |
ff402c4d |
61 | ); |
62 | |
322a6ab3 |
63 | sub set_argument { |
64 | my ($self, $name, @arg) = @_; |
65 | $self->arguments({ %{$self->arguments}, $name => \@arg }); |
66 | } |
21dba240 |
67 | |
322a6ab3 |
68 | sub set_argument_weaken { |
69 | my ($self, $name, @arg) = @_; |
70 | weaken($arg[0]); |
71 | $self->arguments({ %{$self->arguments}, $name => \@arg }); |
72 | } |
ff402c4d |
73 | |
322a6ab3 |
74 | sub _build_arguments { {} } |
ff402c4d |
75 | |
322a6ab3 |
76 | after clear_arguments => sub { shift->_clear_final_arguments }; |
ff402c4d |
77 | |
78 | has _final_arguments => (is => 'lazy', clearer => 1); |
79 | |
322a6ab3 |
80 | after _clear_final_arguments => sub { shift->clear_object }; |
ff402c4d |
81 | |
82 | sub _build__final_arguments { |
83 | my ($self) = @_; |
322a6ab3 |
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; |
ff402c4d |
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 | |
322a6ab3 |
108 | sub fresh_object { |
109 | my ($self) = @_; |
110 | $self->_build_object; |
111 | } |
112 | |
21dba240 |
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 | |
ff402c4d |
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. |