projects / catagits/Reaction.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
pass down options accurately
[catagits/Reaction.git] / lib / Reaction / InterfaceModel / Reflector / DBIC.pm
CommitLineData
7adfd53f 1package Reaction::InterfaceModel::Reflector::DBIC;
2
3use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create';
b8faba69 4use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::DeleteAll';
7adfd53f 5use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update';
6use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete';
7
8use aliased 'Reaction::InterfaceModel::Collection::Virtual::ResultSet';
9use aliased 'Reaction::InterfaceModel::Object';
10use aliased 'Reaction::InterfaceModel::Action';
11use Reaction::Class;
12use Class::MOP;
13
f670cfd0 14use Catalyst::Utils;
15
7adfd53f 16class 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 );
c11c77ee 164 my $meta = $self->_load_or_create($model, $base);
f670cfd0 165
166 # sources => undef, #default to qr/./
167 # sources => [], #default to nothing
168 # sources => qr//, #DWIM, treated as [qr//]
169 # sources => [{...}] #DWIM, treat as [qr/./, {...} ]
170 # sources => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
171 my $haystack = [ $schema->sources ];
172
173 my $rules = delete $opts{sources};
174 if(!defined $rules){
175 $rules = [qr/./];
176 } elsif( ref $rules eq 'Regexp'){
177 $rules = [ $rules ];
178 } elsif( ref $rules eq 'ARRAY' && @$rules){
179 #don't add a qr/./ rule if we have at least one match rule
180 push(@$rules, qr/./) unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
181 || !ref $_ || ref $_ eq 'Regexp'} @$rules;
182 }
7adfd53f 183
f670cfd0 184 my $sources = $self->parse_reflect_rules($rules, $haystack);
7adfd53f 185
de48f4e6 186 my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
7adfd53f 187 $meta->make_mutable if $meta->is_immutable;
188
f670cfd0 189 $meta->add_domain_model
190 ($dm_name, is => 'rw', isa => $schema, required => 1, %$dm_args);
191
192 for my $source_name (keys %$sources){
193 my $source_opts = $sources->{$source_name} || {};
194 $self->reflect_source(
195 source_name => $source_name,
196 parent_class => $model,
197 schema_class => $schema,
198 source_class => $schema->class($source_name),
199 parent_domain_model_name => $dm_name,
200 %$source_opts
201 );
7adfd53f 202 }
203
204 $meta->make_immutable if $make_immutable;
205 return $meta;
206 };
207
f670cfd0 208 implements _compute_source_options => as {
209 my ($self, %opts) = @_;
210 my $schema = delete $opts{schema_class};
211 my $source_name = delete $opts{source_name};
212 my $source_class = delete $opts{source_class};
213 my $parent = delete $opts{parent_class};
214 my $parent_dm = delete $opts{parent_domain_model_name};
215
216 #this is the part where I hate my life for promissing all sorts of DWIMery
217 confess("parent_class and source_name or source_class are required parameters")
218 unless($parent && ($source_name || $source_class));
219
220 OUTER: until( $schema && $source_name && $source_class && $parent_dm ){
221 if( $schema && !$source_name){
222 next OUTER if $source_name = $source_class->result_source_instance->source_name;
223 } elsif( $schema && !$source_class){
224 next OUTER if $source_class = eval { $schema->class($source_name) };
225 }
7adfd53f 226
f670cfd0 227 if($source_class && (!$schema || !$source_name)){
228 if(!$schema){
229 $schema = $source_class->result_source_instance->schema;
230 next OUTER if $schema && Class::MOP::load_class($schema);
231 }
232 if(!$source_name){
233 $source_name = $source_class->result_source_instance->source_name;
234 next OUTER if $source_name;
235 }
236 }
237 my @haystack = $parent_dm ?
238 $parent->meta->find_attribute_by_name($parent_dm) : $parent->domain_models;
239
240 #there's a lot of guessing going on, but it should work fine on most cases
241 INNER: for my $needle (@haystack){
242 my $isa = $needle->_isa_metadata;
243 next INNER unless Class::MOP::load_class( $isa->_isa_metadata );
244 next INNER unless $isa->isa('DBIx::Class::Schema');
245 if(!$parent_dm && $schema && $isa eq $schema){
246 $parent_dm = $needle->name;
247 next OUTER;
248 }
249
250 if( $source_name ){
251 my $src_class = eval{ $isa->class($source_name) };
252 next INNER unless $src_class;
253 next INNER if($source_class && $source_class ne $src_class);
254 $schema = $isa;
255 $parent_dm = $needle->name;
256 $source_class = $src_class;
257 next OUTER;
258 }
259 }
260
261 #do we even need to go this far?
262 if( !$parent_dm && $schema ){
263 my $tentative = $self->dm_name_from_class_name($schema);
264 $parent_dm = $tentative if grep{$_->name eq $tentative} @haystack;
265 }
266
267 confess("Could not determine options automatically from: schema " .
268 "'${schema}', source_name '${source_name}', source_class " .
269 "'${source_class}', parent_domain_model_name '${parent_dm}'");
270 }
271
272 return {
273 source_name => $source_name,
274 schema_class => $schema,
275 source_class => $source_class,
276 parent_class => $parent,
277 parent_domain_model_name => $parent_dm,
278 };
279 };
7adfd53f 280
46937531 281 implements _class_to_attribute_name => as {
282 my ( $self, $str ) = @_;
283 confess("wrong arguments passed for _class_to_attribute_name") unless $str;
284 return join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $str))
285 };
7adfd53f 286
f670cfd0 287 implements add_source => as {
288 my ($self, %opts) = @_;
289
290 my $model = delete $opts{model_class};
291 my $reader = delete $opts{reader};
292 my $source = delete $opts{source_name};
293 my $dm_name = delete $opts{domain_model_name};
294 my $collection = delete $opts{collection_class};
295 my $name = delete $opts{attribute_name} || $source;
296
297 confess("model_class and source_name are required parameters")
298 unless $model && $source;
299 my $meta = $model->meta;
300
301 unless( $collection ){
302 my $object = $self->class_name_from_source_name($model, $source);
303 $collection = $self->class_name_for_collection_of($object);
304 }
305 unless( $reader ){
306 $reader = $source;
7adfd53f 307 $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
46937531 308 $reader = $self->_class_to_attribute_name($reader) . "_collection";
7adfd53f 309 }
f670cfd0 310 unless( $dm_name ){
311 my @haystack = $meta->domain_models;
312 if( @haystack > 1 ){
313 @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack;
314 }
315 if(@haystack == 1){
316 $dm_name = $haystack[0]->name;
317 } elsif(@haystack > 1){
318 confess("Failed to automatically determine domain_model_name. More than one " .
319 "possible match (".(join ", ", map{"'".$_->name."'"} @haystack).")");
320 } else {
321 confess("Failed to automatically determine domain_model_name. No matches.");
322 }
323 }
7adfd53f 324
325 my %attr_opts =
326 (
327 lazy => 1,
7adfd53f 328 required => 1,
f670cfd0 329 isa => $collection,
7adfd53f 330 reader => $reader,
46937531 331 predicate => "has_" . $self->_class_to_attribute_name($name) ,
7adfd53f 332 domain_model => $dm_name,
f670cfd0 333 orig_attr_name => $source,
7adfd53f 334 default => sub {
a945c8a0 335 my $self = $_[0];
336 return $collection->new(
337 _source_resultset => $self->$dm_name->resultset($source),
338 _parent => $self,
339 );
7adfd53f 340 },
341 );
7adfd53f 342
7517cfe5 343# my %debug_attr_opts =
344# (
345# lazy => 1,
346# required => 1,
347# isa => $collection,
348# reader => $reader,
349# predicate => "has_" . $self->_class_to_attribute_name($name) ,
350# domain_model => $dm_name,
351# orig_attr_name => $source,
352# default => qq^sub {
353# my \$self = \$_[0];
354# return $collection->new(
355# _source_resultset => \$self->$dm_name->resultset("$source"),
356# _parent => \$self,
357# );
358# }, ^,
359# );
360
361
362
f670cfd0 363 my $make_immutable = $meta->is_immutable;
364 $meta->make_mutable if $make_immutable;
365 my $attr = $meta->add_attribute($name, %attr_opts);
7adfd53f 366 $meta->make_immutable if $make_immutable;
f670cfd0 367
7adfd53f 368 return $attr;
369 };
370
f670cfd0 371 implements reflect_source => as {
372 my ($self, %opts) = @_;
373 my $collection = delete $opts{collection} || {};
374 %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
375
376 my $obj_meta = $self->reflect_source_object(%opts);
377 my $col_meta = $self->reflect_source_collection
378 (
379 object_class => $obj_meta->name,
380 source_class => $opts{source_class},
381 %$collection
382 );
383
384 $self->add_source(
9db0d7aa 385 %opts,
386 model_class => delete $opts{parent_class},
387 domain_model_name => delete $opts{parent_domain_model_name},
f670cfd0 388 collection_class => $col_meta->name,
389 );
390 };
391
392 implements reflect_source_collection => as {
7adfd53f 393 my ($self, %opts) = @_;
7adfd53f 394 my $base = delete $opts{base} || ResultSet;
f670cfd0 395 my $class = delete $opts{class};
396 my $object = delete $opts{object_class};
397 my $source = delete $opts{source_class};
398 my $action_rules = delete $opts{actions};
399
400 confess('object_class and source_class are required parameters')
401 unless $object && $source;
402 $class ||= $self->class_name_for_collection_of($object);
7adfd53f 403
f670cfd0 404 Class::MOP::load_class( $base );
405 Class::MOP::load_class( $object );
c11c77ee 406 my $meta = $self->_load_or_create($class, $base);
7adfd53f 407
de48f4e6 408 my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;;
f670cfd0 409 $meta->make_mutable if $meta->is_immutable;
c8fbb8ad 410 $meta->add_method(_build_member_type => sub{ $object } );
f670cfd0 411 #XXX as a default pass the domain model as a target_model until i come up with something
412 #better through the coercion method
413 my $def_act_args = sub {
414 my $super = shift;
415 return { (target_model => $_[0]->_source_resultset), %{ $super->(@_) } };
416 };
417 $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
418
419
420 {
421 my $all_actions = $self->_all_collection_actions;
422 my $action_haystack = [keys %$all_actions];
423 if(!defined $action_rules){
424 $action_rules = $self->default_collection_actions;
425 } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){
426 $action_rules = [ $action_rules ];
427 } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){
428 #don't add a qr/./ rule if we have at least one match rule
429 push(@$action_rules, qr/./)
430 unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
431 || !ref $_ || ref $_ eq 'Regexp'} @$action_rules;
7adfd53f 432 }
7adfd53f 433
f670cfd0 434 # XXX this is kind of a dirty hack to support custom actions that are not
435 # previously defined and still be able to use the parse_reflect_rules mechanism
436 my @custom_actions = grep {!exists $all_actions->{$_}}
437 map{ $_->[0] } grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules;
438 push(@$action_haystack, @custom_actions);
439 my $actions = $self->parse_reflect_rules($action_rules, $action_haystack);
440 for my $action (keys %$actions){
441 my $action_opts = $self->merge_hashes
442 ($all_actions->{$action} || {}, $actions->{$action} || {});
7b78a39d 443
444 #NOTE: If the name of the action is not specified in the prototype then use it's
445 #hash key as the name. I think this is sane beahvior, but I've actually been thinking
446 #of making Action prototypes their own separate objects
f670cfd0 447 $self->reflect_source_action(
448 name => $action,
449 object_class => $object,
450 source_class => $source,
451 %$action_opts,
452 );
453
454 # XXX i will move this to use the coercion method soon. this will be
455 # GoodEnough until then. I still need to think a little about the type coercion
456 # thing so i don't make a mess of it
457 my $act_args = sub { #override target model for this action
458 my $super = shift;
459 return { %{ $super->(@_) },
460 ($_[1] eq $action ? (target_model => $_[0]->_source_resultset) : () ) };
461 };
462 $meta->add_around_method_modifier('_default_action_args_for', $act_args);
463 }
464 }
7adfd53f 465 $meta->make_immutable if $make_immutable;
466 return $meta;
467 };
468
f670cfd0 469 implements reflect_source_object => as {
470 my($self, %opts) = @_;
471 %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
472
473 my $base = delete $opts{base} || Object;
474 my $class = delete $opts{class};
475 my $dm_name = delete $opts{domain_model_name};
476 my $dm_opts = delete $opts{domain_model_args} || {};
477
478 my $source_name = delete $opts{source_name};
479 my $schema = delete $opts{schema_class};
480 my $source_class = delete $opts{source_class};
481 my $parent = delete $opts{parent_class};
482 my $parent_dm = delete $opts{parent_domain_model_name};
483
484 my $action_rules = delete $opts{actions};
485 my $attr_rules = delete $opts{attributes};
486
487 $class ||= $self->class_name_from_source_name($parent, $source_name);
488
489 Class::MOP::load_class($parent);
490 Class::MOP::load_class($schema) if $schema;
491 Class::MOP::load_class($source_class);
492
c11c77ee 493 my $meta = $self->_load_or_create($class, $base);
7adfd53f 494
495 #create the domain model
f670cfd0 496 $dm_name ||= $self->dm_name_from_source_name($source_name);
7adfd53f 497
f670cfd0 498 $dm_opts->{isa} = $source_class;
7adfd53f 499 $dm_opts->{is} ||= 'rw';
500 $dm_opts->{required} ||= 1;
7adfd53f 501
de48f4e6 502 my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;;
f670cfd0 503 $meta->make_mutable if $meta->is_immutable;
504
505 my $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts);
506 my $dm_reader = $dm_attr->get_read_method;
507
508 unless( $class->can('inflate_result') ){
7adfd53f 509 my $inflate_method = sub {
510 my $class = shift; my ($src) = @_;
511 $src = $src->resolve if $src->isa('DBIx::Class::ResultSourceHandle');
512 $class->new($dm_name, $src->result_class->inflate_result(@_));
513 };
514 $meta->add_method('inflate_result', $inflate_method);
515 }
516
f670cfd0 517 #XXX this is here to allow action prototypes to work with ListView
518 # maybe Collections hsould have this kind of thing too to allow you to reconstruct them?
519 #i like the possibility to be honest... as aset of key/value pairs they could be URId
520 #XXX move to using 'handles' for this?
521 $meta->add_method('__id', sub {shift->$dm_reader->id} )
522 unless $class->can('__id');
5ee24b95 523 #XXX this one is for Action, ChooseOne and ChooseMany need this shit
f670cfd0 524 $meta->add_method('__ident_condition', sub {shift->$dm_reader->ident_condition} )
525 unless $class->can('__ident_condition');
526
527 #XXX this is just a disaster
528 $meta->add_method('display_name', sub {shift->$dm_reader->display_name} )
529 if( $source_class->can('display_name') && !$class->can('display_name'));
530
531 #XXX as a default pass the domain model as a target_model until i come up with something
532 #better through the coercion method
533 my $def_act_args = sub {
534 my $super = shift;
535 confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
536 return { (target_model => $_[0]->$dm_reader), %{ $super->(@_) } };
537 };
538 $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
539
540 {
541 # attributes => undef, #default to qr/./
542 # attributes => [], #default to nothing
543 # attributes => qr//, #DWIM, treated as [qr//]
544 # attributes => [{...}] #DWIM, treat as [qr/./, {...} ]
545 # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
546 my $attr_haystack =
547 [ map { $_->name } $source_class->meta->compute_all_applicable_attributes ];
548
549 if(!defined $attr_rules){
550 $attr_rules = [qr/./];
551 } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
552 $attr_rules = [ $attr_rules ];
553 } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
554 #don't add a qr/./ rule if we have at least one match rule
555 push(@$attr_rules, qr/./) unless
556 grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
557 || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules;
558 }
559
560 my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
561 for my $attr_name (keys %$attributes){
562 $self->reflect_source_object_attribute(
563 class => $class,
564 source_class => $source_class,
565 parent_class => $parent,
566 attribute_name => $attr_name,
567 domain_model_name => $dm_name,
568 %{ $attributes->{$attr_name} || {}},
569 );
570 }
7adfd53f 571 }
572
f670cfd0 573 {
574 my $all_actions = $self->_all_object_actions;
575 my $action_haystack = [keys %$all_actions];
576 if(!defined $action_rules){
577 $action_rules = $self->default_object_actions;
578 } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){
579 $action_rules = [ $action_rules ];
580 } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){
581 #don't add a qr/./ rule if we have at least one match rule
582 push(@$action_rules, qr/./)
583 unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
584 || !ref $_ || ref $_ eq 'Regexp'} @$action_rules;
585 }
586
587 # XXX this is kind of a dirty hack to support custom actions that are not
588 # previously defined and still be able to use the parse_reflect_rules mechanism
589 my @custom_actions = grep {!exists $all_actions->{$_}} map{ $_->[0] }
590 grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules;
591 push(@$action_haystack, @custom_actions);
592 my $actions = $self->parse_reflect_rules($action_rules, $action_haystack);
593 for my $action (keys %$actions){
594 my $action_opts = $self->merge_hashes
595 ($all_actions->{$action} || {}, $actions->{$action} || {});
7b78a39d 596
597 #NOTE: If the name of the action is not specified in the prototype then use it's
598 #hash key as the name. I think this is sane beahvior, but I've actually been thinking
599 #of making Action prototypes their own separate objects
f670cfd0 600 $self->reflect_source_action(
601 name => $action,
602 object_class => $class,
603 source_class => $source_class,
604 %$action_opts,
605 );
606
607 # XXX i will move this to use the coercion method soon. this will be
608 # GoodEnough until then. I still need to think a little about the type coercion
609 # thing so i don't make a mess of it
610 my $act_args = sub { #override target model for this action
611 my $super = shift;
612 confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
613 return { %{ $super->(@_) },
614 ($_[1] eq $action ? (target_model => $_[0]->$dm_reader) : () ) };
615 };
616 $meta->add_around_method_modifier('_default_action_args_for', $act_args);
7adfd53f 617 }
7adfd53f 618 }
619
620 $meta->make_immutable if $make_immutable;
621 return $meta;
622 };
623
624 # needs class, attribute_name domain_model_name
f670cfd0 625 implements reflect_source_object_attribute => as {
7adfd53f 626 my ($self, %opts) = @_;
f670cfd0 627 unless( $opts{attribute_name} && $opts{class} && $opts{parent_class}
628 && ( $opts{source_class} || $opts{domain_model_name} ) ){
629 confess( "Error: class, parent_class, attribute_name, and either " .
630 "domain_model_name or source_class are required parameters" );
631 }
632
7adfd53f 633 my $meta = $opts{class}->meta;
f670cfd0 634 my $attr_opts = $self->parameters_for_source_object_attribute(%opts);
7adfd53f 635
636 my $make_immutable = $meta->is_immutable;
637 $meta->make_mutable if $meta->is_immutable;
f670cfd0 638
7adfd53f 639 my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts);
7adfd53f 640
f670cfd0 641 $meta->make_immutable if $make_immutable;
7adfd53f 642 return $attr;
643 };
644
645 # needs class, attribute_name domain_model_name
f670cfd0 646 implements parameters_for_source_object_attribute => as {
7adfd53f 647 my ($self, %opts) = @_;
648
f670cfd0 649 my $class = delete $opts{class};
650 my $attr_name = delete $opts{attribute_name};
651 my $dm_name = delete $opts{domain_model_name};
652 my $source_class = delete $opts{source_class};
653 my $parent_class = delete $opts{parent_class};
654 confess("parent_class is a required argument") unless $parent_class;
655 confess("You must supply at least one of domain_model_name and source_class")
656 unless $dm_name || $source_class;
657
658 my $source;
659 $source = $source_class->result_source_instance if $source_class;
660 #puke! dwimery
661 if( !$source_class ){
662 my $dm = $class->meta->find_attribute_by_name($dm_name);
663 $source_class = $dm->_isa_metadata;
664 $source = $source_class->result_source_instance;
665 } elsif( !$dm_name ){
666 ($dm_name) = map{$_->name} grep{$_->_isa_metadata eq $source_class}
667 $class->meta->domain_models;
668 if( !$dm_name ){ #last resort guess
669 my $tentative = $self->dm_name_from_source_name($source->source_name);
670 ($dm_name) = $tentative if grep{$_->name eq $tentative} $class->domain_models;
671 }
672 }
673
674 my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
7adfd53f 675
676 #default options. lazy build but no outsider method
677 my %attr_opts = ( is => 'ro', lazy => 1, required => 1,
678 clearer => "_clear_${attr_name}",
679 predicate => "has_${attr_name}",
680 domain_model => $dm_name,
681 orig_attr_name => $attr_name,
682 );
683
684 #m2m / has_many
685 my $constraint_is_ArrayRef =
686 $from_attr->type_constraint->name eq 'ArrayRef' ||
687 $from_attr->type_constraint->is_subtype_of('ArrayRef');
688
7517cfe5 689
690
7adfd53f 691 if( my $rel_info = $source->relationship_info($attr_name) ){
692 my $rel_accessor = $rel_info->{attrs}->{accessor};
f670cfd0 693 my $rel_moniker = $rel_info->{class}->result_source_instance->source_name;
7adfd53f 694
695 if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
696 #has_many
f670cfd0 697 my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker);
7adfd53f 698 #type constraint is a collection, and default builds it
f670cfd0 699 $attr_opts{isa} = $self->class_name_for_collection_of($sm);
7adfd53f 700 $attr_opts{default} = sub {
701 my $rs = shift->$dm_name->related_resultset($attr_name);
702 return $attr_opts{isa}->new(_source_resultset => $rs);
703 };
704 } elsif( $rel_accessor eq 'single') {
705 #belongs_to
706 #type constraint is the foreign IM object, default inflates it
f670cfd0 707 $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
7adfd53f 708 $attr_opts{default} = sub {
709 shift->$dm_name
710 ->find_related($attr_name, {},{result_class => $attr_opts{isa}});
711 };
712 }
f670cfd0 713 } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
7adfd53f 714 #m2m magic
715 my $mm_name = $1;
716 my $link_table = "links_to_${mm_name}_list";
717 my ($hm_source, $far_side);
718 eval { $hm_source = $source->related_source($link_table); }
719 || confess "Can't find ${link_table} has_many for ${mm_name}_list";
720 eval { $far_side = $hm_source->related_source($mm_name); }
721 || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
722 ." traversing many-many for ${mm_name}_list";
723
f670cfd0 724 my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name);
725 $attr_opts{isa} = $self->class_name_for_collection_of($sm);
7adfd53f 726
727 #proper collections will remove the result_class uglyness.
728 $attr_opts{default} = sub {
2e2afc48 729 my $rs = shift->$dm_name->related_resultset($link_table)->related_resultset($mm_name);
7adfd53f 730 return $attr_opts{isa}->new(_source_resultset => $rs);
731 };
7517cfe5 732 #} elsif( $constraint_is_ArrayRef ){
733 #test these to see if rel is m2m
734 #my $meth = $attr_name;
735 #if( $source->can("set_${meth}") && $source->can("add_to_${meth}") &&
736 # $source->can("${meth}_rs") && $source->can("remove_from_${meth}") ){
737
738
739 #}
7adfd53f 740 } else {
741 #no rel
742 my $reader = $from_attr->get_read_method;
743 $attr_opts{isa} = $from_attr->_isa_metadata;
744 $attr_opts{default} = sub{ shift->$dm_name->$reader };
745 }
746 return \%attr_opts;
747 };
748
749
f670cfd0 750 implements reflect_source_action => as{
7adfd53f 751 my($self, %opts) = @_;
f670cfd0 752 my $name = delete $opts{name};
753 my $class = delete $opts{class};
754 my $base = delete $opts{base} || Action;
755 my $object = delete $opts{object_class};
756 my $source = delete $opts{source_class};
757
758 confess("name, object_class and source_class are required arguments")
759 unless $source && $name && $object;
760
761 my $attr_rules = delete $opts{attributes};
762 $class ||= $object->_default_action_class_for($name);
763
764 Class::MOP::load_class( $base );
765 Class::MOP::load_class( $object );
766 Class::MOP::load_class( $source );
767
768 #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n";
769 # attributes => undef, #default to qr/./
770 # attributes => [], #default to nothing
771 # attributes => qr//, #DWIM, treated as [qr//]
772 # attributes => [{...}] #DWIM, treat as [qr/./, {...} ]
773 # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
32afff5d 774 my $attr_haystack = [ map { $_->name } $object->meta->parameter_attributes ];
f670cfd0 775 if(!defined $attr_rules){
776 $attr_rules = [qr/./];
777 } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
778 $attr_rules = [ $attr_rules ];
779 } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
780 #don't add a qr/./ rule if we have at least one match rule
781 push(@$attr_rules, qr/./) unless
782 grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
783 || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules;
784 }
7adfd53f 785
f670cfd0 786 #print STDERR "${name}\t${class}\t${base}\n";
787 #print STDERR "\t${object}\t${source}\n";
788 #print STDERR "\t",@$attr_rules,"\n";
7adfd53f 789
f670cfd0 790 my $o_meta = $object->meta;
791 my $s_meta = $source->meta;
792 my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
7adfd53f 793
794 #create the class
c11c77ee 795 my $meta = $self->_load_or_create($class, $base);
de48f4e6 796 my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
7adfd53f 797 $meta->make_mutable if $meta->is_immutable;
798
f670cfd0 799 for my $attr_name (keys %$attributes){
800 my $attr_opts = $attributes->{$attr_name} || {};
801 my $o_attr = $o_meta->find_attribute_by_name($attr_name);
802 my $s_attr_name = $o_attr->orig_attr_name || $attr_name;
803 my $s_attr = $s_meta->find_attribute_by_name($s_attr_name);
32afff5d 804 confess("Unable to find attribute for '${s_attr_name}' via '${source}'")
805 unless defined $s_attr;
5e1a47e6 806 next unless $s_attr->get_write_method
807 && $s_attr->get_write_method !~ /^_/; #only rw attributes!
f670cfd0 808
809 my $attr_params = $self->parameters_for_source_object_action_attribute
810 (
811 object_class => $object,
812 source_class => $source,
813 attribute_name => $attr_name
814 );
7adfd53f 815 $meta->add_attribute( $attr_name => %$attr_params);
816 }
817
818 $meta->make_immutable if $make_immutable;
819 return $meta;
820 };
821
f670cfd0 822 implements parameters_for_source_object_action_attribute => as {
7adfd53f 823 my ($self, %opts) = @_;
824
f670cfd0 825 my $object = delete $opts{object_class};
826 my $attr_name = delete $opts{attribute_name};
827 my $source_class = delete $opts{source_class};
828 confess("object_class and attribute_name are required parameters")
829 unless $attr_name && $object;
830
831 my $o_meta = $object->meta;
832 my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model;
833 $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
834 my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
7adfd53f 835
7517cfe5 836 #print STDERR "$attr_name is type: " . $from_attr->meta->name . "\n";
837
7adfd53f 838 confess("${attr_name} is not writeable and can not be reflected")
839 unless $from_attr->get_write_method;
840
841 my %attr_opts = (
842 is => 'rw',
843 isa => $from_attr->_isa_metadata,
844 required => $from_attr->is_required,
e44959e8 845 ($from_attr->is_required
ff009e64 846 ? () : (clearer => "clear_${attr_name}")),
7adfd53f 847 predicate => "has_${attr_name}",
848 );
849
850 if ($attr_opts{required}) {
3fad510b 851 if($from_attr->has_default) {
852 $attr_opts{lazy} = 1;
853 $attr_opts{default} = $from_attr->default;
854 } else {
855 $attr_opts{lazy_fail} = 1;
856 }
7adfd53f 857 }
858
859 #test for relationships
860 my $constraint_is_ArrayRef =
861 $from_attr->type_constraint->name eq 'ArrayRef' ||
862 $from_attr->type_constraint->is_subtype_of('ArrayRef');
863
f670cfd0 864 my $source = $source_class->result_source_instance;
7adfd53f 865 if (my $rel_info = $source->relationship_info($attr_name)) {
866 my $rel_accessor = $rel_info->{attrs}->{accessor};
867
868 if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
869 confess "${attr_name} is a rw has_many, this won't work.";
870 } elsif( $rel_accessor eq 'single') {
871 $attr_opts{valid_values} = sub {
872 shift->target_model->result_source->related_source($attr_name)->resultset;
873 };
874 }
875 } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
876 my $mm_name = $1;
877 my $link_table = "links_to_${mm_name}_list";
878 my ($hm_source, $far_side);
879 eval { $hm_source = $source->related_source($link_table); }
880 || confess "Can't find ${link_table} has_many for ${mm_name}_list";
881 eval { $far_side = $hm_source->related_source($mm_name); }
882 || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
883 ." traversing many-many for ${mm_name}_list";
884
885 $attr_opts{default} = sub { [] };
886 $attr_opts{valid_values} = sub {
f670cfd0 887 shift->target_model->result_source->related_source($link_table)
7adfd53f 888 ->related_source($mm_name)->resultset;
889 };
890 }
f670cfd0 891 #use Data::Dumper;
89939ff9 892 #print STDERR "\n" .$attr_name ." - ". $object . "\n";
f670cfd0 893 #print STDERR Dumper(\%attr_opts);
7adfd53f 894 return \%attr_opts;
895 };
896
c11c77ee 897 implements _load_or_create => as {
898 my ($self, $class, $base) = @_;
ff009e64 899 my $meta = $self->_maybe_load_class($class) ?
c11c77ee 900 $class->meta : $base->meta->create($class, superclasses => [ $base ]);
901 return $meta;
902 };
903
904 implements _maybe_load_class => as {
905 my ($self, $class) = @_;
906 my $file = $class . '.pm';
907 $file =~ s{::}{/}g;
908 my $ret = eval { Class::MOP::load_class($class) };
909 if ($INC{$file} && $@) {
910 confess "Error loading ${class}: $@";
911 }
912 return $ret;
913 };
914
7adfd53f 915};
916
9171;
0402136b 918
919#--------#---------#---------#---------#---------#---------#---------#---------#
920__END__;
921
922=head1 NAME
923
924Reaction::InterfaceModel::Reflector::DBIC -
925Automatically Generate InterfaceModels from DBIx::Class models
926
927=head1 DESCRIPTION
928
929The InterfaceModel reflectors are classes that are meant to aid you in easily
930generating Reaction::InterfaceModel classes that represent their underlying
931DBIx::Class domain models by introspecting your L<DBIx::Class::ResultSource>s
932and creating a collection of L<Reaction::InterfaceModel::Object> and
933L<Reaction::InterfaceModel::Collection> classes for you to use.
934
935The default base class of all Object classes will be
936 L<Reaction::InterfaceModel::Object> and the default Collection type will be
937L<Reaction::InterfaceModel::Collection::Virtual::ResultSet>.
938
939Additionally, the reflector can create InterfaceModel actions that interact
940with the supplied L<Reaction::UI::Controller::Collection::CRUD>, allowing you
941to easily set up a highly customizable CRUD interface in minimal time.
942
943At this time, supported collection actions consist of:
944
945=over 4
946
947=item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::Create>
948
949Creates a new item in the collection and underlying ResultSet.
950
951=item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::DeleteAll>
952
953Deletes all the items in a collection and it's underlying resultset using
954C<delete_all>
955
956=back
957
958And supported object actions are :
959
960=over 4
961
962=item B<Update> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Update>
963
964Updates an existing object.
965
966=item B<Delete> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Delete>
967
968Deletes an existing object.
969
970=back
971
972=head1 SYNOPSIS
973
974 package MyApp::IM::TestModel;
975 use base 'Reaction::InterfaceModel::Object';
976 use Reaction::Class;
977 use Reaction::InterfaceModel::Reflector::DBIC;
978 my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
979
980 #Reflect everything
981 $reflector->reflect_schema
982 (
983 model_class => __PACKAGE__,
984 schema_class => 'MyApp::Schema',
985 );
986
987=head2 Selectively including and excluding sources
988
989 #reflect everything except for the FooBar and FooBaz classes
990 $reflector->reflect_schema
991 (
992 model_class => __PACKAGE__,
993 schema_class => 'MyApp::Schema',
994 sources => [-exclude => [qw/FooBar FooBaz/] ],
995 # you could also do:
996 sources => [-exclude => qr/(?:FooBar|FooBaz)/,
997 # or even
998 sources => [-exclude => [qr/FooBar/, qr/FooBaz/],
999 );
1000
1001 #reflect only the Foo family of sources
1002 $reflector->reflect_schema
1003 (
1004 model_class => __PACKAGE__,
1005 schema_class => 'MyApp::Schema',
1006 sources => qr/^Foo/,
1007 );
1008
1009=head2 Selectively including and excluding fields in sources
1010
1011 #Reflect Foo and Baz in their entirety and exclude the field 'avatar' in the Bar ResultSource
1012 $reflector->reflect_schema
1013 (
1014 model_class => __PACKAGE__,
1015 schema_class => 'MyApp::Schema',
1016 sources => [qw/Foo Baz/,
1017 [ Bar => {attributes => [[-exclude => 'avatar']] } ],
1018 # or exclude by regex
1019 [ Bar => {attributes => [-exclude => qr/avatar/] } ],
1020 # or simply do not include it...
1021 [ Bar => {attributes => [qw/id name description/] } ],
1022 ],
1023 );
1024
1025=head1 ATTRIBUTES
1026
1027=head2 make_classes_immutable
1028
1029=head2 object_actions
1030
1031=head2 collection_actions
1032
1033=head2 default_object_actions
1034
1035=head2 default_collection_actions
1036
1037=head2 builtin_object_actions
1038
1039=head2 builtin_collection_actions
1040
1041=head1 METHODS
1042
1043=head2 new
1044
1045=head2 _all_object_actions
1046
1047=head2 _all_collection_actions
1048
1049=head2 dm_name_from_class_name
1050
1051=head2 dm_name_from_source_name
1052
1053=head2 class_name_from_source_name
1054
1055=head2 class_name_for_collection_of
1056
1057=head2 merge_hashes
1058
1059=head2 parse_reflect_rules
1060
1061=head2 merge_reflect_rules
1062
1063=head2 reflect_schema
1064
1065=head2 _compute_source_options
1066
1067=head2 add_source
1068
1069=head2 reflect_source
1070
1071=head2 reflect_source_collection
1072
1073=head2 reflect_source_object
1074
1075=head2 reflect_source_object_attribute
1076
1077=head2 parameters_for_source_object_attribute
1078
1079=head2 reflect_source_action
1080
1081=head2 parameters_for_source_object_action_attribute
1082
1083=head1 TODO
1084
1085Allow the reflector to dump the generated code out as files, eliminating the need to
1086reflect on startup every time. This will likely take quite a bit of work though. The
1087main work is already in place, but the grunt work is still left. At the moment there
1088is no closures that can't be dumped out as code with a little bit of work.
1089
1090=head1 AUTHORS
1091
1092See L<Reaction::Class> for authors.
1093
1094=head1 LICENSE
1095
1096See L<Reaction::Class> for the license.
1097
1098=cut
'Reaction' or the likes