1 package Reaction::InterfaceModel::Reflector::DBIC;
3 use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create';
4 use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::DeleteAll';
5 use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update';
6 use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete';
8 use aliased 'Reaction::InterfaceModel::Collection::Virtual::ResultSet';
9 use aliased 'Reaction::InterfaceModel::Object';
10 use aliased 'Reaction::InterfaceModel::Action';
18 has make_classes_immutable => (isa => "Bool", is => "rw", required => 1, default => sub{ 1 });
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);
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);
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);
32 implements _build_object_actions => as { {} };
33 implements _build_collection_actions => as { {} };
35 implements _build_default_object_actions => as { [ qw/Update Delete/ ] };
36 implements _build_default_collection_actions => as { [ qw/Create DeleteAll/ ] };
38 implements _build_builtin_object_actions => as {
40 Update => { name => 'Update', base => Update },
41 Delete => { name => 'Delete', base => Delete, attributes => [] },
45 implements _build_builtin_collection_actions => as {
47 Create => {name => 'Create', base => Create },
48 DeleteAll => {name => 'DeleteAll', base => DeleteAll, attributes => [] }
52 implements _all_object_actions => as {
54 return $self->merge_hashes
55 ($self->builtin_object_actions, $self->object_actions);
58 implements _all_collection_actions => as {
60 return $self->merge_hashes
61 ($self->builtin_collection_actions, $self->collection_actions);
64 implements dm_name_from_class_name => as {
65 my($self, $class) = @_;
66 confess("wrong arguments") unless $class;
68 $class = "_" . lc($class) . "_store";
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";
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;
86 implements class_name_for_collection_of => as {
87 my ($self, $object_class) = @_;
88 confess("wrong arguments") unless $object_class;
89 return "${object_class}::Collection";
92 implements merge_hashes => as {
93 my($self, $left, $right) = @_;
94 return Catalyst::Utils::merge_hashes($left, $right);
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';
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]));
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;
114 push(@include, $rule);
118 my $check_exclude = sub{
119 for my $rule (@exclude){
120 return 1 if(ref $rule eq 'Regexp' ? $_[0] =~ /$rule/ : $_[0] eq $rule);
125 @$haystack = grep { !$check_exclude->($_) } @$haystack;
126 $self->merge_reflect_rules(\@include, $needles, $haystack, $global_opts);
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;
141 } elsif( ref $rule eq 'ARRAY' ){
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);
150 implements reflect_schema => as {
151 my ($self, %opts) = @_;
152 my $base = delete $opts{base} || Object;
153 my $model = delete $opts{model_class};
154 my $schema = delete $opts{schema_class};
155 my $dm_name = delete $opts{domain_model_name};
156 my $dm_args = delete $opts{domain_model_args} || {};
157 $dm_name ||= $self->dm_name_from_class_name($schema);
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 );
164 my $meta = eval { Class::MOP::load_class($model); } ?
165 $model->meta : $base->meta->create($model, superclasses => [ $base ]);
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 ];
174 my $rules = delete $opts{sources};
177 } elsif( ref $rules eq 'Regexp'){
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;
185 my $sources = $self->parse_reflect_rules($rules, $haystack);
187 my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
188 $meta->make_mutable if $meta->is_immutable;
190 $meta->add_domain_model
191 ($dm_name, is => 'rw', isa => $schema, required => 1, %$dm_args);
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,
205 $meta->make_immutable if $make_immutable;
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};
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));
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) };
228 if($source_class && (!$schema || !$source_name)){
230 $schema = $source_class->result_source_instance->schema;
231 next OUTER if $schema && Class::MOP::load_class($schema);
234 $source_name = $source_class->result_source_instance->source_name;
235 next OUTER if $source_name;
238 my @haystack = $parent_dm ?
239 $parent->meta->find_attribute_by_name($parent_dm) : $parent->domain_models;
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;
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);
256 $parent_dm = $needle->name;
257 $source_class = $src_class;
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;
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}'");
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,
283 implements add_source => as {
284 my ($self, %opts) = @_;
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;
293 confess("model_class and source_name are required parameters")
294 unless $model && $source;
295 my $meta = $model->meta;
297 unless( $collection ){
298 my $object = $self->class_name_from_source_name($model, $source);
299 $collection = $self->class_name_for_collection_of($object);
303 $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
304 $reader = join('_', map lc, split(/::/, $reader)) . "_collection"; #XXX change to not use _collection ?
307 my @haystack = $meta->domain_models;
309 @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack;
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).")");
317 confess("Failed to automatically determine domain_model_name. No matches.");
327 predicate => "has_" . join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $name)),
328 domain_model => $dm_name,
329 orig_attr_name => $source,
331 $collection->new(_source_resultset => shift->$dm_name->resultset($source));
335 my $make_immutable = $meta->is_immutable;
336 $meta->make_mutable if $make_immutable;
337 my $attr = $meta->add_attribute($name, %attr_opts);
338 $meta->make_immutable if $make_immutable;
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)) };
348 my $obj_meta = $self->reflect_source_object(%opts);
349 my $col_meta = $self->reflect_source_collection
351 object_class => $obj_meta->name,
352 source_class => $opts{source_class},
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,
364 implements reflect_source_collection => as {
365 my ($self, %opts) = @_;
366 my $base = delete $opts{base} || ResultSet;
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};
372 confess('object_class and source_class are required parameters')
373 unless $object && $source;
374 $class ||= $self->class_name_for_collection_of($object);
376 Class::MOP::load_class( $base );
377 Class::MOP::load_class( $object );
378 my $meta = eval { Class::MOP::load_class($class) } ?
379 $class->meta : $base->meta->create( $class, superclasses => [ $base ]);
381 my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;;
382 $meta->make_mutable if $meta->is_immutable;
383 $meta->add_method(_build_member_type => sub{ $object } );
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 {
388 return { (target_model => $_[0]->_source_resultset), %{ $super->(@_) } };
390 $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
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;
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} || {});
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
420 $self->reflect_source_action(
422 object_class => $object,
423 source_class => $source,
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
432 return { %{ $super->(@_) },
433 ($_[1] eq $action ? (target_model => $_[0]->_source_resultset) : () ) };
435 $meta->add_around_method_modifier('_default_action_args_for', $act_args);
438 $meta->make_immutable if $make_immutable;
442 implements reflect_source_object => as {
443 my($self, %opts) = @_;
444 %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
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} || {};
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};
457 my $action_rules = delete $opts{actions};
458 my $attr_rules = delete $opts{attributes};
460 $class ||= $self->class_name_from_source_name($parent, $source_name);
462 Class::MOP::load_class($parent);
463 Class::MOP::load_class($schema) if $schema;
464 Class::MOP::load_class($source_class);
466 my $meta = eval { Class::MOP::load_class($class) } ?
467 $class->meta : $base->meta->create($class, superclasses => [ $base ]);
469 #create the domain model
470 $dm_name ||= $self->dm_name_from_source_name($source_name);
472 $dm_opts->{isa} = $source_class;
473 $dm_opts->{is} ||= 'rw';
474 $dm_opts->{required} ||= 1;
476 my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;;
477 $meta->make_mutable if $meta->is_immutable;
479 my $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts);
480 my $dm_reader = $dm_attr->get_read_method;
482 unless( $class->can('inflate_result') ){
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(@_));
488 $meta->add_method('inflate_result', $inflate_method);
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 Action, ChooseOne and ChooseMany need this shit
498 $meta->add_method('__ident_condition', sub {shift->$dm_reader->ident_condition} )
499 unless $class->can('__ident_condition');
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'));
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 {
509 confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
510 return { (target_model => $_[0]->$dm_reader), %{ $super->(@_) } };
512 $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
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 => ...]]
521 [ map { $_->name } $source_class->meta->compute_all_applicable_attributes ];
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;
534 my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
535 for my $attr_name (keys %$attributes){
536 $self->reflect_source_object_attribute(
538 source_class => $source_class,
539 parent_class => $parent,
540 attribute_name => $attr_name,
541 domain_model_name => $dm_name,
542 %{ $attributes->{$attr_name} || {}},
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;
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} || {});
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
574 $self->reflect_source_action(
576 object_class => $class,
577 source_class => $source_class,
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
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) : () ) };
590 $meta->add_around_method_modifier('_default_action_args_for', $act_args);
594 $meta->make_immutable if $make_immutable;
598 # needs class, attribute_name domain_model_name
599 implements reflect_source_object_attribute => as {
600 my ($self, %opts) = @_;
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" );
607 my $meta = $opts{class}->meta;
608 my $attr_opts = $self->parameters_for_source_object_attribute(%opts);
610 my $make_immutable = $meta->is_immutable;
611 $meta->make_mutable if $meta->is_immutable;
613 my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts);
615 $meta->make_immutable if $make_immutable;
619 # needs class, attribute_name domain_model_name
620 implements parameters_for_source_object_attribute => as {
621 my ($self, %opts) = @_;
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;
633 $source = $source_class->result_source_instance if $source_class;
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;
648 my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
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,
659 my $constraint_is_ArrayRef =
660 $from_attr->type_constraint->name eq 'ArrayRef' ||
661 $from_attr->type_constraint->is_subtype_of('ArrayRef');
663 if( my $rel_info = $source->relationship_info($attr_name) ){
664 my $rel_accessor = $rel_info->{attrs}->{accessor};
665 my $rel_moniker = $rel_info->{class}->result_source_instance->source_name;
667 if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
669 my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker);
670 #type constraint is a collection, and default builds it
671 $attr_opts{isa} = $self->class_name_for_collection_of($sm);
672 $attr_opts{default} = sub {
673 my $rs = shift->$dm_name->related_resultset($attr_name);
674 return $attr_opts{isa}->new(_source_resultset => $rs);
676 } elsif( $rel_accessor eq 'single') {
678 #type constraint is the foreign IM object, default inflates it
679 $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
680 $attr_opts{default} = sub {
682 ->find_related($attr_name, {},{result_class => $attr_opts{isa}});
685 } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
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";
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);
699 #proper collections will remove the result_class uglyness.
700 $attr_opts{default} = sub {
701 my $rs = shift->$dm_name->related_resultset($link_table)->related_resultset($mm_name);
702 return $attr_opts{isa}->new(_source_resultset => $rs);
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 };
714 implements reflect_source_action => as{
715 my($self, %opts) = @_;
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};
722 confess("name, object_class and source_class are required arguments")
723 unless $source && $name && $object;
725 my $attr_rules = delete $opts{attributes};
726 $class ||= $object->_default_action_class_for($name);
728 Class::MOP::load_class( $base );
729 Class::MOP::load_class( $object );
730 Class::MOP::load_class( $source );
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;
750 #print STDERR "${name}\t${class}\t${base}\n";
751 #print STDERR "\t${object}\t${source}\n";
752 #print STDERR "\t",@$attr_rules,"\n";
754 my $o_meta = $object->meta;
755 my $s_meta = $source->meta;
756 my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
759 my $meta = eval { Class::MOP::load_class($class) } ?
760 $class->meta : $base->meta->create($class, superclasses => [$base]);
761 my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
762 $meta->make_mutable if $meta->is_immutable;
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 confess("Unable to find attribute for '${s_attr_name}' via '${source}'")
770 unless defined $s_attr;
771 next unless $s_attr->get_write_method; #only rw attributes!
773 my $attr_params = $self->parameters_for_source_object_action_attribute
775 object_class => $object,
776 source_class => $source,
777 attribute_name => $attr_name
779 $meta->add_attribute( $attr_name => %$attr_params);
782 $meta->make_immutable if $make_immutable;
786 implements parameters_for_source_object_action_attribute => as {
787 my ($self, %opts) = @_;
789 my $object = delete $opts{object_class};
790 my $attr_name = delete $opts{attribute_name};
791 my $source_class = delete $opts{source_class};
792 confess("object_class and attribute_name are required parameters")
793 unless $attr_name && $object;
795 my $o_meta = $object->meta;
796 my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model;
797 $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
798 my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
800 confess("${attr_name} is not writeable and can not be reflected")
801 unless $from_attr->get_write_method;
805 isa => $from_attr->_isa_metadata,
806 required => $from_attr->is_required,
807 predicate => "has_${attr_name}",
810 if ($attr_opts{required}) {
811 $attr_opts{lazy} = 1;
812 $attr_opts{default} = $from_attr->has_default ?
813 $from_attr->default : sub{};
816 #test for relationships
817 my $constraint_is_ArrayRef =
818 $from_attr->type_constraint->name eq 'ArrayRef' ||
819 $from_attr->type_constraint->is_subtype_of('ArrayRef');
821 my $source = $source_class->result_source_instance;
822 if (my $rel_info = $source->relationship_info($attr_name)) {
823 my $rel_accessor = $rel_info->{attrs}->{accessor};
825 if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
826 confess "${attr_name} is a rw has_many, this won't work.";
827 } elsif( $rel_accessor eq 'single') {
828 $attr_opts{valid_values} = sub {
829 shift->target_model->result_source->related_source($attr_name)->resultset;
832 } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
834 my $link_table = "links_to_${mm_name}_list";
835 my ($hm_source, $far_side);
836 eval { $hm_source = $source->related_source($link_table); }
837 || confess "Can't find ${link_table} has_many for ${mm_name}_list";
838 eval { $far_side = $hm_source->related_source($mm_name); }
839 || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
840 ." traversing many-many for ${mm_name}_list";
842 $attr_opts{default} = sub { [] };
843 $attr_opts{valid_values} = sub {
844 shift->target_model->result_source->related_source($link_table)
845 ->related_source($mm_name)->resultset;
849 #print STDERR "\n" .$attr_name ." - ". $object . "\n";
850 #print STDERR Dumper(\%attr_opts);
858 #--------#---------#---------#---------#---------#---------#---------#---------#
863 Reaction::InterfaceModel::Reflector::DBIC -
864 Automatically Generate InterfaceModels from DBIx::Class models
868 The InterfaceModel reflectors are classes that are meant to aid you in easily
869 generating Reaction::InterfaceModel classes that represent their underlying
870 DBIx::Class domain models by introspecting your L<DBIx::Class::ResultSource>s
871 and creating a collection of L<Reaction::InterfaceModel::Object> and
872 L<Reaction::InterfaceModel::Collection> classes for you to use.
874 The default base class of all Object classes will be
875 L<Reaction::InterfaceModel::Object> and the default Collection type will be
876 L<Reaction::InterfaceModel::Collection::Virtual::ResultSet>.
878 Additionally, the reflector can create InterfaceModel actions that interact
879 with the supplied L<Reaction::UI::Controller::Collection::CRUD>, allowing you
880 to easily set up a highly customizable CRUD interface in minimal time.
882 At this time, supported collection actions consist of:
886 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::Create>
888 Creates a new item in the collection and underlying ResultSet.
890 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::DeleteAll>
892 Deletes all the items in a collection and it's underlying resultset using
897 And supported object actions are :
901 =item B<Update> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Update>
903 Updates an existing object.
905 =item B<Delete> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Delete>
907 Deletes an existing object.
913 package MyApp::IM::TestModel;
914 use base 'Reaction::InterfaceModel::Object';
916 use Reaction::InterfaceModel::Reflector::DBIC;
917 my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
920 $reflector->reflect_schema
922 model_class => __PACKAGE__,
923 schema_class => 'MyApp::Schema',
926 =head2 Selectively including and excluding sources
928 #reflect everything except for the FooBar and FooBaz classes
929 $reflector->reflect_schema
931 model_class => __PACKAGE__,
932 schema_class => 'MyApp::Schema',
933 sources => [-exclude => [qw/FooBar FooBaz/] ],
935 sources => [-exclude => qr/(?:FooBar|FooBaz)/,
937 sources => [-exclude => [qr/FooBar/, qr/FooBaz/],
940 #reflect only the Foo family of sources
941 $reflector->reflect_schema
943 model_class => __PACKAGE__,
944 schema_class => 'MyApp::Schema',
948 =head2 Selectively including and excluding fields in sources
950 #Reflect Foo and Baz in their entirety and exclude the field 'avatar' in the Bar ResultSource
951 $reflector->reflect_schema
953 model_class => __PACKAGE__,
954 schema_class => 'MyApp::Schema',
955 sources => [qw/Foo Baz/,
956 [ Bar => {attributes => [[-exclude => 'avatar']] } ],
957 # or exclude by regex
958 [ Bar => {attributes => [-exclude => qr/avatar/] } ],
959 # or simply do not include it...
960 [ Bar => {attributes => [qw/id name description/] } ],
966 =head2 make_classes_immutable
968 =head2 object_actions
970 =head2 collection_actions
972 =head2 default_object_actions
974 =head2 default_collection_actions
976 =head2 builtin_object_actions
978 =head2 builtin_collection_actions
984 =head2 _all_object_actions
986 =head2 _all_collection_actions
988 =head2 dm_name_from_class_name
990 =head2 dm_name_from_source_name
992 =head2 class_name_from_source_name
994 =head2 class_name_for_collection_of
998 =head2 parse_reflect_rules
1000 =head2 merge_reflect_rules
1002 =head2 reflect_schema
1004 =head2 _compute_source_options
1008 =head2 reflect_source
1010 =head2 reflect_source_collection
1012 =head2 reflect_source_object
1014 =head2 reflect_source_object_attribute
1016 =head2 parameters_for_source_object_attribute
1018 =head2 reflect_source_action
1020 =head2 parameters_for_source_object_action_attribute
1024 Allow the reflector to dump the generated code out as files, eliminating the need to
1025 reflect on startup every time. This will likely take quite a bit of work though. The
1026 main work is already in place, but the grunt work is still left. At the moment there
1027 is no closures that can't be dumped out as code with a little bit of work.
1031 See L<Reaction::Class> for authors.
1035 See L<Reaction::Class> for the license.