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
 654   #default options. lazy build but no outsider method
 655   my %attr_opts = ( is => 'ro', lazy => 1, required => 1,
 656                     clearer   => "_clear_${attr_name}",
 657                     predicate => {
 658                         "has_${attr_name}" =>
 659                             sub { defined(shift->$dm_name->$reader) }
 660                     },
 661                     domain_model   => $dm_name,
 662                     orig_attr_name => $attr_name,
 663                   );
 664
 665   #m2m / has_many
 666   my $m2m_meta;
 667   if(my $coderef = $source->result_class->can('_m2m_metadata')){
 668     $m2m_meta = $source->result_class->$coderef;
 669   }
 670
 671   my $constraint_is_ArrayRef =
 672     $from_attr->type_constraint->name eq 'ArrayRef' ||
 673       $from_attr->type_constraint->is_subtype_of('ArrayRef');
 674
 675   if( my $rel_info = $source->relationship_info($attr_name) ){
 676     my $rel_accessor = $rel_info->{attrs}->{accessor};
 677     my $rel_moniker  = $rel_info->{class}->result_source_instance->source_name;
 678
 679     if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 680       #has_many
 681       my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker);
 682       #type constraint is a collection, and default builds it
 683       my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 684       $attr_opts{default} = eval "sub {
 685         my \$rs = shift->${dm_name}->related_resultset('${attr_name}');
 686         return ${isa}->new(_source_resultset => \$rs);
 687       }";
 688     } elsif( $rel_accessor eq 'single' || $rel_accessor eq 'filter' ) {
 689       #belongs_to
 690       #type constraint is the foreign IM object, default inflates it
 691       my $isa = $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
 692       $attr_opts{default} = eval "sub {
 693         if (defined(my \$o = shift->${dm_name}->${reader})) {
 694           return ${isa}->inflate_result(\$o->result_source, { \$o->get_columns });
 695         }
 696         return undef;
 697       }";
 698     }
 699   } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
 700     #m2m magic
 701     my $mm_name = $1;
 702     my $link_table = "links_to_${mm_name}_list";
 703     my ($hm_source, $far_side);
 704     eval { $hm_source = $source->related_source($link_table); }
 705       || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 706     eval { $far_side = $hm_source->related_source($mm_name); }
 707       || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 708         ." traversing many-many for ${mm_name}_list";
 709
 710     my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name);
 711     my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 712
 713     #proper collections will remove the result_class uglyness.
 714     $attr_opts{default} = eval "sub {
 715       my \$rs = shift->${dm_name}->related_resultset('${link_table}')->related_resultset('${mm_name}');
 716       return ${isa}->new(_source_resultset => \$rs);
 717     }";
 718   } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){
 719     #m2m if using introspectable m2m component
 720     my $rel = $m2m_meta->{$attr_name}->{relation};
 721     my $far_rel   = $m2m_meta->{$attr_name}->{foreign_relation};
 722     my $far_source = $source->related_source($rel)->related_source($far_rel);
 723     my $sm = $self->class_name_from_source_name($parent_class, $far_source->source_name);
 724     my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 725
 726     my $rs_meth = $m2m_meta->{$attr_name}->{rs_method};
 727     $attr_opts{default} = eval "sub {
 728       return ${isa}->new(_source_resultset => shift->${dm_name}->${rs_meth});
 729     }";
 730   } else {
 731     #no rel
 732     $attr_opts{isa} = $from_attr->_isa_metadata;
 733     $attr_opts{default} = eval "sub{ shift->${dm_name}->${reader} }";
 734   }
 735   return \%attr_opts;
 736 };
 737 sub reflect_source_action {
 738   my($self, %opts) = @_;
 739   my $name = delete $opts{name};
 740   my $base = delete $opts{base} || Action;
 741   my $roles = delete $opts{roles} || [];
 742   my $class = delete $opts{class};
 743   my $object = delete $opts{object_class};
 744   my $source = delete $opts{source_class};
 745
 746   confess("name, object_class and source_class are required arguments")
 747     unless $source && $name && $object;
 748
 749   my $attr_rules = delete $opts{attributes};
 750   $class ||= $object->_default_action_class_for($name);
 751
 752   Class::MOP::load_class( $base   );
 753   Class::MOP::load_class( $object );
 754   Class::MOP::load_class( $source );
 755
 756   #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n";
 757   # attributes => undef,              #default to qr/./
 758   # attributes => [],                 #default to nothing
 759   # attributes => qr//,               #DWIM, treated as [qr//]
 760   # attributes => [{...}]             #DWIM, treat as [qr/./, {...} ]
 761   # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
 762   my $attr_haystack = [ map { $_->name } $object->parameter_attributes ];
 763   if(!defined $attr_rules){
 764     $attr_rules = [qr/./];
 765   } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
 766     $attr_rules = [ $attr_rules ];
 767   } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
 768     #don't add a qr/./ rule if we have at least one match rule
 769     push(@$attr_rules, qr/./) unless
 770       grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 771               || !ref $_  || ref $_ eq 'Regexp'} @$attr_rules;
 772   }
 773
 774   #print STDERR "${name}\t${class}\t${base}\n";
 775   #print STDERR "\t${object}\t${source}\n";
 776   #print STDERR "\t",@$attr_rules,"\n";
 777
 778   my $o_meta = $object->meta;
 779   my $s_meta = $source->meta;
 780   my $attributes  = $self->parse_reflect_rules($attr_rules, $attr_haystack);
 781
 782   #create the class
 783   my $meta = $self->_load_or_create(
 784     $class,
 785     superclasses => [$base],
 786     ( @$roles ? (roles => $roles) : ()),
 787   );
 788   my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
 789   $meta->make_mutable if $meta->is_immutable;
 790
 791   for my $attr_name (keys %$attributes){
 792     my $attr_opts   = $attributes->{$attr_name} || {};
 793     my $o_attr      = $o_meta->find_attribute_by_name($attr_name);
 794     my $s_attr_name = $o_attr->orig_attr_name || $attr_name;
 795     my $s_attr      = $s_meta->find_attribute_by_name($s_attr_name);
 796     confess("Unable to find attribute for '${s_attr_name}' via '${source}'")
 797       unless defined $s_attr;
 798     next unless $s_attr->get_write_method
 799       && $s_attr->get_write_method !~ /^_/; #only rw attributes!
 800
 801     my $attr_params = $self->parameters_for_source_object_action_attribute
 802       (
 803        object_class   => $object,
 804        source_class   => $source,
 805        attribute_name => $attr_name
 806       );
 807     $meta->add_attribute( $attr_name => %$attr_params);
 808   }
 809
 810   $meta->make_immutable if $make_immutable;
 811   return $meta;
 812 };
 813 sub parameters_for_source_object_action_attribute {
 814   my ($self, %opts) = @_;
 815
 816   my $object       = delete $opts{object_class};
 817   my $attr_name    = delete $opts{attribute_name};
 818   my $source_class = delete $opts{source_class};
 819   confess("object_class and attribute_name are required parameters")
 820     unless $attr_name && $object;
 821
 822   my $o_meta  = $object->meta;
 823   my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model;
 824   $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
 825   my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
 826
 827   #print STDERR "$attr_name is type: " . $from_attr->meta->name . "\n";
 828
 829   confess("${attr_name} is not writeable and can not be reflected")
 830     unless $from_attr->get_write_method;
 831
 832   my %attr_opts = (
 833                    is        => 'rw',
 834                    isa       => $from_attr->_isa_metadata,
 835                    required  => $from_attr->is_required,
 836                    ($from_attr->is_required
 837                      ? () : (clearer => "clear_${attr_name}")),
 838                    predicate => "has_${attr_name}",
 839                   );
 840
 841   if ($attr_opts{required}) {
 842       if($from_attr->has_default) {
 843         $attr_opts{lazy} = 1;
 844         $attr_opts{default} = $from_attr->default;
 845       } else {
 846         $attr_opts{lazy_fail} = 1;
 847       }
 848   }
 849
 850
 851   my $m2m_meta;
 852   if(my $coderef = $source_class->result_class->can('_m2m_metadata')){
 853     $m2m_meta = $source_class->result_class->$coderef;
 854   }
 855   #test for relationships
 856   my $constraint_is_ArrayRef =
 857     $from_attr->type_constraint->name eq 'ArrayRef' ||
 858       $from_attr->type_constraint->is_subtype_of('ArrayRef');
 859
 860   my $source = $source_class->result_source_instance;
 861   if (my $rel_info = $source->relationship_info($attr_name)) {
 862     my $rel_accessor = $rel_info->{attrs}->{accessor};
 863
 864     if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 865       confess "${attr_name} is a rw has_many, this won't work.";
 866     } elsif( $rel_accessor eq 'single' || $rel_accessor eq 'filter') {
 867       $attr_opts{valid_values} = sub {
 868         shift->target_model->result_source->related_source($attr_name)->resultset;
 869       };
 870     }
 871   } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
 872     my $mm_name = $1;
 873     my $link_table = "links_to_${mm_name}_list";
 874     $attr_opts{default} = sub { [] };
 875     $attr_opts{valid_values} = sub {
 876       shift->target_model->result_source->related_source($link_table)
 877         ->related_source($mm_name)->resultset;
 878     };
 879   } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){
 880     #m2m if using introspectable m2m component
 881     my $rel = $m2m_meta->{$attr_name}->{relation};
 882     my $far_rel   = $m2m_meta->{$attr_name}->{foreign_relation};
 883     $attr_opts{default} = sub { [] };
 884     $attr_opts{valid_values} = sub {
 885       shift->target_model->result_source->related_source($rel)
 886         ->related_source($far_rel)->resultset;
 887     };
 888   }
 889   #use Data::Dumper;
 890   #print STDERR "\n" .$attr_name ." - ". $object . "\n";
 891   #print STDERR Dumper(\%attr_opts);
 892   return \%attr_opts;
 893 };
 894
 895 sub _load_or_create {
 896   my ($self, $class, %options) = @_;
 897
 898   if( $self->_maybe_load_class($class) ){
 899     return $class->meta;
 900   }
 901   my $base;
 902   if( exists $options{superclasses} ){
 903     ($base) = @{ $options{superclasses} };
 904   } else {
 905     $base = 'Reaction::InterfaceModel::Action';
 906   }
 907   return $base->meta->create($class, %options);
 908 }
 909
 910 sub _maybe_load_class {
 911   my ($self, $class) = @_;
 912   my $file = $class . '.pm';
 913   $file =~ s{::}{/}g;
 914   my $ret = eval { Class::MOP::load_class($class) };
 915   if ($INC{$file} && $@) {
 916     confess "Error loading ${class}: $@";
 917   }
 918   return $ret;
 919 }
 920
 921 __PACKAGE__->meta->make_immutable;
 922
 923
 924 1;
 925
 926 #--------#---------#---------#---------#---------#---------#---------#---------#
 927 __END__;
 928
 929 =head1 NAME
 930
 931 Reaction::InterfaceModel::Reflector::DBIC -
 932 Automatically Generate InterfaceModels from DBIx::Class models
 933
 934 =head1 DESCRIPTION
 935
 936 The InterfaceModel reflectors are classes that are meant to aid you in easily
 937 generating Reaction::InterfaceModel classes that represent their underlying
 938 DBIx::Class domain models by introspecting your L<DBIx::Class::ResultSource>s
 939 and creating a collection of L<Reaction::InterfaceModel::Object> and
 940 L<Reaction::InterfaceModel::Collection> classes for you to use.
 941
 942 The default base class of all Object classes will be
 943  L<Reaction::InterfaceModel::Object> and the default Collection type will be
 944 L<Reaction::InterfaceModel::Collection::Virtual::ResultSet>.
 945
 946 Additionally, the reflector can create InterfaceModel actions that interact
 947 with the supplied L<Reaction::UI::Controller::Collection::CRUD>, allowing you
 948 to easily set up a highly customizable CRUD interface in minimal time.
 949
 950 At this time, supported collection actions consist of:
 951
 952 =over 4
 953
 954 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::Create>
 955
 956 Creates a new item in the collection and underlying ResultSet.
 957
 958 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::DeleteAll>
 959
 960 Deletes all the items in a collection and it's underlying resultset using
 961 C<delete_all>
 962
 963 =back
 964
 965 And supported object actions are :
 966
 967 =over 4
 968
 969 =item B<Update> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Update>
 970
 971 Updates an existing object.
 972
 973 =item B<Delete> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Delete>
 974
 975 Deletes an existing object.
 976
 977 =back
 978
 979 =head1 SYNOPSIS
 980
 981     package MyApp::IM::TestModel;
 982     use base 'Reaction::InterfaceModel::Object';
 983     use Reaction::Class;
 984     use Reaction::InterfaceModel::Reflector::DBIC;
 985     my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
 986
 987     #Reflect everything
 988     $reflector->reflect_schema
 989       (
 990        model_class  => __PACKAGE__,
 991        schema_class => 'MyApp::Schema',
 992       );
 993
 994 =head2 Selectively including and excluding sources
 995
 996     #reflect everything except for the FooBar and FooBaz classes
 997     $reflector->reflect_schema
 998       (
 999        model_class  => __PACKAGE__,
1000        schema_class => 'MyApp::Schema',
1001        sources => [-exclude => [qw/FooBar FooBaz/] ],
1002        # you could also do:
1003        sources => [-exclude => qr/(?:FooBar|FooBaz)/,
1004        # or even
1005        sources => [-exclude => [qr/FooBar/, qr/FooBaz/],
1006       );
1007
1008     #reflect only the Foo family of sources
1009     $reflector->reflect_schema
1010       (
1011        model_class  => __PACKAGE__,
1012        schema_class => 'MyApp::Schema',
1013        sources => qr/^Foo/,
1014       );
1015
1016 =head2 Selectively including and excluding fields in sources
1017
1018     #Reflect Foo and Baz in their entirety and exclude the field 'avatar' in the Bar ResultSource
1019     $reflector->reflect_schema
1020       (
1021        model_class  => __PACKAGE__,
1022        schema_class => 'MyApp::Schema',
1023        sources => [qw/Foo Baz/,
1024                    [ Bar => {attributes => [[-exclude => 'avatar']] } ],
1025                    # or exclude by regex
1026                    [ Bar => {attributes => [-exclude => qr/avatar/] } ],
1027                    # or simply do not include it...
1028                    [ Bar => {attributes => [qw/id name description/] } ],
1029                   ],
1030       );
1031
1032 =head1 ATTRIBUTES
1033
1034 =head2 make_classes_immutable
1035
1036 =head2 object_actions
1037
1038 =head2 collection_actions
1039
1040 =head2 default_object_actions
1041
1042 =head2 default_collection_actions
1043
1044 =head2 builtin_object_actions
1045
1046 =head2 builtin_collection_actions
1047
1048 =head1 METHODS
1049
1050 =head2 new
1051
1052 =head2 _all_object_actions
1053
1054 =head2 _all_collection_actions
1055
1056 =head2 dm_name_from_class_name
1057
1058 =head2 dm_name_from_source_name
1059
1060 =head2 class_name_from_source_name
1061
1062 =head2 class_name_for_collection_of
1063
1064 =head2 merge_hashes
1065
1066 =head2 parse_reflect_rules
1067
1068 =head2 merge_reflect_rules
1069
1070 =head2 reflect_schema
1071
1072 =head2 _compute_source_options
1073
1074 =head2 add_source
1075
1076 =head2 reflect_source
1077
1078 =head2 reflect_source_collection
1079
1080 =head2 reflect_source_object
1081
1082 =head2 reflect_source_object_attribute
1083
1084 =head2 parameters_for_source_object_attribute
1085
1086 =head2 reflect_source_action
1087
1088 =head2 parameters_for_source_object_action_attribute
1089
1090 =head1 TODO
1091
1092 Allow the reflector to dump the generated code out as files, eliminating the need to
1093 reflect on startup every time. This will likely take quite a bit of work though. The
1094 main work is already in place, but the grunt work is still left. At the moment there
1095 is no closures that can't be dumped out as code with a little bit of work.
1096
1097 =head1 AUTHORS
1098
1099 See L<Reaction::Class> for authors.
1100
1101 =head1 LICENSE
1102
1103 See L<Reaction::Class> for the license.
1104
1105 =cut