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   implements create_classes => as {
  21     my $self = shift;
  22     my $packages = $self->packages;
  23
  24     while(my($name, $properties) = each %$packages){
  25       my $base = $properties->{base} || 'Reaction::Object';
  26       my $meta = $self->_load_or_create($name, $base);
  27     }
  28
  29   };
  30
  31   implements reflect_schema => as {
  32     my ($self, %opts) = @_;
  33     my $base    = delete $opts{base} || Object;
  34     my $model   = delete $opts{model_class};
  35     my $schema  = delete $opts{schema_class};
  36     my $dm_name = delete $opts{domain_model_name};
  37     my $dm_args = delete $opts{domain_model_args} || {};
  38     $dm_name ||= $self->dm_name_from_class_name($schema);
  39
  40     #load all necessary classes
  41     confess("model_class and schema_class are required parameters")
  42       unless($model && $schema);
  43     Class::MOP::load_class( $base );
  44     Class::MOP::load_class( $schema );
  45
  46
  47     # sources => undef,              #default to qr/./
  48     # sources => [],                 #default to nothing
  49     # sources => qr//,               #DWIM, treated as [qr//]
  50     # sources => [{...}]             #DWIM, treat as [qr/./, {...} ]
  51     # sources => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
  52     my $haystack = [ $schema->sources ];
  53
  54     my $rules    = delete $opts{sources};
  55     if(!defined $rules){
  56       $rules = [qr/./];
  57     } elsif( ref $rules eq 'Regexp'){
  58       $rules = [ $rules ];
  59     } elsif( ref $rules eq 'ARRAY' && @$rules){
  60       #don't add a qr/./ rule if we have at least one match rule
  61       push(@$rules, qr/./) unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
  62                                           || !ref $_  || ref $_ eq 'Regexp'} @$rules;
  63     }
  64
  65     my $sources = $self->parse_reflect_rules($rules, $haystack);
  66
  67     my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
  68     $meta->make_mutable if $meta->is_immutable;
  69
  70     $meta->add_domain_model
  71       ($dm_name, is => 'rw', isa => $schema, required => 1, %$dm_args);
  72
  73     for my $source_name (keys %$sources){
  74       my $source_opts = $sources->{$source_name} || {};
  75       $self->reflect_source(
  76                             source_name  => $source_name,
  77                             parent_class => $model,
  78                             schema_class => $schema,
  79                             source_class => $schema->class($source_name),
  80                             parent_domain_model_name => $dm_name,
  81                             %$source_opts
  82                            );
  83     }
  84
  85     $meta->make_immutable if $make_immutable;
  86     return $meta;
  87   };
  88
  89   implements _compute_source_options => as {
  90     my ($self, %opts) = @_;
  91     my $schema       = delete $opts{schema_class};
  92     my $source_name  = delete $opts{source_name};
  93     my $source_class = delete $opts{source_class};
  94     my $parent       = delete $opts{parent_class};
  95     my $parent_dm    = delete $opts{parent_domain_model_name};
  96
  97     #this is the part where I hate my life for promissing all sorts of DWIMery
  98     confess("parent_class and source_name or source_class are required parameters")
  99       unless($parent && ($source_name || $source_class));
 100
 101   OUTER: until( $schema && $source_name && $source_class && $parent_dm ){
 102       if( $schema && !$source_name){
 103         next OUTER if $source_name = $source_class->result_source_instance->source_name;
 104       } elsif( $schema && !$source_class){
 105         next OUTER if $source_class = eval { $schema->class($source_name) };
 106       }
 107
 108       if($source_class && (!$schema || !$source_name)){
 109         if(!$schema){
 110           $schema = $source_class->result_source_instance->schema;
 111           next OUTER if $schema && Class::MOP::load_class($schema);
 112         }
 113         if(!$source_name){
 114           $source_name = $source_class->result_source_instance->source_name;
 115           next OUTER if $source_name;
 116         }
 117       }
 118       my @haystack = $parent_dm ?
 119         $parent->meta->find_attribute_by_name($parent_dm) : $parent->domain_models;
 120
 121       #there's a lot of guessing going on, but it should work fine on most cases
 122     INNER: for my $needle (@haystack){
 123         my $isa = $needle->_isa_metadata;
 124         next INNER unless Class::MOP::load_class( $isa->_isa_metadata );
 125         next INNER unless $isa->isa('DBIx::Class::Schema');
 126         if(!$parent_dm && $schema && $isa eq $schema){
 127           $parent_dm = $needle->name;
 128           next OUTER;
 129         }
 130
 131         if( $source_name ){
 132           my $src_class = eval{ $isa->class($source_name) };
 133           next INNER unless $src_class;
 134           next INNER if($source_class && $source_class ne $src_class);
 135           $schema = $isa;
 136           $parent_dm = $needle->name;
 137           $source_class = $src_class;
 138           next OUTER;
 139         }
 140       }
 141
 142       #do we even need to go this far?
 143       if( !$parent_dm && $schema ){
 144         my $tentative = $self->dm_name_from_class_name($schema);
 145         $parent_dm = $tentative if grep{$_->name eq $tentative} @haystack;
 146       }
 147
 148       confess("Could not determine options automatically from: schema " .
 149               "'${schema}', source_name '${source_name}', source_class " .
 150               "'${source_class}', parent_domain_model_name '${parent_dm}'");
 151     }
 152
 153     return {
 154             source_name  => $source_name,
 155             schema_class => $schema,
 156             source_class => $source_class,
 157             parent_class => $parent,
 158             parent_domain_model_name => $parent_dm,
 159            };
 160   };
 161
 162   implements _class_to_attribute_name => as {
 163     my ( $self, $str ) = @_;
 164     confess("wrong arguments passed for _class_to_attribute_name") unless $str;
 165     return join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $str))
 166   };
 167
 168   implements add_source => as {
 169     my ($self, %opts) = @_;
 170
 171     my $model      = delete $opts{model_class};
 172     my $reader     = delete $opts{reader};
 173     my $source     = delete $opts{source_name};
 174     my $dm_name    = delete $opts{domain_model_name};
 175     my $collection = delete $opts{collection_class};
 176     my $name       = delete $opts{attribute_name} || $source;
 177
 178     confess("model_class and source_name are required parameters")
 179       unless $model && $source;
 180     my $meta = $model->meta;
 181
 182     unless( $collection ){
 183       my $object = $self->class_name_from_source_name($model, $source);
 184       $collection = $self->class_name_for_collection_of($object);
 185     }
 186     unless( $reader ){
 187       $reader = $source;
 188       $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
 189       $reader = $self->_class_to_attribute_name($reader) . "_collection";
 190     }
 191     unless( $dm_name ){
 192       my @haystack = $meta->domain_models;
 193       if( @haystack > 1 ){
 194         @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack;
 195       }
 196       if(@haystack == 1){
 197         $dm_name = $haystack[0]->name;
 198       } elsif(@haystack > 1){
 199         confess("Failed to automatically determine domain_model_name. More than one " .
 200                 "possible match (".(join ", ", map{"'".$_->name."'"} @haystack).")");
 201       } else {
 202         confess("Failed to automatically determine domain_model_name. No matches.");
 203       }
 204     }
 205
 206     my %attr_opts =
 207       (
 208        lazy           => 1,
 209        required       => 1,
 210        isa            => $collection,
 211        reader         => $reader,
 212        predicate      => "has_" . $self->_class_to_attribute_name($name) ,
 213        domain_model   => $dm_name,
 214        orig_attr_name => $source,
 215        default        => sub {
 216          $collection->new
 217            (
 218             _source_resultset => $_[0]->$dm_name->resultset($source),
 219             _parent           => $_[0],
 220            );
 221        },
 222       );
 223
 224 #     my %debug_attr_opts =
 225 #       (
 226 #        lazy           => 1,
 227 #        required       => 1,
 228 #        isa            => $collection,
 229 #        reader         => $reader,
 230 #        predicate      => "has_" . $self->_class_to_attribute_name($name) ,
 231 #        domain_model   => $dm_name,
 232 #        orig_attr_name => $source,
 233 #        default        => qq^sub {
 234 #          my \$self = \$_[0];
 235 #          return $collection->new(
 236 #            _source_resultset => \$self->$dm_name->resultset("$source"),
 237 #            _parent => \$self,
 238 #          );
 239 #        }, ^,
 240 #       );
 241
 242
 243
 244     my $make_immutable = $meta->is_immutable;
 245     $meta->make_mutable   if $make_immutable;
 246     my $attr = $meta->add_attribute($name, %attr_opts);
 247     $meta->make_immutable if $make_immutable;
 248
 249     return $attr;
 250   };
 251
 252   implements reflect_source => as {
 253     my ($self, %opts) = @_;
 254     my $collection  = delete $opts{collection} || {};
 255     %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
 256
 257     my $obj_meta = $self->reflect_source_object(%opts);
 258     my $col_meta = $self->reflect_source_collection
 259       (
 260        object_class => $obj_meta->name,
 261        source_class => $opts{source_class},
 262        %$collection
 263       );
 264
 265     $self->add_source(
 266                       %opts,
 267                       model_class       => delete $opts{parent_class},
 268                       domain_model_name => delete $opts{parent_domain_model_name},
 269                       collection_class  => $col_meta->name,
 270                      );
 271   };
 272
 273   implements reflect_source_collection => as {
 274     my ($self, %opts) = @_;
 275     my $base    = delete $opts{base} || ResultSet;
 276     my $class   = delete $opts{class};
 277     my $object  = delete $opts{object_class};
 278     my $source  = delete $opts{source_class};
 279     my $action_rules = delete $opts{actions};
 280
 281     confess('object_class and source_class are required parameters')
 282       unless $object && $source;
 283     $class ||= $self->class_name_for_collection_of($object);
 284
 285     Class::MOP::load_class( $base );
 286     Class::MOP::load_class( $object );
 287     my $meta = $self->_load_or_create($class, $base);
 288
 289     my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;;
 290     $meta->make_mutable if $meta->is_immutable;
 291     $meta->add_method(_build_member_type => sub{ $object } );
 292     #XXX as a default pass the domain model as a target_model until i come up with something
 293     #better through the coercion method
 294     my $def_act_args = sub {
 295       my $super = shift;
 296       return { (target_model => $_[0]->_source_resultset), %{ $super->(@_) } };
 297     };
 298     $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
 299
 300
 301     {
 302       my $all_actions = $self->_all_collection_actions;
 303       my $action_haystack = [keys %$all_actions];
 304       if(!defined $action_rules){
 305         $action_rules = $self->default_collection_actions;
 306       } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){
 307         $action_rules = [ $action_rules ];
 308       } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){
 309         #don't add a qr/./ rule if we have at least one match rule
 310         push(@$action_rules, qr/./)
 311           unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 312                          || !ref $_  || ref $_ eq 'Regexp'} @$action_rules;
 313       }
 314
 315       # XXX this is kind of a dirty hack to support custom actions that are not
 316       # previously defined and still be able to use the parse_reflect_rules mechanism
 317       my @custom_actions = grep {!exists $all_actions->{$_}}
 318         map{ $_->[0] } grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules;
 319       push(@$action_haystack, @custom_actions);
 320       my $actions = $self->parse_reflect_rules($action_rules, $action_haystack);
 321       for my $action (keys %$actions){
 322         my $action_opts = $self->merge_hashes
 323           ($all_actions->{$action} || {}, $actions->{$action} || {});
 324
 325         #NOTE: If the name of the action is not specified in the prototype then use it's
 326         #hash key as the name. I think this is sane beahvior, but I've actually been thinking
 327         #of making Action prototypes their own separate objects
 328         $self->reflect_source_action(
 329                                      name         => $action,
 330                                      object_class => $object,
 331                                      source_class => $source,
 332                                      %$action_opts,
 333                                     );
 334
 335         # XXX i will move this to use the coercion method soon. this will be
 336         #  GoodEnough until then. I still need to think a little about the type coercion
 337         #  thing so i don't make a mess of it
 338         my $act_args = sub {   #override target model for this action
 339           my $super = shift;
 340           return { %{ $super->(@_) },
 341                    ($_[1] eq $action ? (target_model => $_[0]->_source_resultset) : () ) };
 342         };
 343         $meta->add_around_method_modifier('_default_action_args_for', $act_args);
 344       }
 345     }
 346     $meta->make_immutable if $make_immutable;
 347     return $meta;
 348   };
 349
 350   implements reflect_source_object => as {
 351     my($self, %opts) = @_;
 352     %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
 353
 354     my $base         = delete $opts{base}  || Object;
 355     my $class        = delete $opts{class};
 356     my $dm_name      = delete $opts{domain_model_name};
 357     my $dm_opts      = delete $opts{domain_model_args} || {};
 358
 359     my $source_name  = delete $opts{source_name};
 360     my $schema       = delete $opts{schema_class};
 361     my $source_class = delete $opts{source_class};
 362     my $parent       = delete $opts{parent_class};
 363     my $parent_dm    = delete $opts{parent_domain_model_name};
 364
 365     my $action_rules = delete $opts{actions};
 366     my $attr_rules   = delete $opts{attributes};
 367
 368     $class ||= $self->class_name_from_source_name($parent, $source_name);
 369
 370     Class::MOP::load_class($parent);
 371     Class::MOP::load_class($schema) if $schema;
 372     Class::MOP::load_class($source_class);
 373
 374     my $meta = $self->_load_or_create($class, $base);
 375
 376     #create the domain model
 377     $dm_name ||= $self->dm_name_from_source_name($source_name);
 378
 379     $dm_opts->{isa}        = $source_class;
 380     $dm_opts->{is}       ||= 'rw';
 381     $dm_opts->{required} ||= 1;
 382
 383     my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;;
 384     $meta->make_mutable if $meta->is_immutable;
 385
 386     my $dm_attr   = $meta->add_domain_model($dm_name, %$dm_opts);
 387     my $dm_reader = $dm_attr->get_read_method;
 388
 389     unless( $class->can('inflate_result') ){
 390       my $inflate_method = sub {
 391         my $class = shift; my ($src) = @_;
 392         $src = $src->resolve if $src->isa('DBIx::Class::ResultSourceHandle');
 393         $class->new($dm_name, $src->result_class->inflate_result(@_));
 394       };
 395       $meta->add_method('inflate_result', $inflate_method);
 396     }
 397
 398     #XXX this is here to allow action prototypes to work with ListView
 399     # maybe Collections hsould have this kind of thing too to allow you to reconstruct them?
 400     #i like the possibility to be honest... as aset of key/value pairs they could be URId
 401     #XXX move to using 'handles' for this?
 402     $meta->add_method('__id', sub {shift->$dm_reader->id} )
 403       unless $class->can('__id');
 404     #XXX this one is for Action, ChooseOne and ChooseMany need this shit
 405     $meta->add_method('__ident_condition', sub {shift->$dm_reader->ident_condition} )
 406       unless $class->can('__ident_condition');
 407
 408     #XXX this is just a disaster
 409     $meta->add_method('display_name', sub {shift->$dm_reader->display_name} )
 410       if( $source_class->can('display_name') && !$class->can('display_name'));
 411
 412     #XXX as a default pass the domain model as a target_model until i come up with something
 413     #better through the coercion method
 414     my $def_act_args = sub {
 415       my $super = shift;
 416       confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
 417       return { (target_model => $_[0]->$dm_reader), %{ $super->(@_) } };
 418     };
 419     $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
 420
 421     {
 422       # attributes => undef,              #default to qr/./
 423       # attributes => [],                 #default to nothing
 424       # attributes => qr//,               #DWIM, treated as [qr//]
 425       # attributes => [{...}]             #DWIM, treat as [qr/./, {...} ]
 426       # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
 427       my $attr_haystack =
 428         [ map { $_->name } $source_class->meta->compute_all_applicable_attributes ];
 429
 430       if(!defined $attr_rules){
 431         $attr_rules = [qr/./];
 432       } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
 433         $attr_rules = [ $attr_rules ];
 434       } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
 435         #don't add a qr/./ rule if we have at least one match rule
 436         push(@$attr_rules, qr/./) unless
 437           grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 438                   || !ref $_  || ref $_ eq 'Regexp'} @$attr_rules;
 439       }
 440
 441       my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
 442       for my $attr_name (keys %$attributes){
 443         $self->reflect_source_object_attribute(
 444                                                class             => $class,
 445                                                source_class      => $source_class,
 446                                                parent_class      => $parent,
 447                                                attribute_name    => $attr_name,
 448                                                domain_model_name => $dm_name,
 449                                                %{ $attributes->{$attr_name} || {}},
 450                                               );
 451       }
 452     }
 453
 454     {
 455       my $all_actions = $self->_all_object_actions;
 456       my $action_haystack = [keys %$all_actions];
 457       if(!defined $action_rules){
 458         $action_rules = $self->default_object_actions;
 459       } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){
 460         $action_rules = [ $action_rules ];
 461       } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){
 462         #don't add a qr/./ rule if we have at least one match rule
 463         push(@$action_rules, qr/./)
 464           unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 465                          || !ref $_  || ref $_ eq 'Regexp'} @$action_rules;
 466       }
 467
 468       # XXX this is kind of a dirty hack to support custom actions that are not
 469       # previously defined and still be able to use the parse_reflect_rules mechanism
 470       my @custom_actions = grep {!exists $all_actions->{$_}} map{ $_->[0] }
 471         grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules;
 472       push(@$action_haystack, @custom_actions);
 473       my $actions = $self->parse_reflect_rules($action_rules, $action_haystack);
 474       for my $action (keys %$actions){
 475         my $action_opts = $self->merge_hashes
 476           ($all_actions->{$action} || {}, $actions->{$action} || {});
 477
 478         #NOTE: If the name of the action is not specified in the prototype then use it's
 479         #hash key as the name. I think this is sane beahvior, but I've actually been thinking
 480         #of making Action prototypes their own separate objects
 481         $self->reflect_source_action(
 482                                      name         => $action,
 483                                      object_class => $class,
 484                                      source_class => $source_class,
 485                                      %$action_opts,
 486                                     );
 487
 488         # XXX i will move this to use the coercion method soon. this will be
 489         #  GoodEnough until then. I still need to think a little about the type coercion
 490         #  thing so i don't make a mess of it
 491         my $act_args = sub {   #override target model for this action
 492           my $super = shift;
 493           confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
 494           return { %{ $super->(@_) },
 495                    ($_[1] eq $action ? (target_model => $_[0]->$dm_reader) : () ) };
 496         };
 497         $meta->add_around_method_modifier('_default_action_args_for', $act_args);
 498       }
 499     }
 500
 501     $meta->make_immutable if $make_immutable;
 502     return $meta;
 503   };
 504
 505   # needs class, attribute_name domain_model_name
 506   implements reflect_source_object_attribute => as {
 507     my ($self, %opts) = @_;
 508     unless( $opts{attribute_name} && $opts{class} && $opts{parent_class}
 509             && ( $opts{source_class} || $opts{domain_model_name} ) ){
 510       confess( "Error: class, parent_class, attribute_name, and either " .
 511                "domain_model_name or source_class are required parameters" );
 512     }
 513
 514     my $meta =  $opts{class}->meta;
 515     my $attr_opts = $self->parameters_for_source_object_attribute(%opts);
 516
 517     my $make_immutable = $meta->is_immutable;
 518     $meta->make_mutable if $meta->is_immutable;
 519
 520     my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts);
 521
 522     $meta->make_immutable if $make_immutable;
 523     return $attr;
 524   };
 525
 526   # needs class, attribute_name domain_model_name
 527   implements parameters_for_source_object_attribute => as {
 528     my ($self, %opts) = @_;
 529
 530     my $class        = delete $opts{class};
 531     my $attr_name    = delete $opts{attribute_name};
 532     my $dm_name      = delete $opts{domain_model_name};
 533     my $source_class = delete $opts{source_class};
 534     my $parent_class = delete $opts{parent_class};
 535     confess("parent_class is a required argument") unless $parent_class;
 536     confess("You must supply at least one of domain_model_name and source_class")
 537       unless $dm_name || $source_class;
 538
 539     my $source;
 540     $source = $source_class->result_source_instance if $source_class;
 541     #puke! dwimery
 542     if( !$source_class ){
 543       my $dm = $class->meta->find_attribute_by_name($dm_name);
 544       $source_class = $dm->_isa_metadata;
 545       $source = $source_class->result_source_instance;
 546     } elsif( !$dm_name ){
 547       ($dm_name) = map{$_->name} grep{$_->_isa_metadata eq $source_class}
 548         $class->meta->domain_models;
 549       if( !$dm_name ){   #last resort guess
 550         my $tentative = $self->dm_name_from_source_name($source->source_name);
 551         ($dm_name) = $tentative if grep{$_->name eq $tentative} $class->domain_models;
 552       }
 553     }
 554
 555     my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
 556
 557     #default options. lazy build but no outsider method
 558     my %attr_opts = ( is => 'ro', lazy => 1, required => 1,
 559                       clearer   => "_clear_${attr_name}",
 560                       predicate => {
 561                           "has_${attr_name}" =>
 562                               sub { defined(shift->$dm_name->$attr_name) }
 563                       },
 564                       domain_model   => $dm_name,
 565                       orig_attr_name => $attr_name,
 566                     );
 567
 568     #m2m / has_many
 569     my $constraint_is_ArrayRef =
 570       $from_attr->type_constraint->name eq 'ArrayRef' ||
 571         $from_attr->type_constraint->is_subtype_of('ArrayRef');
 572
 573
 574
 575     if( my $rel_info = $source->relationship_info($attr_name) ){
 576       my $rel_accessor = $rel_info->{attrs}->{accessor};
 577       my $rel_moniker  = $rel_info->{class}->result_source_instance->source_name;
 578
 579       if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 580         #has_many
 581         my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker);
 582         #type constraint is a collection, and default builds it
 583         $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 584         $attr_opts{default} = sub {
 585           my $rs = shift->$dm_name->related_resultset($attr_name);
 586           return $attr_opts{isa}->new(_source_resultset => $rs);
 587         };
 588       } elsif( $rel_accessor eq 'single') {
 589         #belongs_to
 590         #type constraint is the foreign IM object, default inflates it
 591         $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
 592         $attr_opts{default} = sub {
 593           if (defined(my $o = shift->$dm_name->$attr_name)) {
 594             return $attr_opts{isa}->inflate_result($o->result_source, { $o->get_columns });
 595           }
 596           return undef;
 597             #->find_related($attr_name, {},{result_class => $attr_opts{isa}});
 598         };
 599       }
 600     } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
 601       #m2m magic
 602       my $mm_name = $1;
 603       my $link_table = "links_to_${mm_name}_list";
 604       my ($hm_source, $far_side);
 605       eval { $hm_source = $source->related_source($link_table); }
 606         || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 607       eval { $far_side = $hm_source->related_source($mm_name); }
 608         || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 609           ." traversing many-many for ${mm_name}_list";
 610
 611       my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name);
 612       $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 613
 614       #proper collections will remove the result_class uglyness.
 615       $attr_opts{default} = sub {
 616         my $rs = shift->$dm_name->related_resultset($link_table)->related_resultset($mm_name);
 617         return $attr_opts{isa}->new(_source_resultset => $rs);
 618       };
 619     #} elsif( $constraint_is_ArrayRef ){
 620       #test these to see if rel is m2m
 621       #my $meth = $attr_name;
 622       #if( $source->can("set_${meth}") && $source->can("add_to_${meth}") &&
 623       #    $source->can("${meth}_rs") && $source->can("remove_from_${meth}") ){
 624
 625
 626       #}
 627     } else {
 628       #no rel
 629       my $reader = $from_attr->get_read_method;
 630       $attr_opts{isa} = $from_attr->_isa_metadata;
 631       $attr_opts{default} = sub{ shift->$dm_name->$reader };
 632     }
 633     return \%attr_opts;
 634   };
 635
 636
 637   implements reflect_source_action => as{
 638     my($self, %opts) = @_;
 639     my $name   = delete $opts{name};
 640     my $class  = delete $opts{class};
 641     my $base   = delete $opts{base} || Action;
 642     my $object = delete $opts{object_class};
 643     my $source = delete $opts{source_class};
 644
 645     confess("name, object_class and source_class are required arguments")
 646       unless $source && $name && $object;
 647
 648     my $attr_rules = delete $opts{attributes};
 649     $class ||= $object->_default_action_class_for($name);
 650
 651     Class::MOP::load_class( $base   );
 652     Class::MOP::load_class( $object );
 653     Class::MOP::load_class( $source );
 654
 655     #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n";
 656     # attributes => undef,              #default to qr/./
 657     # attributes => [],                 #default to nothing
 658     # attributes => qr//,               #DWIM, treated as [qr//]
 659     # attributes => [{...}]             #DWIM, treat as [qr/./, {...} ]
 660     # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
 661     my $attr_haystack = [ map { $_->name } $object->meta->parameter_attributes ];
 662     if(!defined $attr_rules){
 663       $attr_rules = [qr/./];
 664     } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
 665       $attr_rules = [ $attr_rules ];
 666     } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
 667       #don't add a qr/./ rule if we have at least one match rule
 668       push(@$attr_rules, qr/./) unless
 669         grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 670                 || !ref $_  || ref $_ eq 'Regexp'} @$attr_rules;
 671     }
 672
 673     #print STDERR "${name}\t${class}\t${base}\n";
 674     #print STDERR "\t${object}\t${source}\n";
 675     #print STDERR "\t",@$attr_rules,"\n";
 676
 677     my $o_meta = $object->meta;
 678     my $s_meta = $source->meta;
 679     my $attributes  = $self->parse_reflect_rules($attr_rules, $attr_haystack);
 680
 681     #create the class
 682     my $meta = $self->_load_or_create($class, $base);
 683     my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
 684     $meta->make_mutable if $meta->is_immutable;
 685
 686     for my $attr_name (keys %$attributes){
 687       my $attr_opts   = $attributes->{$attr_name} || {};
 688       my $o_attr      = $o_meta->find_attribute_by_name($attr_name);
 689       my $s_attr_name = $o_attr->orig_attr_name || $attr_name;
 690       my $s_attr      = $s_meta->find_attribute_by_name($s_attr_name);
 691       confess("Unable to find attribute for '${s_attr_name}' via '${source}'")
 692         unless defined $s_attr;
 693       next unless $s_attr->get_write_method
 694         && $s_attr->get_write_method !~ /^_/; #only rw attributes!
 695
 696       my $attr_params = $self->parameters_for_source_object_action_attribute
 697         (
 698          object_class   => $object,
 699          source_class   => $source,
 700          attribute_name => $attr_name
 701         );
 702       $meta->add_attribute( $attr_name => %$attr_params);
 703     }
 704
 705     $meta->make_immutable if $make_immutable;
 706     return $meta;
 707   };
 708
 709   implements parameters_for_source_object_action_attribute => as {
 710     my ($self, %opts) = @_;
 711
 712     my $object       = delete $opts{object_class};
 713     my $attr_name    = delete $opts{attribute_name};
 714     my $source_class = delete $opts{source_class};
 715     confess("object_class and attribute_name are required parameters")
 716       unless $attr_name && $object;
 717
 718     my $o_meta  = $object->meta;
 719     my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model;
 720     $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
 721     my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
 722
 723     #print STDERR "$attr_name is type: " . $from_attr->meta->name . "\n";
 724
 725     confess("${attr_name} is not writeable and can not be reflected")
 726       unless $from_attr->get_write_method;
 727
 728     my %attr_opts = (
 729                      is        => 'rw',
 730                      isa       => $from_attr->_isa_metadata,
 731                      required  => $from_attr->is_required,
 732                      ($from_attr->is_required
 733                        ? () : (clearer => "clear_${attr_name}")),
 734                      predicate => "has_${attr_name}",
 735                     );
 736
 737     if ($attr_opts{required}) {
 738         if($from_attr->has_default) {
 739           $attr_opts{lazy} = 1;
 740           $attr_opts{default} = $from_attr->default;
 741         } else {
 742           $attr_opts{lazy_fail} = 1;
 743         }
 744     }
 745
 746     #test for relationships
 747     my $constraint_is_ArrayRef =
 748       $from_attr->type_constraint->name eq 'ArrayRef' ||
 749         $from_attr->type_constraint->is_subtype_of('ArrayRef');
 750
 751     my $source = $source_class->result_source_instance;
 752     if (my $rel_info = $source->relationship_info($attr_name)) {
 753       my $rel_accessor = $rel_info->{attrs}->{accessor};
 754
 755       if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 756         confess "${attr_name} is a rw has_many, this won't work.";
 757       } elsif( $rel_accessor eq 'single') {
 758         $attr_opts{valid_values} = sub {
 759           shift->target_model->result_source->related_source($attr_name)->resultset;
 760         };
 761       }
 762     } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
 763       my $mm_name = $1;
 764       my $link_table = "links_to_${mm_name}_list";
 765       my ($hm_source, $far_side);
 766       eval { $hm_source = $source->related_source($link_table); }
 767         || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 768       eval { $far_side = $hm_source->related_source($mm_name); }
 769         || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 770           ." traversing many-many for ${mm_name}_list";
 771
 772       $attr_opts{default} = sub { [] };
 773       $attr_opts{valid_values} = sub {
 774         shift->target_model->result_source->related_source($link_table)
 775           ->related_source($mm_name)->resultset;
 776       };
 777     }
 778     #use Data::Dumper;
 779     #print STDERR "\n" .$attr_name ." - ". $object . "\n";
 780     #print STDERR Dumper(\%attr_opts);
 781     return \%attr_opts;
 782   };
 783
 784   implements _load_or_create => as {
 785     my ($self, $class, $base) = @_;
 786     my $meta = $self->_maybe_load_class($class) ?
 787       $class->meta : $base->meta->create($class, superclasses => [ $base ]);
 788     return $meta;
 789   };
 790
 791   implements _maybe_load_class => as {
 792     my ($self, $class) = @_;
 793     my $file = $class . '.pm';
 794     $file =~ s{::}{/}g;
 795     my $ret = eval { Class::MOP::load_class($class) };
 796     if ($INC{$file} && $@) {
 797       confess "Error loading ${class}: $@";
 798     }
 799     return $ret;
 800   };
 801
 802 };
 803
 804 1;
 805
 806 #--------#---------#---------#---------#---------#---------#---------#---------#
 807 __END__;
 808
 809 =head1 NAME
 810
 811 Reaction::InterfaceModel::Reflector::DBIC -
 812 Automatically Generate InterfaceModels from DBIx::Class models
 813
 814 =head1 DESCRIPTION
 815
 816 The InterfaceModel reflectors are classes that are meant to aid you in easily
 817 generating Reaction::InterfaceModel classes that represent their underlying
 818 DBIx::Class domain models by introspecting your L<DBIx::Class::ResultSource>s
 819 and creating a collection of L<Reaction::InterfaceModel::Object> and
 820 L<Reaction::InterfaceModel::Collection> classes for you to use.
 821
 822 The default base class of all Object classes will be
 823  L<Reaction::InterfaceModel::Object> and the default Collection type will be
 824 L<Reaction::InterfaceModel::Collection::Virtual::ResultSet>.
 825
 826 Additionally, the reflector can create InterfaceModel actions that interact
 827 with the supplied L<Reaction::UI::Controller::Collection::CRUD>, allowing you
 828 to easily set up a highly customizable CRUD interface in minimal time.
 829
 830 At this time, supported collection actions consist of:
 831
 832 =over 4
 833
 834 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::Create>
 835
 836 Creates a new item in the collection and underlying ResultSet.
 837
 838 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::DeleteAll>
 839
 840 Deletes all the items in a collection and it's underlying resultset using
 841 C<delete_all>
 842
 843 =back
 844
 845 And supported object actions are :
 846
 847 =over 4
 848
 849 =item B<Update> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Update>
 850
 851 Updates an existing object.
 852
 853 =item B<Delete> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Delete>
 854
 855 Deletes an existing object.
 856
 857 =back
 858
 859 =head1 SYNOPSIS
 860
 861     package MyApp::IM::TestModel;
 862     use base 'Reaction::InterfaceModel::Object';
 863     use Reaction::Class;
 864     use Reaction::InterfaceModel::Reflector::DBIC;
 865     my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
 866
 867     #Reflect everything
 868     $reflector->reflect_schema
 869       (
 870        model_class  => __PACKAGE__,
 871        schema_class => 'MyApp::Schema',
 872       );
 873
 874 =head2 Selectively including and excluding sources
 875
 876     #reflect everything except for the FooBar and FooBaz classes
 877     $reflector->reflect_schema
 878       (
 879        model_class  => __PACKAGE__,
 880        schema_class => 'MyApp::Schema',
 881        sources => [-exclude => [qw/FooBar FooBaz/] ],
 882        # you could also do:
 883        sources => [-exclude => qr/(?:FooBar|FooBaz)/,
 884        # or even
 885        sources => [-exclude => [qr/FooBar/, qr/FooBaz/],
 886       );
 887
 888     #reflect only the Foo family of sources
 889     $reflector->reflect_schema
 890       (
 891        model_class  => __PACKAGE__,
 892        schema_class => 'MyApp::Schema',
 893        sources => qr/^Foo/,
 894       );
 895
 896 =head2 Selectively including and excluding fields in sources
 897
 898     #Reflect Foo and Baz in their entirety and exclude the field 'avatar' in the Bar ResultSource
 899     $reflector->reflect_schema
 900       (
 901        model_class  => __PACKAGE__,
 902        schema_class => 'MyApp::Schema',
 903        sources => [qw/Foo Baz/,
 904                    [ Bar => {attributes => [[-exclude => 'avatar']] } ],
 905                    # or exclude by regex
 906                    [ Bar => {attributes => [-exclude => qr/avatar/] } ],
 907                    # or simply do not include it...
 908                    [ Bar => {attributes => [qw/id name description/] } ],
 909                   ],
 910       );
 911
 912 =head1 ATTRIBUTES
 913
 914 =head2 make_classes_immutable
 915
 916 =head2 object_actions
 917
 918 =head2 collection_actions
 919
 920 =head2 default_object_actions
 921
 922 =head2 default_collection_actions
 923
 924 =head2 builtin_object_actions
 925
 926 =head2 builtin_collection_actions
 927
 928 =head1 METHODS
 929
 930 =head2 new
 931
 932 =head2 _all_object_actions
 933
 934 =head2 _all_collection_actions
 935
 936 =head2 dm_name_from_class_name
 937
 938 =head2 dm_name_from_source_name
 939
 940 =head2 class_name_from_source_name
 941
 942 =head2 class_name_for_collection_of
 943
 944 =head2 merge_hashes
 945
 946 =head2 parse_reflect_rules
 947
 948 =head2 merge_reflect_rules
 949
 950 =head2 reflect_schema
 951
 952 =head2 _compute_source_options
 953
 954 =head2 add_source
 955
 956 =head2 reflect_source
 957
 958 =head2 reflect_source_collection
 959
 960 =head2 reflect_source_object
 961
 962 =head2 reflect_source_object_attribute
 963
 964 =head2 parameters_for_source_object_attribute
 965
 966 =head2 reflect_source_action
 967
 968 =head2 parameters_for_source_object_action_attribute
 969
 970 =head1 TODO
 971
 972 Allow the reflector to dump the generated code out as files, eliminating the need to
 973 reflect on startup every time. This will likely take quite a bit of work though. The
 974 main work is already in place, but the grunt work is still left. At the moment there
 975 is no closures that can't be dumped out as code with a little bit of work.
 976
 977 =head1 AUTHORS
 978
 979 See L<Reaction::Class> for authors.
 980
 981 =head1 LICENSE
 982
 983 See L<Reaction::Class> for the license.
 984
 985 =cut