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