lib/Reaction/InterfaceModel/Reflector/DBIC.pm

   1 package Reaction::InterfaceModel::Reflector::DBIC;
   2
   3 use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create';
   4 use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update';
   5 use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete';
   6
   7 use aliased 'Reaction::InterfaceModel::Collection::Virtual::ResultSet';
   8 use aliased 'Reaction::InterfaceModel::Object';
   9 use aliased 'Reaction::InterfaceModel::Action';
  10 use Reaction::Class;
  11 use Class::MOP;
  12
  13 use Catalyst::Utils;
  14
  15 class DBIC, which {
  16
  17   #user defined actions and prototypes
  18   has object_actions     => (isa => "HashRef", is => "rw", lazy_build => 1);
  19   has collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1);
  20
  21   #which actions to create by default
  22   has default_object_actions     => (isa => "ArrayRef", is => "rw", lazy_build => 1);
  23   has default_collection_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1);
  24
  25   #builtin actions and prototypes
  26   has builtin_object_actions     => (isa => "HashRef", is => "rw", lazy_build => 1);
  27   has builtin_collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1);
  28
  29   implements build_object_actions     => as { {} };
  30   implements build_collection_actions => as { {} };
  31
  32   implements build_default_object_actions     => as { [ qw/Update Delete/ ] };
  33   implements build_default_collection_actions => as { [ 'Create' ] };
  34
  35   implements build_builtin_object_actions => as {
  36     {
  37       Update => { base => Update },
  38       Delete => { base => Delete, attributes => [] },
  39     };
  40   };
  41
  42   implements build_builtin_collection_actions => as {
  43     { Create => {base => Create } };
  44   };
  45
  46   implements _all_object_actions => as {
  47     my $self = shift;
  48     return $self->merge_hashes
  49       ($self->builtin_object_actions, $self->object_actions);
  50   };
  51
  52   implements _all_collection_actions => as {
  53     my $self = shift;
  54     return $self->merge_hashes
  55       ($self->builtin_collection_actions, $self->collection_actions);
  56   };
  57
  58   implements dm_name_from_class_name => as {
  59     my($self, $class) = @_;
  60     confess("wrong arguments") unless $class;
  61     $class =~ s/::/_/g;
  62     $class = "_" . lc($class) . "_store";
  63     return $class;
  64   };
  65
  66   implements dm_name_from_source_name => as {
  67     my($self, $source) = @_;
  68     confess("wrong arguments") unless $source;
  69     $source =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
  70     $source = "_" . lc($source) . "_store";
  71     return $source;
  72   };
  73
  74   implements class_name_from_source_name => as {
  75     my ($self, $model_class, $source_name) = @_;
  76     confess("wrong arguments") unless $model_class && $source_name;
  77     return join "::", $model_class, $source_name;
  78   };
  79
  80   implements class_name_for_collection_of => as {
  81     my ($self, $object_class) = @_;
  82     confess("wrong arguments") unless $object_class;
  83     return "${object_class}::Collection";
  84   };
  85
  86   implements merge_hashes => as {
  87     my($self, $left, $right) = @_;
  88     return Catalyst::Utils::merge_hashes($left, $right);
  89   };
  90
  91   implements parse_reflect_rules => as {
  92     my ($self, $rules, $haystack) = @_;
  93     confess('$rules must be an array reference')    unless ref $rules    eq 'ARRAY';
  94     confess('$haystack must be an array reference') unless ref $haystack eq 'ARRAY';
  95
  96     my $needles = {};
  97     my (@exclude, @include, $global_opts);
  98     if(@$rules == 2 && $rules->[0] eq '-exclude'){
  99       push(@exclude, (ref $rules->[1] eq 'ARRAY' ? @{$rules->[1]} : $rules->[1]));
 100     } else {
 101       for my $rule ( @$rules ){
 102         if (ref $rule eq 'ARRAY' && $rule->[0] eq '-exclude'){
 103           push(@exclude, (ref $rule->[1] eq 'ARRAY' ? @{$rule->[1]} : $rule->[1]));
 104         } elsif( ref $rule eq 'HASH' ){
 105           $global_opts = ref $global_opts eq 'HASH' ?
 106             $self->merge_hashes($global_opts, $rule) : $rule;
 107         } else {
 108           push(@include, $rule);
 109         }
 110       }
 111     }
 112     my $check_exclude = sub{
 113       for my $rule (@exclude){
 114         return 1 if(ref $rule eq 'Regexp' ? $_[0] =~ /$rule/ : $_[0] eq $rule);
 115       }
 116       return;
 117     };
 118
 119     @$haystack = grep { !$check_exclude->($_) } @$haystack;
 120     $self->merge_reflect_rules(\@include, $needles, $haystack, $global_opts);
 121     return $needles;
 122   };
 123
 124   implements merge_reflect_rules => as {
 125     my ($self, $rules, $needles, $haystack, $local_opts) = @_;
 126     for my $rule ( @$rules ){
 127       if(!ref $rule && ( grep {$rule eq $_} @$haystack ) ){
 128         $needles->{$rule} = defined $needles->{$rule} ?
 129           $self->merge_hashes($needles->{$rule}, $local_opts) : $local_opts;
 130       } elsif( ref $rule eq 'Regexp' ){
 131         for my $match ( grep { /$rule/ } @$haystack ){
 132           $needles->{$match} = defined $needles->{$match} ?
 133             $self->merge_hashes($needles->{$match}, $local_opts) : $local_opts;
 134         }
 135       } elsif( ref $rule eq 'ARRAY' ){
 136         my $opts;
 137         $opts = pop(@$rule) if @$rule > 1 and ref $rule->[$#$rule] eq 'HASH';
 138         $opts = $self->merge_hashes($local_opts, $opts) if defined $local_opts;
 139         $self->merge_reflect_rules($rule, $needles, $haystack, $opts);
 140       }
 141     }
 142   };
 143
 144   implements reflect_schema => as {
 145     my ($self, %opts) = @_;
 146     my $base    = delete $opts{base} || Object;
 147     my $model   = delete $opts{model_class};
 148     my $schema  = delete $opts{schema_class};
 149     my $dm_name = delete $opts{domain_model_name};
 150     my $dm_args = delete $opts{domain_model_args} || {};
 151     $dm_name ||= $self->dm_name_from_class_name($schema);
 152
 153     #load all necessary classes
 154     confess("model_class and schema_class are required parameters")
 155       unless($model && $schema);
 156     Class::MOP::load_class( $base );
 157     Class::MOP::load_class( $schema );
 158     my $meta = eval {Class::MOP::load_class($model); } ?
 159       $model->meta : $base->meta->create($model, superclasses => [ $base ]);
 160
 161     # sources => undef,              #default to qr/./
 162     # sources => [],                 #default to nothing
 163     # sources => qr//,               #DWIM, treated as [qr//]
 164     # sources => [{...}]             #DWIM, treat as [qr/./, {...} ]
 165     # sources => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
 166     my $haystack = [ $schema->sources ];
 167
 168     my $rules    = delete $opts{sources};
 169     if(!defined $rules){
 170       $rules = [qr/./];
 171     } elsif( ref $rules eq 'Regexp'){
 172       $rules = [ $rules ];
 173     } elsif( ref $rules eq 'ARRAY' && @$rules){
 174       #don't add a qr/./ rule if we have at least one match rule
 175       push(@$rules, qr/./) unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 176                                           || !ref $_  || ref $_ eq 'Regexp'} @$rules;
 177     }
 178
 179     my $sources = $self->parse_reflect_rules($rules, $haystack);
 180
 181     my $make_immutable = $meta->is_immutable;
 182     $meta->make_mutable if $meta->is_immutable;
 183
 184     $meta->add_domain_model
 185       ($dm_name, is => 'rw', isa => $schema, required => 1, %$dm_args);
 186
 187     for my $source_name (keys %$sources){
 188       my $source_opts = $sources->{$source_name} || {};
 189       $self->reflect_source(
 190                             source_name  => $source_name,
 191                             parent_class => $model,
 192                             schema_class => $schema,
 193                             source_class => $schema->class($source_name),
 194                             parent_domain_model_name => $dm_name,
 195                             %$source_opts
 196                            );
 197     }
 198
 199     $meta->make_immutable if $make_immutable;
 200     return $meta;
 201   };
 202
 203   implements _compute_source_options => as {
 204     my ($self, %opts) = @_;
 205     my $schema       = delete $opts{schema_class};
 206     my $source_name  = delete $opts{source_name};
 207     my $source_class = delete $opts{source_class};
 208     my $parent       = delete $opts{parent_class};
 209     my $parent_dm    = delete $opts{parent_domain_model_name};
 210
 211     #this is the part where I hate my life for promissing all sorts of DWIMery
 212     confess("parent_class and source_name or source_class are required parameters")
 213       unless($parent && ($source_name || $source_class));
 214
 215   OUTER: until( $schema && $source_name && $source_class && $parent_dm ){
 216       if( $schema && !$source_name){
 217         next OUTER if $source_name = $source_class->result_source_instance->source_name;
 218       } elsif( $schema && !$source_class){
 219         next OUTER if $source_class = eval { $schema->class($source_name) };
 220       }
 221
 222       if($source_class && (!$schema || !$source_name)){
 223         if(!$schema){
 224           $schema = $source_class->result_source_instance->schema;
 225           next OUTER if $schema && Class::MOP::load_class($schema);
 226         }
 227         if(!$source_name){
 228           $source_name = $source_class->result_source_instance->source_name;
 229           next OUTER if $source_name;
 230         }
 231       }
 232       my @haystack = $parent_dm ?
 233         $parent->meta->find_attribute_by_name($parent_dm) : $parent->domain_models;
 234
 235       #there's a lot of guessing going on, but it should work fine on most cases
 236     INNER: for my $needle (@haystack){
 237         my $isa = $needle->_isa_metadata;
 238         next INNER unless Class::MOP::load_class( $isa->_isa_metadata );
 239         next INNER unless $isa->isa('DBIx::Class::Schema');
 240         if(!$parent_dm && $schema && $isa eq $schema){
 241           $parent_dm = $needle->name;
 242           next OUTER;
 243         }
 244
 245         if( $source_name ){
 246           my $src_class = eval{ $isa->class($source_name) };
 247           next INNER unless $src_class;
 248           next INNER if($source_class && $source_class ne $src_class);
 249           $schema = $isa;
 250           $parent_dm = $needle->name;
 251           $source_class = $src_class;
 252           next OUTER;
 253         }
 254       }
 255
 256       #do we even need to go this far?
 257       if( !$parent_dm && $schema ){
 258         my $tentative = $self->dm_name_from_class_name($schema);
 259         $parent_dm = $tentative if grep{$_->name eq $tentative} @haystack;
 260       }
 261
 262       confess("Could not determine options automatically from: schema " .
 263               "'${schema}', source_name '${source_name}', source_class " .
 264               "'${source_class}', parent_domain_model_name '${parent_dm}'");
 265     }
 266
 267     return {
 268             source_name  => $source_name,
 269             schema_class => $schema,
 270             source_class => $source_class,
 271             parent_class => $parent,
 272             parent_domain_model_name => $parent_dm,
 273            };
 274   };
 275
 276
 277   implements add_source => as {
 278     my ($self, %opts) = @_;
 279
 280     my $model      = delete $opts{model_class};
 281     my $reader     = delete $opts{reader};
 282     my $source     = delete $opts{source_name};
 283     my $dm_name    = delete $opts{domain_model_name};
 284     my $collection = delete $opts{collection_class};
 285     my $name       = delete $opts{attribute_name} || $source;
 286
 287     confess("model_class and source_name are required parameters")
 288       unless $model && $source;
 289     my $meta = $model->meta;
 290
 291     unless( $collection ){
 292       my $object = $self->class_name_from_source_name($model, $source);
 293       $collection = $self->class_name_for_collection_of($object);
 294     }
 295     unless( $reader ){
 296       $reader = $source;
 297       $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
 298       $reader = lc($reader) . "_collection";
 299     }
 300     unless( $dm_name ){
 301       my @haystack = $meta->domain_models;
 302       if( @haystack > 1 ){
 303         @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack;
 304       }
 305       if(@haystack == 1){
 306         $dm_name = $haystack[0]->name;
 307       } elsif(@haystack > 1){
 308         confess("Failed to automatically determine domain_model_name. More than one " .
 309                 "possible match (".(join ", ", map{"'".$_->name."'"} @haystack).")");
 310       } else {
 311         confess("Failed to automatically determine domain_model_name. No matches.");
 312       }
 313     }
 314
 315     my %attr_opts =
 316       (
 317        lazy           => 1,
 318        required       => 1,
 319        isa            => $collection,
 320        reader         => $reader,
 321        predicate      => "has_${name}",
 322        domain_model   => $dm_name,
 323        orig_attr_name => $source,
 324        default        => sub {
 325          $collection->new(_source_resultset => shift->$dm_name->resultset($source));
 326        },
 327       );
 328
 329     my $make_immutable = $meta->is_immutable;
 330     $meta->make_mutable   if $make_immutable;
 331     my $attr = $meta->add_attribute($name, %attr_opts);
 332     $meta->make_immutable if $make_immutable;
 333
 334     return $attr;
 335   };
 336
 337   implements reflect_source => as {
 338     my ($self, %opts) = @_;
 339     my $collection  = delete $opts{collection} || {};
 340     %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
 341
 342     my $obj_meta = $self->reflect_source_object(%opts);
 343     my $col_meta = $self->reflect_source_collection
 344       (
 345        object_class => $obj_meta->name,
 346        source_class => $opts{source_class},
 347        %$collection
 348       );
 349
 350     $self->add_source(
 351                       model_class       => $opts{parent_class},
 352                       source_name       => $opts{source_name},
 353                       domain_model_name => $opts{parent_domain_model_name},
 354                       collection_class  => $col_meta->name,
 355                      );
 356   };
 357
 358   implements reflect_source_collection => as {
 359     my ($self, %opts) = @_;
 360     my $base    = delete $opts{base} || ResultSet;
 361     my $class   = delete $opts{class};
 362     my $object  = delete $opts{object_class};
 363     my $source  = delete $opts{source_class};
 364     my $action_rules = delete $opts{actions};
 365
 366     confess('object_class and source_class are required parameters')
 367       unless $object && $source;
 368     $class ||= $self->class_name_for_collection_of($object);
 369
 370     Class::MOP::load_class( $base );
 371     Class::MOP::load_class( $object );
 372     my $meta = eval { Class::MOP::load_class($class) } ?
 373       $class->meta : $base->meta->create( $class, superclasses => [ $base ]);
 374
 375     my $make_immutable = $meta->is_immutable;
 376     $meta->make_mutable if $meta->is_immutable;
 377     $meta->add_method(_build_im_class => sub{ $object } );
 378     #XXX as a default pass the domain model as a target_model until i come up with something
 379     #better through the coercion method
 380     my $def_act_args = sub {
 381       my $super = shift;
 382       return { (target_model => $_[0]->_source_resultset), %{ $super->(@_) } };
 383     };
 384     $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
 385
 386
 387     {
 388       my $all_actions = $self->_all_collection_actions;
 389       my $action_haystack = [keys %$all_actions];
 390       if(!defined $action_rules){
 391         $action_rules = $self->default_collection_actions;
 392       } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){
 393         $action_rules = [ $action_rules ];
 394       } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){
 395         #don't add a qr/./ rule if we have at least one match rule
 396         push(@$action_rules, qr/./)
 397           unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 398                          || !ref $_  || ref $_ eq 'Regexp'} @$action_rules;
 399       }
 400
 401       # XXX this is kind of a dirty hack to support custom actions that are not
 402       # previously defined and still be able to use the parse_reflect_rules mechanism
 403       my @custom_actions = grep {!exists $all_actions->{$_}}
 404         map{ $_->[0] } grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules;
 405       push(@$action_haystack, @custom_actions);
 406       my $actions = $self->parse_reflect_rules($action_rules, $action_haystack);
 407       for my $action (keys %$actions){
 408         my $action_opts = $self->merge_hashes
 409           ($all_actions->{$action} || {}, $actions->{$action} || {});
 410         $self->reflect_source_action(
 411                                      name         => $action,
 412                                      object_class => $object,
 413                                      source_class => $source,
 414                                      %$action_opts,
 415                                     );
 416
 417         # XXX i will move this to use the coercion method soon. this will be
 418         #  GoodEnough until then. I still need to think a little about the type coercion
 419         #  thing so i don't make a mess of it
 420         my $act_args = sub {   #override target model for this action
 421           my $super = shift;
 422           return { %{ $super->(@_) },
 423                    ($_[1] eq $action ? (target_model => $_[0]->_source_resultset) : () ) };
 424         };
 425         $meta->add_around_method_modifier('_default_action_args_for', $act_args);
 426       }
 427     }
 428     $meta->make_immutable if $make_immutable;
 429     return $meta;
 430   };
 431
 432   implements reflect_source_object => as {
 433     my($self, %opts) = @_;
 434     %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
 435
 436     my $base         = delete $opts{base}  || Object;
 437     my $class        = delete $opts{class};
 438     my $dm_name      = delete $opts{domain_model_name};
 439     my $dm_opts      = delete $opts{domain_model_args} || {};
 440
 441     my $source_name  = delete $opts{source_name};
 442     my $schema       = delete $opts{schema_class};
 443     my $source_class = delete $opts{source_class};
 444     my $parent       = delete $opts{parent_class};
 445     my $parent_dm    = delete $opts{parent_domain_model_name};
 446
 447     my $action_rules = delete $opts{actions};
 448     my $attr_rules   = delete $opts{attributes};
 449
 450     $class ||= $self->class_name_from_source_name($parent, $source_name);
 451
 452     Class::MOP::load_class($parent);
 453     Class::MOP::load_class($schema) if $schema;
 454     Class::MOP::load_class($source_class);
 455
 456     my $meta = eval { Class::MOP::load_class($class) } ?
 457       $class->meta : $base->meta->create($class, superclasses => [ $base ]);
 458
 459     #create the domain model
 460     $dm_name ||= $self->dm_name_from_source_name($source_name);
 461
 462     $dm_opts->{isa}        = $source_class;
 463     $dm_opts->{is}       ||= 'rw';
 464     $dm_opts->{required} ||= 1;
 465
 466     my $make_immutable = $meta->is_immutable;
 467     $meta->make_mutable if $meta->is_immutable;
 468
 469     my $dm_attr   = $meta->add_domain_model($dm_name, %$dm_opts);
 470     my $dm_reader = $dm_attr->get_read_method;
 471
 472     unless( $class->can('inflate_result') ){
 473       my $inflate_method = sub {
 474         my $class = shift; my ($src) = @_;
 475         $src = $src->resolve if $src->isa('DBIx::Class::ResultSourceHandle');
 476         $class->new($dm_name, $src->result_class->inflate_result(@_));
 477       };
 478       $meta->add_method('inflate_result', $inflate_method);
 479     }
 480
 481     #XXX this is here to allow action prototypes to work with ListView
 482     # maybe Collections hsould have this kind of thing too to allow you to reconstruct them?
 483     #i like the possibility to be honest... as aset of key/value pairs they could be URId
 484     #XXX move to using 'handles' for this?
 485     $meta->add_method('__id', sub {shift->$dm_reader->id} )
 486       unless $class->can('__id');
 487     #XXX this one is for ActionForm, ChooseOne and ChooseMany need this shit
 488     $meta->add_method('__ident_condition', sub {shift->$dm_reader->ident_condition} )
 489       unless $class->can('__ident_condition');
 490
 491     #XXX this is just a disaster
 492     $meta->add_method('display_name', sub {shift->$dm_reader->display_name} )
 493       if( $source_class->can('display_name') && !$class->can('display_name'));
 494
 495     #XXX as a default pass the domain model as a target_model until i come up with something
 496     #better through the coercion method
 497     my $def_act_args = sub {
 498       my $super = shift;
 499       confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
 500       return { (target_model => $_[0]->$dm_reader), %{ $super->(@_) } };
 501     };
 502     $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
 503
 504     {
 505       # attributes => undef,              #default to qr/./
 506       # attributes => [],                 #default to nothing
 507       # attributes => qr//,               #DWIM, treated as [qr//]
 508       # attributes => [{...}]             #DWIM, treat as [qr/./, {...} ]
 509       # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
 510       my $attr_haystack =
 511         [ map { $_->name } $source_class->meta->compute_all_applicable_attributes ];
 512
 513       if(!defined $attr_rules){
 514         $attr_rules = [qr/./];
 515       } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
 516         $attr_rules = [ $attr_rules ];
 517       } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
 518         #don't add a qr/./ rule if we have at least one match rule
 519         push(@$attr_rules, qr/./) unless
 520           grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 521                   || !ref $_  || ref $_ eq 'Regexp'} @$attr_rules;
 522       }
 523
 524       my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
 525       for my $attr_name (keys %$attributes){
 526         $self->reflect_source_object_attribute(
 527                                                class             => $class,
 528                                                source_class      => $source_class,
 529                                                parent_class      => $parent,
 530                                                attribute_name    => $attr_name,
 531                                                domain_model_name => $dm_name,
 532                                                %{ $attributes->{$attr_name} || {}},
 533                                               );
 534       }
 535     }
 536
 537     {
 538       my $all_actions = $self->_all_object_actions;
 539       my $action_haystack = [keys %$all_actions];
 540       if(!defined $action_rules){
 541         $action_rules = $self->default_object_actions;
 542       } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){
 543         $action_rules = [ $action_rules ];
 544       } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){
 545         #don't add a qr/./ rule if we have at least one match rule
 546         push(@$action_rules, qr/./)
 547           unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 548                          || !ref $_  || ref $_ eq 'Regexp'} @$action_rules;
 549       }
 550
 551       # XXX this is kind of a dirty hack to support custom actions that are not
 552       # previously defined and still be able to use the parse_reflect_rules mechanism
 553       my @custom_actions = grep {!exists $all_actions->{$_}} map{ $_->[0] }
 554         grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules;
 555       push(@$action_haystack, @custom_actions);
 556       my $actions = $self->parse_reflect_rules($action_rules, $action_haystack);
 557       for my $action (keys %$actions){
 558         my $action_opts = $self->merge_hashes
 559           ($all_actions->{$action} || {}, $actions->{$action} || {});
 560         $self->reflect_source_action(
 561                                      name         => $action,
 562                                      object_class => $class,
 563                                      source_class => $source_class,
 564                                      %$action_opts,
 565                                     );
 566
 567         # XXX i will move this to use the coercion method soon. this will be
 568         #  GoodEnough until then. I still need to think a little about the type coercion
 569         #  thing so i don't make a mess of it
 570         my $act_args = sub {   #override target model for this action
 571           my $super = shift;
 572           confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
 573           return { %{ $super->(@_) },
 574                    ($_[1] eq $action ? (target_model => $_[0]->$dm_reader) : () ) };
 575         };
 576         $meta->add_around_method_modifier('_default_action_args_for', $act_args);
 577       }
 578     }
 579
 580     $meta->make_immutable if $make_immutable;
 581     return $meta;
 582   };
 583
 584   # needs class, attribute_name domain_model_name
 585   implements reflect_source_object_attribute => as {
 586     my ($self, %opts) = @_;
 587     unless( $opts{attribute_name} && $opts{class} && $opts{parent_class}
 588             && ( $opts{source_class} || $opts{domain_model_name} ) ){
 589       confess( "Error: class, parent_class, attribute_name, and either " .
 590                "domain_model_name or source_class are required parameters" );
 591     }
 592
 593     my $meta =  $opts{class}->meta;
 594     my $attr_opts = $self->parameters_for_source_object_attribute(%opts);
 595
 596     my $make_immutable = $meta->is_immutable;
 597     $meta->make_mutable if $meta->is_immutable;
 598
 599     my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts);
 600
 601     $meta->make_immutable if $make_immutable;
 602     return $attr;
 603   };
 604
 605   # needs class, attribute_name domain_model_name
 606   implements parameters_for_source_object_attribute => as {
 607     my ($self, %opts) = @_;
 608
 609     my $class        = delete $opts{class};
 610     my $attr_name    = delete $opts{attribute_name};
 611     my $dm_name      = delete $opts{domain_model_name};
 612     my $source_class = delete $opts{source_class};
 613     my $parent_class = delete $opts{parent_class};
 614     confess("parent_class is a required argument") unless $parent_class;
 615     confess("You must supply at least one of domain_model_name and source_class")
 616       unless $dm_name || $source_class;
 617
 618     my $source;
 619     $source = $source_class->result_source_instance if $source_class;
 620     #puke! dwimery
 621     if( !$source_class ){
 622       my $dm = $class->meta->find_attribute_by_name($dm_name);
 623       $source_class = $dm->_isa_metadata;
 624       $source = $source_class->result_source_instance;
 625     } elsif( !$dm_name ){
 626       ($dm_name) = map{$_->name} grep{$_->_isa_metadata eq $source_class}
 627         $class->meta->domain_models;
 628       if( !$dm_name ){   #last resort guess
 629         my $tentative = $self->dm_name_from_source_name($source->source_name);
 630         ($dm_name) = $tentative if grep{$_->name eq $tentative} $class->domain_models;
 631       }
 632     }
 633
 634     my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
 635
 636     #default options. lazy build but no outsider method
 637     my %attr_opts = ( is => 'ro', lazy => 1, required => 1,
 638                       clearer   => "_clear_${attr_name}",
 639                       predicate => "has_${attr_name}",
 640                       domain_model   => $dm_name,
 641                       orig_attr_name => $attr_name,
 642                     );
 643
 644     #m2m / has_many
 645     my $constraint_is_ArrayRef =
 646       $from_attr->type_constraint->name eq 'ArrayRef' ||
 647         $from_attr->type_constraint->is_subtype_of('ArrayRef');
 648
 649     if( my $rel_info = $source->relationship_info($attr_name) ){
 650       my $rel_accessor = $rel_info->{attrs}->{accessor};
 651       my $rel_moniker  = $rel_info->{class}->result_source_instance->source_name;
 652
 653       if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 654         #has_many
 655         my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker);
 656         #type constraint is a collection, and default builds it
 657         $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 658         $attr_opts{default} = sub {
 659           my $rs = shift->$dm_name->related_resultset($attr_name);
 660           return $attr_opts{isa}->new(_source_resultset => $rs);
 661         };
 662       } elsif( $rel_accessor eq 'single') {
 663         #belongs_to
 664         #type constraint is the foreign IM object, default inflates it
 665         $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
 666         $attr_opts{default} = sub {
 667           shift->$dm_name
 668             ->find_related($attr_name, {},{result_class => $attr_opts{isa}});
 669         };
 670       }
 671     } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
 672       #m2m magic
 673       my $mm_name = $1;
 674       my $link_table = "links_to_${mm_name}_list";
 675       my ($hm_source, $far_side);
 676       eval { $hm_source = $source->related_source($link_table); }
 677         || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 678       eval { $far_side = $hm_source->related_source($mm_name); }
 679         || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 680           ." traversing many-many for ${mm_name}_list";
 681
 682       my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name);
 683       $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 684
 685       #proper collections will remove the result_class uglyness.
 686       $attr_opts{default} = sub {
 687         my $rs = shift->$dm_name->result_source->related_source($link_table)
 688           ->related_source($mm_name)->resultset;
 689         return $attr_opts{isa}->new(_source_resultset => $rs);
 690       };
 691     } else {
 692       #no rel
 693       my $reader = $from_attr->get_read_method;
 694       $attr_opts{isa} = $from_attr->_isa_metadata;
 695       $attr_opts{default} = sub{ shift->$dm_name->$reader };
 696     }
 697     return \%attr_opts;
 698   };
 699
 700
 701   implements reflect_source_action => as{
 702     my($self, %opts) = @_;
 703     my $name   = delete $opts{name};
 704     my $class  = delete $opts{class};
 705     my $base   = delete $opts{base} || Action;
 706     my $object = delete $opts{object_class};
 707     my $source = delete $opts{source_class};
 708
 709     confess("name, object_class and source_class are required arguments")
 710       unless $source && $name && $object;
 711
 712     my $attr_rules = delete $opts{attributes};
 713     $class ||= $object->_default_action_class_for($name);
 714
 715     Class::MOP::load_class( $base   );
 716     Class::MOP::load_class( $object );
 717     Class::MOP::load_class( $source );
 718
 719     #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n";
 720     # attributes => undef,              #default to qr/./
 721     # attributes => [],                 #default to nothing
 722     # attributes => qr//,               #DWIM, treated as [qr//]
 723     # attributes => [{...}]             #DWIM, treat as [qr/./, {...} ]
 724     # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
 725     my $attr_haystack = [ map {$_->name} $object->meta->parameter_attributes ];
 726     if(!defined $attr_rules){
 727       $attr_rules = [qr/./];
 728     } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
 729       $attr_rules = [ $attr_rules ];
 730     } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
 731       #don't add a qr/./ rule if we have at least one match rule
 732       push(@$attr_rules, qr/./) unless
 733         grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 734                 || !ref $_  || ref $_ eq 'Regexp'} @$attr_rules;
 735     }
 736
 737     #print STDERR "${name}\t${class}\t${base}\n";
 738     #print STDERR "\t${object}\t${source}\n";
 739     #print STDERR "\t",@$attr_rules,"\n";
 740
 741     my $o_meta = $object->meta;
 742     my $s_meta = $source->meta;
 743     my $attributes  = $self->parse_reflect_rules($attr_rules, $attr_haystack);
 744
 745     #create the class
 746     my $meta = eval { Class::MOP::load_class($class) } ?
 747       $class->meta : $base->meta->create($class, superclasses => [$base]);
 748     my $make_immutable = $meta->is_immutable;
 749     $meta->make_mutable if $meta->is_immutable;
 750
 751     for my $attr_name (keys %$attributes){
 752       my $attr_opts   = $attributes->{$attr_name} || {};
 753       my $o_attr      = $o_meta->find_attribute_by_name($attr_name);
 754       my $s_attr_name = $o_attr->orig_attr_name || $attr_name;
 755       my $s_attr      = $s_meta->find_attribute_by_name($s_attr_name);
 756       next unless $s_attr->get_write_method; #only rw attributes!
 757
 758       my $attr_params = $self->parameters_for_source_object_action_attribute
 759         (
 760          object_class   => $object,
 761          source_class   => $source,
 762          attribute_name => $attr_name
 763         );
 764       $meta->add_attribute( $attr_name => %$attr_params);
 765     }
 766
 767     $meta->make_immutable if $make_immutable;
 768     return $meta;
 769   };
 770
 771   implements parameters_for_source_object_action_attribute => as {
 772     my ($self, %opts) = @_;
 773
 774     my $object       = delete $opts{object_class};
 775     my $attr_name    = delete $opts{attribute_name};
 776     my $source_class = delete $opts{source_class};
 777     confess("object_class and attribute_name are required parameters")
 778       unless $attr_name && $object;
 779
 780     my $o_meta  = $object->meta;
 781     my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model;
 782     $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
 783     my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
 784
 785     confess("${attr_name} is not writeable and can not be reflected")
 786       unless $from_attr->get_write_method;
 787
 788     my %attr_opts = (
 789                      is        => 'rw',
 790                      isa       => $from_attr->_isa_metadata,
 791                      required  => $from_attr->is_required,
 792                      predicate => "has_${attr_name}",
 793                     );
 794
 795     if ($attr_opts{required}) {
 796       $attr_opts{lazy} = 1;
 797       $attr_opts{default} = $from_attr->has_default ? $from_attr->default :
 798         sub{confess("${attr_name} must be provided before calling reader")};
 799     }
 800
 801     #test for relationships
 802     my $constraint_is_ArrayRef =
 803       $from_attr->type_constraint->name eq 'ArrayRef' ||
 804         $from_attr->type_constraint->is_subtype_of('ArrayRef');
 805
 806     my $source = $source_class->result_source_instance;
 807     if (my $rel_info = $source->relationship_info($attr_name)) {
 808       my $rel_accessor = $rel_info->{attrs}->{accessor};
 809
 810       if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 811         confess "${attr_name} is a rw has_many, this won't work.";
 812       } elsif( $rel_accessor eq 'single') {
 813         $attr_opts{valid_values} = sub {
 814           shift->target_model->result_source->related_source($attr_name)->resultset;
 815         };
 816       }
 817     } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
 818       my $mm_name = $1;
 819       my $link_table = "links_to_${mm_name}_list";
 820       my ($hm_source, $far_side);
 821       eval { $hm_source = $source->related_source($link_table); }
 822         || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 823       eval { $far_side = $hm_source->related_source($mm_name); }
 824         || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 825           ." traversing many-many for ${mm_name}_list";
 826
 827       $attr_opts{default} = sub { [] };
 828       $attr_opts{valid_values} = sub {
 829         shift->target_model->result_source->related_source($link_table)
 830           ->related_source($mm_name)->resultset;
 831       };
 832     }
 833     #use Data::Dumper;
 834     #print STDERR Dumper(\%attr_opts);
 835     return \%attr_opts;
 836   };
 837
 838 };
 839
 840 1;