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 Action, 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     warn $class;
 760     my $meta = eval { Class::MOP::load_class($class) } ?
 761       $class->meta : $base->meta->create($class, superclasses => [$base]);
 762     my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
 763     $meta->make_mutable if $meta->is_immutable;
 764
 765     for my $attr_name (keys %$attributes){
 766       my $attr_opts   = $attributes->{$attr_name} || {};
 767       my $o_attr      = $o_meta->find_attribute_by_name($attr_name);
 768       my $s_attr_name = $o_attr->orig_attr_name || $attr_name;
 769       my $s_attr      = $s_meta->find_attribute_by_name($s_attr_name);
 770       confess("Unable to find attribute for '${s_attr_name}' via '${source}'")
 771         unless defined $s_attr;
 772       next unless $s_attr->get_write_method; #only rw attributes!
 773
 774       my $attr_params = $self->parameters_for_source_object_action_attribute
 775         (
 776          object_class   => $object,
 777          source_class   => $source,
 778          attribute_name => $attr_name
 779         );
 780       $meta->add_attribute( $attr_name => %$attr_params);
 781     }
 782
 783     $meta->make_immutable if $make_immutable;
 784     return $meta;
 785   };
 786
 787   implements parameters_for_source_object_action_attribute => as {
 788     my ($self, %opts) = @_;
 789
 790     my $object       = delete $opts{object_class};
 791     my $attr_name    = delete $opts{attribute_name};
 792     my $source_class = delete $opts{source_class};
 793     confess("object_class and attribute_name are required parameters")
 794       unless $attr_name && $object;
 795
 796     my $o_meta  = $object->meta;
 797     my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model;
 798     $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
 799     my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
 800
 801     confess("${attr_name} is not writeable and can not be reflected")
 802       unless $from_attr->get_write_method;
 803
 804     my %attr_opts = (
 805                      is        => 'rw',
 806                      isa       => $from_attr->_isa_metadata,
 807                      required  => $from_attr->is_required,
 808                      predicate => "has_${attr_name}",
 809                     );
 810
 811     if ($attr_opts{required}) {
 812         if($from_attr->has_default) {
 813           $attr_opts{lazy} = 1;
 814           $attr_opts{default} = $from_attr->default;
 815         } else {
 816           $attr_opts{lazy_fail} = 1;
 817         }
 818     }
 819
 820     #test for relationships
 821     my $constraint_is_ArrayRef =
 822       $from_attr->type_constraint->name eq 'ArrayRef' ||
 823         $from_attr->type_constraint->is_subtype_of('ArrayRef');
 824
 825     my $source = $source_class->result_source_instance;
 826     if (my $rel_info = $source->relationship_info($attr_name)) {
 827       my $rel_accessor = $rel_info->{attrs}->{accessor};
 828
 829       if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 830         confess "${attr_name} is a rw has_many, this won't work.";
 831       } elsif( $rel_accessor eq 'single') {
 832         $attr_opts{valid_values} = sub {
 833           shift->target_model->result_source->related_source($attr_name)->resultset;
 834         };
 835       }
 836     } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
 837       my $mm_name = $1;
 838       my $link_table = "links_to_${mm_name}_list";
 839       my ($hm_source, $far_side);
 840       eval { $hm_source = $source->related_source($link_table); }
 841         || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 842       eval { $far_side = $hm_source->related_source($mm_name); }
 843         || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 844           ." traversing many-many for ${mm_name}_list";
 845
 846       $attr_opts{default} = sub { [] };
 847       $attr_opts{valid_values} = sub {
 848         shift->target_model->result_source->related_source($link_table)
 849           ->related_source($mm_name)->resultset;
 850       };
 851     }
 852     #use Data::Dumper;
 853     #print STDERR "\n" .$attr_name ." - ". $object . "\n";
 854     #print STDERR Dumper(\%attr_opts);
 855     return \%attr_opts;
 856   };
 857
 858 };
 859
 860 1;
 861
 862 #--------#---------#---------#---------#---------#---------#---------#---------#
 863 __END__;
 864
 865 =head1 NAME
 866
 867 Reaction::InterfaceModel::Reflector::DBIC -
 868 Automatically Generate InterfaceModels from DBIx::Class models
 869
 870 =head1 DESCRIPTION
 871
 872 The InterfaceModel reflectors are classes that are meant to aid you in easily
 873 generating Reaction::InterfaceModel classes that represent their underlying
 874 DBIx::Class domain models by introspecting your L<DBIx::Class::ResultSource>s
 875 and creating a collection of L<Reaction::InterfaceModel::Object> and
 876 L<Reaction::InterfaceModel::Collection> classes for you to use.
 877
 878 The default base class of all Object classes will be
 879  L<Reaction::InterfaceModel::Object> and the default Collection type will be
 880 L<Reaction::InterfaceModel::Collection::Virtual::ResultSet>.
 881
 882 Additionally, the reflector can create InterfaceModel actions that interact
 883 with the supplied L<Reaction::UI::Controller::Collection::CRUD>, allowing you
 884 to easily set up a highly customizable CRUD interface in minimal time.
 885
 886 At this time, supported collection actions consist of:
 887
 888 =over 4
 889
 890 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::Create>
 891
 892 Creates a new item in the collection and underlying ResultSet.
 893
 894 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::DeleteAll>
 895
 896 Deletes all the items in a collection and it's underlying resultset using
 897 C<delete_all>
 898
 899 =back
 900
 901 And supported object actions are :
 902
 903 =over 4
 904
 905 =item B<Update> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Update>
 906
 907 Updates an existing object.
 908
 909 =item B<Delete> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Delete>
 910
 911 Deletes an existing object.
 912
 913 =back
 914
 915 =head1 SYNOPSIS
 916
 917     package MyApp::IM::TestModel;
 918     use base 'Reaction::InterfaceModel::Object';
 919     use Reaction::Class;
 920     use Reaction::InterfaceModel::Reflector::DBIC;
 921     my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
 922
 923     #Reflect everything
 924     $reflector->reflect_schema
 925       (
 926        model_class  => __PACKAGE__,
 927        schema_class => 'MyApp::Schema',
 928       );
 929
 930 =head2 Selectively including and excluding sources
 931
 932     #reflect everything except for the FooBar and FooBaz classes
 933     $reflector->reflect_schema
 934       (
 935        model_class  => __PACKAGE__,
 936        schema_class => 'MyApp::Schema',
 937        sources => [-exclude => [qw/FooBar FooBaz/] ],
 938        # you could also do:
 939        sources => [-exclude => qr/(?:FooBar|FooBaz)/,
 940        # or even
 941        sources => [-exclude => [qr/FooBar/, qr/FooBaz/],
 942       );
 943
 944     #reflect only the Foo family of sources
 945     $reflector->reflect_schema
 946       (
 947        model_class  => __PACKAGE__,
 948        schema_class => 'MyApp::Schema',
 949        sources => qr/^Foo/,
 950       );
 951
 952 =head2 Selectively including and excluding fields in sources
 953
 954     #Reflect Foo and Baz in their entirety and exclude the field 'avatar' in the Bar ResultSource
 955     $reflector->reflect_schema
 956       (
 957        model_class  => __PACKAGE__,
 958        schema_class => 'MyApp::Schema',
 959        sources => [qw/Foo Baz/,
 960                    [ Bar => {attributes => [[-exclude => 'avatar']] } ],
 961                    # or exclude by regex
 962                    [ Bar => {attributes => [-exclude => qr/avatar/] } ],
 963                    # or simply do not include it...
 964                    [ Bar => {attributes => [qw/id name description/] } ],
 965                   ],
 966       );
 967
 968 =head1 ATTRIBUTES
 969
 970 =head2 make_classes_immutable
 971
 972 =head2 object_actions
 973
 974 =head2 collection_actions
 975
 976 =head2 default_object_actions
 977
 978 =head2 default_collection_actions
 979
 980 =head2 builtin_object_actions
 981
 982 =head2 builtin_collection_actions
 983
 984 =head1 METHODS
 985
 986 =head2 new
 987
 988 =head2 _all_object_actions
 989
 990 =head2 _all_collection_actions
 991
 992 =head2 dm_name_from_class_name
 993
 994 =head2 dm_name_from_source_name
 995
 996 =head2 class_name_from_source_name
 997
 998 =head2 class_name_for_collection_of
 999
1000 =head2 merge_hashes
1001
1002 =head2 parse_reflect_rules
1003
1004 =head2 merge_reflect_rules
1005
1006 =head2 reflect_schema
1007
1008 =head2 _compute_source_options
1009
1010 =head2 add_source
1011
1012 =head2 reflect_source
1013
1014 =head2 reflect_source_collection
1015
1016 =head2 reflect_source_object
1017
1018 =head2 reflect_source_object_attribute
1019
1020 =head2 parameters_for_source_object_attribute
1021
1022 =head2 reflect_source_action
1023
1024 =head2 parameters_for_source_object_action_attribute
1025
1026 =head1 TODO
1027
1028 Allow the reflector to dump the generated code out as files, eliminating the need to
1029 reflect on startup every time. This will likely take quite a bit of work though. The
1030 main work is already in place, but the grunt work is still left. At the moment there
1031 is no closures that can't be dumped out as code with a little bit of work.
1032
1033 =head1 AUTHORS
1034
1035 See L<Reaction::Class> for authors.
1036
1037 =head1 LICENSE
1038
1039 See L<Reaction::Class> for the license.
1040
1041 =cut