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