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