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