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