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