Commit | Line | Data |
7adfd53f |
1 | package Reaction::InterfaceModel::Reflector::DBIC; |
2 | |
3 | use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create'; |
b8faba69 |
4 | use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::DeleteAll'; |
7adfd53f |
5 | use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update'; |
6 | use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete'; |
7 | |
8 | use aliased 'Reaction::InterfaceModel::Collection::Virtual::ResultSet'; |
9 | use aliased 'Reaction::InterfaceModel::Object'; |
10 | use aliased 'Reaction::InterfaceModel::Action'; |
11 | use Reaction::Class; |
12 | use Class::MOP; |
13 | |
f670cfd0 |
14 | use Catalyst::Utils; |
15 | |
7adfd53f |
16 | class DBIC, which { |
17 | |
de48f4e6 |
18 | has make_classes_immutable => (isa => "Bool", is => "rw", required => 1, default => sub{ 1 }); |
19 | |
f670cfd0 |
20 | #user defined actions and prototypes |
21 | has object_actions => (isa => "HashRef", is => "rw", lazy_build => 1); |
22 | has collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1); |
23 | |
24 | #which actions to create by default |
25 | has default_object_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1); |
26 | has default_collection_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1); |
27 | |
28 | #builtin actions and prototypes |
29 | has builtin_object_actions => (isa => "HashRef", is => "rw", lazy_build => 1); |
30 | has builtin_collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1); |
31 | |
89939ff9 |
32 | implements _build_object_actions => as { {} }; |
33 | implements _build_collection_actions => as { {} }; |
f670cfd0 |
34 | |
89939ff9 |
35 | implements _build_default_object_actions => as { [ qw/Update Delete/ ] }; |
36 | implements _build_default_collection_actions => as { [ qw/Create DeleteAll/ ] }; |
f670cfd0 |
37 | |
89939ff9 |
38 | implements _build_builtin_object_actions => as { |
f670cfd0 |
39 | { |
7b78a39d |
40 | Update => { name => 'Update', base => Update }, |
41 | Delete => { name => 'Delete', base => Delete, attributes => [] }, |
f670cfd0 |
42 | }; |
43 | }; |
44 | |
89939ff9 |
45 | implements _build_builtin_collection_actions => as { |
a4f82080 |
46 | { |
47 | Create => {name => 'Create', base => Create }, |
c689b58e |
48 | DeleteAll => {name => 'DeleteAll', base => DeleteAll, attributes => [] } |
a4f82080 |
49 | }; |
f670cfd0 |
50 | }; |
51 | |
52 | implements _all_object_actions => as { |
89939ff9 |
53 | my $self = shift; |
f670cfd0 |
54 | return $self->merge_hashes |
55 | ($self->builtin_object_actions, $self->object_actions); |
56 | }; |
7adfd53f |
57 | |
f670cfd0 |
58 | implements _all_collection_actions => as { |
59 | my $self = shift; |
60 | return $self->merge_hashes |
61 | ($self->builtin_collection_actions, $self->collection_actions); |
62 | }; |
63 | |
64 | implements dm_name_from_class_name => as { |
65 | my($self, $class) = @_; |
66 | confess("wrong arguments") unless $class; |
67 | $class =~ s/::/_/g; |
68 | $class = "_" . lc($class) . "_store"; |
69 | return $class; |
7adfd53f |
70 | }; |
71 | |
f670cfd0 |
72 | implements dm_name_from_source_name => as { |
73 | my($self, $source) = @_; |
74 | confess("wrong arguments") unless $source; |
75 | $source =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; |
76 | $source = "_" . lc($source) . "_store"; |
77 | return $source; |
7adfd53f |
78 | }; |
79 | |
f670cfd0 |
80 | implements class_name_from_source_name => as { |
81 | my ($self, $model_class, $source_name) = @_; |
82 | confess("wrong arguments") unless $model_class && $source_name; |
83 | return join "::", $model_class, $source_name; |
84 | }; |
85 | |
86 | implements class_name_for_collection_of => as { |
7adfd53f |
87 | my ($self, $object_class) = @_; |
f670cfd0 |
88 | confess("wrong arguments") unless $object_class; |
7adfd53f |
89 | return "${object_class}::Collection"; |
90 | }; |
91 | |
f670cfd0 |
92 | implements merge_hashes => as { |
93 | my($self, $left, $right) = @_; |
94 | return Catalyst::Utils::merge_hashes($left, $right); |
95 | }; |
96 | |
97 | implements parse_reflect_rules => as { |
98 | my ($self, $rules, $haystack) = @_; |
99 | confess('$rules must be an array reference') unless ref $rules eq 'ARRAY'; |
100 | confess('$haystack must be an array reference') unless ref $haystack eq 'ARRAY'; |
101 | |
102 | my $needles = {}; |
103 | my (@exclude, @include, $global_opts); |
104 | if(@$rules == 2 && $rules->[0] eq '-exclude'){ |
105 | push(@exclude, (ref $rules->[1] eq 'ARRAY' ? @{$rules->[1]} : $rules->[1])); |
106 | } else { |
107 | for my $rule ( @$rules ){ |
108 | if (ref $rule eq 'ARRAY' && $rule->[0] eq '-exclude'){ |
109 | push(@exclude, (ref $rule->[1] eq 'ARRAY' ? @{$rule->[1]} : $rule->[1])); |
110 | } elsif( ref $rule eq 'HASH' ){ |
111 | $global_opts = ref $global_opts eq 'HASH' ? |
112 | $self->merge_hashes($global_opts, $rule) : $rule; |
113 | } else { |
114 | push(@include, $rule); |
115 | } |
116 | } |
117 | } |
118 | my $check_exclude = sub{ |
119 | for my $rule (@exclude){ |
120 | return 1 if(ref $rule eq 'Regexp' ? $_[0] =~ /$rule/ : $_[0] eq $rule); |
121 | } |
122 | return; |
123 | }; |
124 | |
125 | @$haystack = grep { !$check_exclude->($_) } @$haystack; |
126 | $self->merge_reflect_rules(\@include, $needles, $haystack, $global_opts); |
127 | return $needles; |
128 | }; |
129 | |
130 | implements merge_reflect_rules => as { |
131 | my ($self, $rules, $needles, $haystack, $local_opts) = @_; |
132 | for my $rule ( @$rules ){ |
133 | if(!ref $rule && ( grep {$rule eq $_} @$haystack ) ){ |
134 | $needles->{$rule} = defined $needles->{$rule} ? |
135 | $self->merge_hashes($needles->{$rule}, $local_opts) : $local_opts; |
136 | } elsif( ref $rule eq 'Regexp' ){ |
137 | for my $match ( grep { /$rule/ } @$haystack ){ |
138 | $needles->{$match} = defined $needles->{$match} ? |
139 | $self->merge_hashes($needles->{$match}, $local_opts) : $local_opts; |
140 | } |
141 | } elsif( ref $rule eq 'ARRAY' ){ |
142 | my $opts; |
143 | $opts = pop(@$rule) if @$rule > 1 and ref $rule->[$#$rule] eq 'HASH'; |
144 | $opts = $self->merge_hashes($local_opts, $opts) if defined $local_opts; |
145 | $self->merge_reflect_rules($rule, $needles, $haystack, $opts); |
146 | } |
147 | } |
148 | }; |
149 | |
150 | implements reflect_schema => as { |
7adfd53f |
151 | my ($self, %opts) = @_; |
f670cfd0 |
152 | my $base = delete $opts{base} || Object; |
153 | my $model = delete $opts{model_class}; |
154 | my $schema = delete $opts{schema_class}; |
7adfd53f |
155 | my $dm_name = delete $opts{domain_model_name}; |
156 | my $dm_args = delete $opts{domain_model_args} || {}; |
f670cfd0 |
157 | $dm_name ||= $self->dm_name_from_class_name($schema); |
158 | |
159 | #load all necessary classes |
160 | confess("model_class and schema_class are required parameters") |
161 | unless($model && $schema); |
162 | Class::MOP::load_class( $base ); |
163 | Class::MOP::load_class( $schema ); |
89939ff9 |
164 | my $meta = eval { Class::MOP::load_class($model); } ? |
f670cfd0 |
165 | $model->meta : $base->meta->create($model, superclasses => [ $base ]); |
166 | |
167 | # sources => undef, #default to qr/./ |
168 | # sources => [], #default to nothing |
169 | # sources => qr//, #DWIM, treated as [qr//] |
170 | # sources => [{...}] #DWIM, treat as [qr/./, {...} ] |
171 | # sources => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]] |
172 | my $haystack = [ $schema->sources ]; |
173 | |
174 | my $rules = delete $opts{sources}; |
175 | if(!defined $rules){ |
176 | $rules = [qr/./]; |
177 | } elsif( ref $rules eq 'Regexp'){ |
178 | $rules = [ $rules ]; |
179 | } elsif( ref $rules eq 'ARRAY' && @$rules){ |
180 | #don't add a qr/./ rule if we have at least one match rule |
181 | push(@$rules, qr/./) unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') |
182 | || !ref $_ || ref $_ eq 'Regexp'} @$rules; |
183 | } |
7adfd53f |
184 | |
f670cfd0 |
185 | my $sources = $self->parse_reflect_rules($rules, $haystack); |
7adfd53f |
186 | |
de48f4e6 |
187 | my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; |
7adfd53f |
188 | $meta->make_mutable if $meta->is_immutable; |
189 | |
f670cfd0 |
190 | $meta->add_domain_model |
191 | ($dm_name, is => 'rw', isa => $schema, required => 1, %$dm_args); |
192 | |
193 | for my $source_name (keys %$sources){ |
194 | my $source_opts = $sources->{$source_name} || {}; |
195 | $self->reflect_source( |
196 | source_name => $source_name, |
197 | parent_class => $model, |
198 | schema_class => $schema, |
199 | source_class => $schema->class($source_name), |
200 | parent_domain_model_name => $dm_name, |
201 | %$source_opts |
202 | ); |
7adfd53f |
203 | } |
204 | |
205 | $meta->make_immutable if $make_immutable; |
206 | return $meta; |
207 | }; |
208 | |
f670cfd0 |
209 | implements _compute_source_options => as { |
210 | my ($self, %opts) = @_; |
211 | my $schema = delete $opts{schema_class}; |
212 | my $source_name = delete $opts{source_name}; |
213 | my $source_class = delete $opts{source_class}; |
214 | my $parent = delete $opts{parent_class}; |
215 | my $parent_dm = delete $opts{parent_domain_model_name}; |
216 | |
217 | #this is the part where I hate my life for promissing all sorts of DWIMery |
218 | confess("parent_class and source_name or source_class are required parameters") |
219 | unless($parent && ($source_name || $source_class)); |
220 | |
221 | OUTER: until( $schema && $source_name && $source_class && $parent_dm ){ |
222 | if( $schema && !$source_name){ |
223 | next OUTER if $source_name = $source_class->result_source_instance->source_name; |
224 | } elsif( $schema && !$source_class){ |
225 | next OUTER if $source_class = eval { $schema->class($source_name) }; |
226 | } |
7adfd53f |
227 | |
f670cfd0 |
228 | if($source_class && (!$schema || !$source_name)){ |
229 | if(!$schema){ |
230 | $schema = $source_class->result_source_instance->schema; |
231 | next OUTER if $schema && Class::MOP::load_class($schema); |
232 | } |
233 | if(!$source_name){ |
234 | $source_name = $source_class->result_source_instance->source_name; |
235 | next OUTER if $source_name; |
236 | } |
237 | } |
238 | my @haystack = $parent_dm ? |
239 | $parent->meta->find_attribute_by_name($parent_dm) : $parent->domain_models; |
240 | |
241 | #there's a lot of guessing going on, but it should work fine on most cases |
242 | INNER: for my $needle (@haystack){ |
243 | my $isa = $needle->_isa_metadata; |
244 | next INNER unless Class::MOP::load_class( $isa->_isa_metadata ); |
245 | next INNER unless $isa->isa('DBIx::Class::Schema'); |
246 | if(!$parent_dm && $schema && $isa eq $schema){ |
247 | $parent_dm = $needle->name; |
248 | next OUTER; |
249 | } |
250 | |
251 | if( $source_name ){ |
252 | my $src_class = eval{ $isa->class($source_name) }; |
253 | next INNER unless $src_class; |
254 | next INNER if($source_class && $source_class ne $src_class); |
255 | $schema = $isa; |
256 | $parent_dm = $needle->name; |
257 | $source_class = $src_class; |
258 | next OUTER; |
259 | } |
260 | } |
261 | |
262 | #do we even need to go this far? |
263 | if( !$parent_dm && $schema ){ |
264 | my $tentative = $self->dm_name_from_class_name($schema); |
265 | $parent_dm = $tentative if grep{$_->name eq $tentative} @haystack; |
266 | } |
267 | |
268 | confess("Could not determine options automatically from: schema " . |
269 | "'${schema}', source_name '${source_name}', source_class " . |
270 | "'${source_class}', parent_domain_model_name '${parent_dm}'"); |
271 | } |
272 | |
273 | return { |
274 | source_name => $source_name, |
275 | schema_class => $schema, |
276 | source_class => $source_class, |
277 | parent_class => $parent, |
278 | parent_domain_model_name => $parent_dm, |
279 | }; |
280 | }; |
7adfd53f |
281 | |
7adfd53f |
282 | |
f670cfd0 |
283 | implements add_source => as { |
284 | my ($self, %opts) = @_; |
285 | |
286 | my $model = delete $opts{model_class}; |
287 | my $reader = delete $opts{reader}; |
288 | my $source = delete $opts{source_name}; |
289 | my $dm_name = delete $opts{domain_model_name}; |
290 | my $collection = delete $opts{collection_class}; |
291 | my $name = delete $opts{attribute_name} || $source; |
292 | |
293 | confess("model_class and source_name are required parameters") |
294 | unless $model && $source; |
295 | my $meta = $model->meta; |
296 | |
297 | unless( $collection ){ |
298 | my $object = $self->class_name_from_source_name($model, $source); |
299 | $collection = $self->class_name_for_collection_of($object); |
300 | } |
301 | unless( $reader ){ |
302 | $reader = $source; |
7adfd53f |
303 | $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; |
a4f82080 |
304 | $reader = lc($reader) . "_collection"; #XXX change to not use _collection ? |
7adfd53f |
305 | } |
f670cfd0 |
306 | unless( $dm_name ){ |
307 | my @haystack = $meta->domain_models; |
308 | if( @haystack > 1 ){ |
309 | @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack; |
310 | } |
311 | if(@haystack == 1){ |
312 | $dm_name = $haystack[0]->name; |
313 | } elsif(@haystack > 1){ |
314 | confess("Failed to automatically determine domain_model_name. More than one " . |
315 | "possible match (".(join ", ", map{"'".$_->name."'"} @haystack).")"); |
316 | } else { |
317 | confess("Failed to automatically determine domain_model_name. No matches."); |
318 | } |
319 | } |
7adfd53f |
320 | |
321 | my %attr_opts = |
322 | ( |
323 | lazy => 1, |
7adfd53f |
324 | required => 1, |
f670cfd0 |
325 | isa => $collection, |
7adfd53f |
326 | reader => $reader, |
f670cfd0 |
327 | predicate => "has_${name}", |
7adfd53f |
328 | domain_model => $dm_name, |
f670cfd0 |
329 | orig_attr_name => $source, |
7adfd53f |
330 | default => sub { |
f670cfd0 |
331 | $collection->new(_source_resultset => shift->$dm_name->resultset($source)); |
7adfd53f |
332 | }, |
333 | ); |
7adfd53f |
334 | |
f670cfd0 |
335 | my $make_immutable = $meta->is_immutable; |
336 | $meta->make_mutable if $make_immutable; |
337 | my $attr = $meta->add_attribute($name, %attr_opts); |
7adfd53f |
338 | $meta->make_immutable if $make_immutable; |
f670cfd0 |
339 | |
7adfd53f |
340 | return $attr; |
341 | }; |
342 | |
f670cfd0 |
343 | implements reflect_source => as { |
344 | my ($self, %opts) = @_; |
345 | my $collection = delete $opts{collection} || {}; |
346 | %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) }; |
347 | |
348 | my $obj_meta = $self->reflect_source_object(%opts); |
349 | my $col_meta = $self->reflect_source_collection |
350 | ( |
351 | object_class => $obj_meta->name, |
352 | source_class => $opts{source_class}, |
353 | %$collection |
354 | ); |
355 | |
356 | $self->add_source( |
357 | model_class => $opts{parent_class}, |
358 | source_name => $opts{source_name}, |
359 | domain_model_name => $opts{parent_domain_model_name}, |
360 | collection_class => $col_meta->name, |
361 | ); |
362 | }; |
363 | |
364 | implements reflect_source_collection => as { |
7adfd53f |
365 | my ($self, %opts) = @_; |
7adfd53f |
366 | my $base = delete $opts{base} || ResultSet; |
f670cfd0 |
367 | my $class = delete $opts{class}; |
368 | my $object = delete $opts{object_class}; |
369 | my $source = delete $opts{source_class}; |
370 | my $action_rules = delete $opts{actions}; |
371 | |
372 | confess('object_class and source_class are required parameters') |
373 | unless $object && $source; |
374 | $class ||= $self->class_name_for_collection_of($object); |
7adfd53f |
375 | |
f670cfd0 |
376 | Class::MOP::load_class( $base ); |
377 | Class::MOP::load_class( $object ); |
7adfd53f |
378 | my $meta = eval { Class::MOP::load_class($class) } ? |
f670cfd0 |
379 | $class->meta : $base->meta->create( $class, superclasses => [ $base ]); |
7adfd53f |
380 | |
de48f4e6 |
381 | my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; |
f670cfd0 |
382 | $meta->make_mutable if $meta->is_immutable; |
c8fbb8ad |
383 | $meta->add_method(_build_member_type => sub{ $object } ); |
f670cfd0 |
384 | #XXX as a default pass the domain model as a target_model until i come up with something |
385 | #better through the coercion method |
386 | my $def_act_args = sub { |
387 | my $super = shift; |
388 | return { (target_model => $_[0]->_source_resultset), %{ $super->(@_) } }; |
389 | }; |
390 | $meta->add_around_method_modifier('_default_action_args_for', $def_act_args); |
391 | |
392 | |
393 | { |
394 | my $all_actions = $self->_all_collection_actions; |
395 | my $action_haystack = [keys %$all_actions]; |
396 | if(!defined $action_rules){ |
397 | $action_rules = $self->default_collection_actions; |
398 | } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){ |
399 | $action_rules = [ $action_rules ]; |
400 | } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){ |
401 | #don't add a qr/./ rule if we have at least one match rule |
402 | push(@$action_rules, qr/./) |
403 | unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') |
404 | || !ref $_ || ref $_ eq 'Regexp'} @$action_rules; |
7adfd53f |
405 | } |
7adfd53f |
406 | |
f670cfd0 |
407 | # XXX this is kind of a dirty hack to support custom actions that are not |
408 | # previously defined and still be able to use the parse_reflect_rules mechanism |
409 | my @custom_actions = grep {!exists $all_actions->{$_}} |
410 | map{ $_->[0] } grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules; |
411 | push(@$action_haystack, @custom_actions); |
412 | my $actions = $self->parse_reflect_rules($action_rules, $action_haystack); |
413 | for my $action (keys %$actions){ |
414 | my $action_opts = $self->merge_hashes |
415 | ($all_actions->{$action} || {}, $actions->{$action} || {}); |
7b78a39d |
416 | |
417 | #NOTE: If the name of the action is not specified in the prototype then use it's |
418 | #hash key as the name. I think this is sane beahvior, but I've actually been thinking |
419 | #of making Action prototypes their own separate objects |
f670cfd0 |
420 | $self->reflect_source_action( |
421 | name => $action, |
422 | object_class => $object, |
423 | source_class => $source, |
424 | %$action_opts, |
425 | ); |
426 | |
427 | # XXX i will move this to use the coercion method soon. this will be |
428 | # GoodEnough until then. I still need to think a little about the type coercion |
429 | # thing so i don't make a mess of it |
430 | my $act_args = sub { #override target model for this action |
431 | my $super = shift; |
432 | return { %{ $super->(@_) }, |
433 | ($_[1] eq $action ? (target_model => $_[0]->_source_resultset) : () ) }; |
434 | }; |
435 | $meta->add_around_method_modifier('_default_action_args_for', $act_args); |
436 | } |
437 | } |
7adfd53f |
438 | $meta->make_immutable if $make_immutable; |
439 | return $meta; |
440 | }; |
441 | |
f670cfd0 |
442 | implements reflect_source_object => as { |
443 | my($self, %opts) = @_; |
444 | %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) }; |
445 | |
446 | my $base = delete $opts{base} || Object; |
447 | my $class = delete $opts{class}; |
448 | my $dm_name = delete $opts{domain_model_name}; |
449 | my $dm_opts = delete $opts{domain_model_args} || {}; |
450 | |
451 | my $source_name = delete $opts{source_name}; |
452 | my $schema = delete $opts{schema_class}; |
453 | my $source_class = delete $opts{source_class}; |
454 | my $parent = delete $opts{parent_class}; |
455 | my $parent_dm = delete $opts{parent_domain_model_name}; |
456 | |
457 | my $action_rules = delete $opts{actions}; |
458 | my $attr_rules = delete $opts{attributes}; |
459 | |
460 | $class ||= $self->class_name_from_source_name($parent, $source_name); |
461 | |
462 | Class::MOP::load_class($parent); |
463 | Class::MOP::load_class($schema) if $schema; |
464 | Class::MOP::load_class($source_class); |
465 | |
7adfd53f |
466 | my $meta = eval { Class::MOP::load_class($class) } ? |
f670cfd0 |
467 | $class->meta : $base->meta->create($class, superclasses => [ $base ]); |
7adfd53f |
468 | |
469 | #create the domain model |
f670cfd0 |
470 | $dm_name ||= $self->dm_name_from_source_name($source_name); |
7adfd53f |
471 | |
f670cfd0 |
472 | $dm_opts->{isa} = $source_class; |
7adfd53f |
473 | $dm_opts->{is} ||= 'rw'; |
474 | $dm_opts->{required} ||= 1; |
7adfd53f |
475 | |
de48f4e6 |
476 | my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; |
f670cfd0 |
477 | $meta->make_mutable if $meta->is_immutable; |
478 | |
479 | my $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts); |
480 | my $dm_reader = $dm_attr->get_read_method; |
481 | |
482 | unless( $class->can('inflate_result') ){ |
7adfd53f |
483 | my $inflate_method = sub { |
484 | my $class = shift; my ($src) = @_; |
485 | $src = $src->resolve if $src->isa('DBIx::Class::ResultSourceHandle'); |
486 | $class->new($dm_name, $src->result_class->inflate_result(@_)); |
487 | }; |
488 | $meta->add_method('inflate_result', $inflate_method); |
489 | } |
490 | |
f670cfd0 |
491 | #XXX this is here to allow action prototypes to work with ListView |
492 | # maybe Collections hsould have this kind of thing too to allow you to reconstruct them? |
493 | #i like the possibility to be honest... as aset of key/value pairs they could be URId |
494 | #XXX move to using 'handles' for this? |
495 | $meta->add_method('__id', sub {shift->$dm_reader->id} ) |
496 | unless $class->can('__id'); |
497 | #XXX this one is for ActionForm, ChooseOne and ChooseMany need this shit |
498 | $meta->add_method('__ident_condition', sub {shift->$dm_reader->ident_condition} ) |
499 | unless $class->can('__ident_condition'); |
500 | |
501 | #XXX this is just a disaster |
502 | $meta->add_method('display_name', sub {shift->$dm_reader->display_name} ) |
503 | if( $source_class->can('display_name') && !$class->can('display_name')); |
504 | |
505 | #XXX as a default pass the domain model as a target_model until i come up with something |
506 | #better through the coercion method |
507 | my $def_act_args = sub { |
508 | my $super = shift; |
509 | confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader); |
510 | return { (target_model => $_[0]->$dm_reader), %{ $super->(@_) } }; |
511 | }; |
512 | $meta->add_around_method_modifier('_default_action_args_for', $def_act_args); |
513 | |
514 | { |
515 | # attributes => undef, #default to qr/./ |
516 | # attributes => [], #default to nothing |
517 | # attributes => qr//, #DWIM, treated as [qr//] |
518 | # attributes => [{...}] #DWIM, treat as [qr/./, {...} ] |
519 | # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]] |
520 | my $attr_haystack = |
521 | [ map { $_->name } $source_class->meta->compute_all_applicable_attributes ]; |
522 | |
523 | if(!defined $attr_rules){ |
524 | $attr_rules = [qr/./]; |
525 | } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){ |
526 | $attr_rules = [ $attr_rules ]; |
527 | } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){ |
528 | #don't add a qr/./ rule if we have at least one match rule |
529 | push(@$attr_rules, qr/./) unless |
530 | grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') |
531 | || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules; |
532 | } |
533 | |
534 | my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); |
535 | for my $attr_name (keys %$attributes){ |
536 | $self->reflect_source_object_attribute( |
537 | class => $class, |
538 | source_class => $source_class, |
539 | parent_class => $parent, |
540 | attribute_name => $attr_name, |
541 | domain_model_name => $dm_name, |
542 | %{ $attributes->{$attr_name} || {}}, |
543 | ); |
544 | } |
7adfd53f |
545 | } |
546 | |
f670cfd0 |
547 | { |
548 | my $all_actions = $self->_all_object_actions; |
549 | my $action_haystack = [keys %$all_actions]; |
550 | if(!defined $action_rules){ |
551 | $action_rules = $self->default_object_actions; |
552 | } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){ |
553 | $action_rules = [ $action_rules ]; |
554 | } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){ |
555 | #don't add a qr/./ rule if we have at least one match rule |
556 | push(@$action_rules, qr/./) |
557 | unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') |
558 | || !ref $_ || ref $_ eq 'Regexp'} @$action_rules; |
559 | } |
560 | |
561 | # XXX this is kind of a dirty hack to support custom actions that are not |
562 | # previously defined and still be able to use the parse_reflect_rules mechanism |
563 | my @custom_actions = grep {!exists $all_actions->{$_}} map{ $_->[0] } |
564 | grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules; |
565 | push(@$action_haystack, @custom_actions); |
566 | my $actions = $self->parse_reflect_rules($action_rules, $action_haystack); |
567 | for my $action (keys %$actions){ |
568 | my $action_opts = $self->merge_hashes |
569 | ($all_actions->{$action} || {}, $actions->{$action} || {}); |
7b78a39d |
570 | |
571 | #NOTE: If the name of the action is not specified in the prototype then use it's |
572 | #hash key as the name. I think this is sane beahvior, but I've actually been thinking |
573 | #of making Action prototypes their own separate objects |
f670cfd0 |
574 | $self->reflect_source_action( |
575 | name => $action, |
576 | object_class => $class, |
577 | source_class => $source_class, |
578 | %$action_opts, |
579 | ); |
580 | |
581 | # XXX i will move this to use the coercion method soon. this will be |
582 | # GoodEnough until then. I still need to think a little about the type coercion |
583 | # thing so i don't make a mess of it |
584 | my $act_args = sub { #override target model for this action |
585 | my $super = shift; |
586 | confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader); |
587 | return { %{ $super->(@_) }, |
588 | ($_[1] eq $action ? (target_model => $_[0]->$dm_reader) : () ) }; |
589 | }; |
590 | $meta->add_around_method_modifier('_default_action_args_for', $act_args); |
7adfd53f |
591 | } |
7adfd53f |
592 | } |
593 | |
594 | $meta->make_immutable if $make_immutable; |
595 | return $meta; |
596 | }; |
597 | |
598 | # needs class, attribute_name domain_model_name |
f670cfd0 |
599 | implements reflect_source_object_attribute => as { |
7adfd53f |
600 | my ($self, %opts) = @_; |
f670cfd0 |
601 | unless( $opts{attribute_name} && $opts{class} && $opts{parent_class} |
602 | && ( $opts{source_class} || $opts{domain_model_name} ) ){ |
603 | confess( "Error: class, parent_class, attribute_name, and either " . |
604 | "domain_model_name or source_class are required parameters" ); |
605 | } |
606 | |
7adfd53f |
607 | my $meta = $opts{class}->meta; |
f670cfd0 |
608 | my $attr_opts = $self->parameters_for_source_object_attribute(%opts); |
7adfd53f |
609 | |
610 | my $make_immutable = $meta->is_immutable; |
611 | $meta->make_mutable if $meta->is_immutable; |
f670cfd0 |
612 | |
7adfd53f |
613 | my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts); |
7adfd53f |
614 | |
f670cfd0 |
615 | $meta->make_immutable if $make_immutable; |
7adfd53f |
616 | return $attr; |
617 | }; |
618 | |
619 | # needs class, attribute_name domain_model_name |
f670cfd0 |
620 | implements parameters_for_source_object_attribute => as { |
7adfd53f |
621 | my ($self, %opts) = @_; |
622 | |
f670cfd0 |
623 | my $class = delete $opts{class}; |
624 | my $attr_name = delete $opts{attribute_name}; |
625 | my $dm_name = delete $opts{domain_model_name}; |
626 | my $source_class = delete $opts{source_class}; |
627 | my $parent_class = delete $opts{parent_class}; |
628 | confess("parent_class is a required argument") unless $parent_class; |
629 | confess("You must supply at least one of domain_model_name and source_class") |
630 | unless $dm_name || $source_class; |
631 | |
632 | my $source; |
633 | $source = $source_class->result_source_instance if $source_class; |
634 | #puke! dwimery |
635 | if( !$source_class ){ |
636 | my $dm = $class->meta->find_attribute_by_name($dm_name); |
637 | $source_class = $dm->_isa_metadata; |
638 | $source = $source_class->result_source_instance; |
639 | } elsif( !$dm_name ){ |
640 | ($dm_name) = map{$_->name} grep{$_->_isa_metadata eq $source_class} |
641 | $class->meta->domain_models; |
642 | if( !$dm_name ){ #last resort guess |
643 | my $tentative = $self->dm_name_from_source_name($source->source_name); |
644 | ($dm_name) = $tentative if grep{$_->name eq $tentative} $class->domain_models; |
645 | } |
646 | } |
647 | |
648 | my $from_attr = $source_class->meta->find_attribute_by_name($attr_name); |
7adfd53f |
649 | |
650 | #default options. lazy build but no outsider method |
651 | my %attr_opts = ( is => 'ro', lazy => 1, required => 1, |
652 | clearer => "_clear_${attr_name}", |
653 | predicate => "has_${attr_name}", |
654 | domain_model => $dm_name, |
655 | orig_attr_name => $attr_name, |
656 | ); |
657 | |
658 | #m2m / has_many |
659 | my $constraint_is_ArrayRef = |
660 | $from_attr->type_constraint->name eq 'ArrayRef' || |
661 | $from_attr->type_constraint->is_subtype_of('ArrayRef'); |
662 | |
663 | if( my $rel_info = $source->relationship_info($attr_name) ){ |
664 | my $rel_accessor = $rel_info->{attrs}->{accessor}; |
f670cfd0 |
665 | my $rel_moniker = $rel_info->{class}->result_source_instance->source_name; |
7adfd53f |
666 | |
667 | if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { |
668 | #has_many |
f670cfd0 |
669 | my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker); |
7adfd53f |
670 | #type constraint is a collection, and default builds it |
f670cfd0 |
671 | $attr_opts{isa} = $self->class_name_for_collection_of($sm); |
7adfd53f |
672 | $attr_opts{default} = sub { |
673 | my $rs = shift->$dm_name->related_resultset($attr_name); |
674 | return $attr_opts{isa}->new(_source_resultset => $rs); |
675 | }; |
676 | } elsif( $rel_accessor eq 'single') { |
677 | #belongs_to |
678 | #type constraint is the foreign IM object, default inflates it |
f670cfd0 |
679 | $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker); |
7adfd53f |
680 | $attr_opts{default} = sub { |
681 | shift->$dm_name |
682 | ->find_related($attr_name, {},{result_class => $attr_opts{isa}}); |
683 | }; |
684 | } |
f670cfd0 |
685 | } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) { |
7adfd53f |
686 | #m2m magic |
687 | my $mm_name = $1; |
688 | my $link_table = "links_to_${mm_name}_list"; |
689 | my ($hm_source, $far_side); |
690 | eval { $hm_source = $source->related_source($link_table); } |
691 | || confess "Can't find ${link_table} has_many for ${mm_name}_list"; |
692 | eval { $far_side = $hm_source->related_source($mm_name); } |
693 | || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class |
694 | ." traversing many-many for ${mm_name}_list"; |
695 | |
f670cfd0 |
696 | my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name); |
697 | $attr_opts{isa} = $self->class_name_for_collection_of($sm); |
7adfd53f |
698 | |
699 | #proper collections will remove the result_class uglyness. |
700 | $attr_opts{default} = sub { |
2e2afc48 |
701 | my $rs = shift->$dm_name->related_resultset($link_table)->related_resultset($mm_name); |
7adfd53f |
702 | return $attr_opts{isa}->new(_source_resultset => $rs); |
703 | }; |
704 | } else { |
705 | #no rel |
706 | my $reader = $from_attr->get_read_method; |
707 | $attr_opts{isa} = $from_attr->_isa_metadata; |
708 | $attr_opts{default} = sub{ shift->$dm_name->$reader }; |
709 | } |
710 | return \%attr_opts; |
711 | }; |
712 | |
713 | |
f670cfd0 |
714 | implements reflect_source_action => as{ |
7adfd53f |
715 | my($self, %opts) = @_; |
f670cfd0 |
716 | my $name = delete $opts{name}; |
717 | my $class = delete $opts{class}; |
718 | my $base = delete $opts{base} || Action; |
719 | my $object = delete $opts{object_class}; |
720 | my $source = delete $opts{source_class}; |
721 | |
722 | confess("name, object_class and source_class are required arguments") |
723 | unless $source && $name && $object; |
724 | |
725 | my $attr_rules = delete $opts{attributes}; |
726 | $class ||= $object->_default_action_class_for($name); |
727 | |
728 | Class::MOP::load_class( $base ); |
729 | Class::MOP::load_class( $object ); |
730 | Class::MOP::load_class( $source ); |
731 | |
732 | #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n"; |
733 | # attributes => undef, #default to qr/./ |
734 | # attributes => [], #default to nothing |
735 | # attributes => qr//, #DWIM, treated as [qr//] |
736 | # attributes => [{...}] #DWIM, treat as [qr/./, {...} ] |
737 | # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]] |
738 | my $attr_haystack = [ map {$_->name} $object->meta->parameter_attributes ]; |
739 | if(!defined $attr_rules){ |
740 | $attr_rules = [qr/./]; |
741 | } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){ |
742 | $attr_rules = [ $attr_rules ]; |
743 | } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){ |
744 | #don't add a qr/./ rule if we have at least one match rule |
745 | push(@$attr_rules, qr/./) unless |
746 | grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') |
747 | || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules; |
748 | } |
7adfd53f |
749 | |
f670cfd0 |
750 | #print STDERR "${name}\t${class}\t${base}\n"; |
751 | #print STDERR "\t${object}\t${source}\n"; |
752 | #print STDERR "\t",@$attr_rules,"\n"; |
7adfd53f |
753 | |
f670cfd0 |
754 | my $o_meta = $object->meta; |
755 | my $s_meta = $source->meta; |
756 | my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); |
7adfd53f |
757 | |
758 | #create the class |
759 | my $meta = eval { Class::MOP::load_class($class) } ? |
760 | $class->meta : $base->meta->create($class, superclasses => [$base]); |
de48f4e6 |
761 | my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; |
7adfd53f |
762 | $meta->make_mutable if $meta->is_immutable; |
763 | |
f670cfd0 |
764 | for my $attr_name (keys %$attributes){ |
765 | my $attr_opts = $attributes->{$attr_name} || {}; |
766 | my $o_attr = $o_meta->find_attribute_by_name($attr_name); |
767 | my $s_attr_name = $o_attr->orig_attr_name || $attr_name; |
768 | my $s_attr = $s_meta->find_attribute_by_name($s_attr_name); |
769 | next unless $s_attr->get_write_method; #only rw attributes! |
770 | |
771 | my $attr_params = $self->parameters_for_source_object_action_attribute |
772 | ( |
773 | object_class => $object, |
774 | source_class => $source, |
775 | attribute_name => $attr_name |
776 | ); |
7adfd53f |
777 | $meta->add_attribute( $attr_name => %$attr_params); |
778 | } |
779 | |
780 | $meta->make_immutable if $make_immutable; |
781 | return $meta; |
782 | }; |
783 | |
f670cfd0 |
784 | implements parameters_for_source_object_action_attribute => as { |
7adfd53f |
785 | my ($self, %opts) = @_; |
786 | |
f670cfd0 |
787 | my $object = delete $opts{object_class}; |
788 | my $attr_name = delete $opts{attribute_name}; |
789 | my $source_class = delete $opts{source_class}; |
790 | confess("object_class and attribute_name are required parameters") |
791 | unless $attr_name && $object; |
792 | |
793 | my $o_meta = $object->meta; |
794 | my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model; |
795 | $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata; |
796 | my $from_attr = $source_class->meta->find_attribute_by_name($attr_name); |
7adfd53f |
797 | |
798 | confess("${attr_name} is not writeable and can not be reflected") |
799 | unless $from_attr->get_write_method; |
800 | |
801 | my %attr_opts = ( |
802 | is => 'rw', |
803 | isa => $from_attr->_isa_metadata, |
804 | required => $from_attr->is_required, |
805 | predicate => "has_${attr_name}", |
806 | ); |
807 | |
808 | if ($attr_opts{required}) { |
809 | $attr_opts{lazy} = 1; |
810 | $attr_opts{default} = $from_attr->has_default ? $from_attr->default : |
811 | sub{confess("${attr_name} must be provided before calling reader")}; |
812 | } |
813 | |
814 | #test for relationships |
815 | my $constraint_is_ArrayRef = |
816 | $from_attr->type_constraint->name eq 'ArrayRef' || |
817 | $from_attr->type_constraint->is_subtype_of('ArrayRef'); |
818 | |
f670cfd0 |
819 | my $source = $source_class->result_source_instance; |
7adfd53f |
820 | if (my $rel_info = $source->relationship_info($attr_name)) { |
821 | my $rel_accessor = $rel_info->{attrs}->{accessor}; |
822 | |
823 | if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { |
824 | confess "${attr_name} is a rw has_many, this won't work."; |
825 | } elsif( $rel_accessor eq 'single') { |
826 | $attr_opts{valid_values} = sub { |
827 | shift->target_model->result_source->related_source($attr_name)->resultset; |
828 | }; |
829 | } |
830 | } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) { |
831 | my $mm_name = $1; |
832 | my $link_table = "links_to_${mm_name}_list"; |
833 | my ($hm_source, $far_side); |
834 | eval { $hm_source = $source->related_source($link_table); } |
835 | || confess "Can't find ${link_table} has_many for ${mm_name}_list"; |
836 | eval { $far_side = $hm_source->related_source($mm_name); } |
837 | || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class |
838 | ." traversing many-many for ${mm_name}_list"; |
839 | |
840 | $attr_opts{default} = sub { [] }; |
841 | $attr_opts{valid_values} = sub { |
f670cfd0 |
842 | shift->target_model->result_source->related_source($link_table) |
7adfd53f |
843 | ->related_source($mm_name)->resultset; |
844 | }; |
845 | } |
f670cfd0 |
846 | #use Data::Dumper; |
89939ff9 |
847 | #print STDERR "\n" .$attr_name ." - ". $object . "\n"; |
f670cfd0 |
848 | #print STDERR Dumper(\%attr_opts); |
7adfd53f |
849 | return \%attr_opts; |
850 | }; |
851 | |
852 | }; |
853 | |
854 | 1; |