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 = join('_', map lc, split(/::/, $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_" . join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $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;
 855
 856 #--------#---------#---------#---------#---------#---------#---------#---------#
 857 __END__;
 858
 859 =head1 NAME
 860
 861 Reaction::InterfaceModel::Reflector::DBIC -
 862 Automatically Generate InterfaceModels from DBIx::Class models
 863
 864 =head1 DESCRIPTION
 865
 866 The InterfaceModel reflectors are classes that are meant to aid you in easily
 867 generating Reaction::InterfaceModel classes that represent their underlying
 868 DBIx::Class domain models by introspecting your L<DBIx::Class::ResultSource>s
 869 and creating a collection of L<Reaction::InterfaceModel::Object> and
 870 L<Reaction::InterfaceModel::Collection> classes for you to use.
 871
 872 The default base class of all Object classes will be
 873  L<Reaction::InterfaceModel::Object> and the default Collection type will be
 874 L<Reaction::InterfaceModel::Collection::Virtual::ResultSet>.
 875
 876 Additionally, the reflector can create InterfaceModel actions that interact
 877 with the supplied L<Reaction::UI::Controller::Collection::CRUD>, allowing you
 878 to easily set up a highly customizable CRUD interface in minimal time.
 879
 880 At this time, supported collection actions consist of:
 881
 882 =over 4
 883
 884 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::Create>
 885
 886 Creates a new item in the collection and underlying ResultSet.
 887
 888 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::DeleteAll>
 889
 890 Deletes all the items in a collection and it's underlying resultset using
 891 C<delete_all>
 892
 893 =back
 894
 895 And supported object actions are :
 896
 897 =over 4
 898
 899 =item B<Update> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Update>
 900
 901 Updates an existing object.
 902
 903 =item B<Delete> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Delete>
 904
 905 Deletes an existing object.
 906
 907 =back
 908
 909 =head1 SYNOPSIS
 910
 911     package MyApp::IM::TestModel;
 912     use base 'Reaction::InterfaceModel::Object';
 913     use Reaction::Class;
 914     use Reaction::InterfaceModel::Reflector::DBIC;
 915     my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
 916
 917     #Reflect everything
 918     $reflector->reflect_schema
 919       (
 920        model_class  => __PACKAGE__,
 921        schema_class => 'MyApp::Schema',
 922       );
 923
 924 =head2 Selectively including and excluding sources
 925
 926     #reflect everything except for the FooBar and FooBaz classes
 927     $reflector->reflect_schema
 928       (
 929        model_class  => __PACKAGE__,
 930        schema_class => 'MyApp::Schema',
 931        sources => [-exclude => [qw/FooBar FooBaz/] ],
 932        # you could also do:
 933        sources => [-exclude => qr/(?:FooBar|FooBaz)/,
 934        # or even
 935        sources => [-exclude => [qr/FooBar/, qr/FooBaz/],
 936       );
 937
 938     #reflect only the Foo family of sources
 939     $reflector->reflect_schema
 940       (
 941        model_class  => __PACKAGE__,
 942        schema_class => 'MyApp::Schema',
 943        sources => qr/^Foo/,
 944       );
 945
 946 =head2 Selectively including and excluding fields in sources
 947
 948     #Reflect Foo and Baz in their entirety and exclude the field 'avatar' in the Bar ResultSource
 949     $reflector->reflect_schema
 950       (
 951        model_class  => __PACKAGE__,
 952        schema_class => 'MyApp::Schema',
 953        sources => [qw/Foo Baz/,
 954                    [ Bar => {attributes => [[-exclude => 'avatar']] } ],
 955                    # or exclude by regex
 956                    [ Bar => {attributes => [-exclude => qr/avatar/] } ],
 957                    # or simply do not include it...
 958                    [ Bar => {attributes => [qw/id name description/] } ],
 959                   ],
 960       );
 961
 962 =head1 ATTRIBUTES
 963
 964 =head2 make_classes_immutable
 965
 966 =head2 object_actions
 967
 968 =head2 collection_actions
 969
 970 =head2 default_object_actions
 971
 972 =head2 default_collection_actions
 973
 974 =head2 builtin_object_actions
 975
 976 =head2 builtin_collection_actions
 977
 978 =head1 METHODS
 979
 980 =head2 new
 981
 982 =head2 _all_object_actions
 983
 984 =head2 _all_collection_actions
 985
 986 =head2 dm_name_from_class_name
 987
 988 =head2 dm_name_from_source_name
 989
 990 =head2 class_name_from_source_name
 991
 992 =head2 class_name_for_collection_of
 993
 994 =head2 merge_hashes
 995
 996 =head2 parse_reflect_rules
 997
 998 =head2 merge_reflect_rules
 999
1000 =head2 reflect_schema
1001
1002 =head2 _compute_source_options
1003
1004 =head2 add_source
1005
1006 =head2 reflect_source
1007
1008 =head2 reflect_source_collection
1009
1010 =head2 reflect_source_object
1011
1012 =head2 reflect_source_object_attribute
1013
1014 =head2 parameters_for_source_object_attribute
1015
1016 =head2 reflect_source_action
1017
1018 =head2 parameters_for_source_object_action_attribute
1019
1020 =head1 TODO
1021
1022 Allow the reflector to dump the generated code out as files, eliminating the need to
1023 reflect on startup every time. This will likely take quite a bit of work though. The
1024 main work is already in place, but the grunt work is still left. At the moment there
1025 is no closures that can't be dumped out as code with a little bit of work.
1026
1027 =head1 AUTHORS
1028
1029 See L<Reaction::Class> for authors.
1030
1031 =head1 LICENSE
1032
1033 See L<Reaction::Class> for the license.
1034
1035 =cut