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