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