lib/Reaction/InterfaceModel/DBIC/ObjectClass.pm

   1 package Reaction::InterfaceModel::DBIC::ObjectClass;
   2
   3 use Reaction::ClassExporter;
   4 use Reaction::Class;
   5 use aliased 'Reaction::InterfaceModel::DBIC::Collection';
   6 use Class::MOP;
   7
   8 use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create';
   9 use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update';
  10 use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete';
  11
  12 use aliased 'Reaction::Meta::InterfaceModel::Action::Class' => 'ActionClass';
  13
  14 class ObjectClass, is 'Reaction::InterfaceModel::ObjectClass', which {
  15   override exports_for_package => sub {
  16     my ($self, $package) = @_;
  17     my %exports = $self->SUPER::exports_for_package($package);
  18
  19     $exports{reflect_actions} = sub {
  20
  21       my %actions = @_;
  22       my $meta = $package->meta;
  23       my $defaults = {
  24                       'Create' => { base => Create },
  25                       'Update' => { base => Update },
  26                       'Delete' => { base => Delete },
  27                      };
  28
  29       while (my($name,$opts) = each %actions) {
  30         my $action_class = delete $opts->{class} ||
  31           $package->_default_action_class_for($name);
  32
  33         #support this for now, I don't know about defaults yet though.
  34         #especially, '*' for all writtable attributes. ugh
  35         my $super = delete $opts->{base} || $defaults->{$name}->{base} || [];
  36         my $attrs = delete $opts->{attrs} || [];
  37         $super = (ref($super) ne 'ARRAY' && $super) ? [ $super ] : [];
  38
  39         $self->reflect_action($meta, $action_class, $super, $attrs);
  40       }
  41     };
  42
  43
  44     my $orig_domain_model = delete $exports{domain_model};
  45     $exports{domain_model} = sub {
  46       my($dm_name, %opts) = @_;
  47
  48       my $reflect = delete $opts{reflect};
  49       my $inflate_result = delete $opts{inflate_result};
  50
  51       my @attr_names = map {ref $_ ? $_->[0] : $_ } @$reflect;
  52       $opts{reflect} = [@attr_names];
  53       $orig_domain_model->($dm_name, %opts);
  54
  55       #Create an inflate result_method for DBIC objects
  56       my $meta = $package->meta;
  57       if ($inflate_result) {
  58         my $inflate = sub {
  59           my $class = shift; my ($source) = @_;
  60           if($source->isa('DBIx::Class::ResultSourceHandle'))
  61           {
  62               $source = $source->resolve;
  63           }
  64           return $class->new
  65             ($dm_name, $source->result_class->inflate_result(@_));
  66         };
  67         $meta->add_method('inflate_result', $inflate);
  68       }
  69
  70       #relationship magic
  71       my %rel_attrs = map{ @$_ } grep {ref $_} @$reflect;
  72       my $dm_meta = $opts{isa}->meta;
  73
  74       for my $attr_name ( @attr_names ) {
  75
  76         my $from_attr = $dm_meta->find_attribute_by_name($attr_name);
  77         confess "Failed to get attribute $attr_name from class $opts{isa}"
  78           unless $from_attr;
  79
  80         if ( my $info = $opts{isa}->result_source_instance
  81              ->relationship_info($attr_name) ) {
  82
  83           next unless(my $rel_accessor = $info->{attrs}->{accessor});
  84
  85           unless ( $rel_attrs{$attr_name} ) {
  86             my ($im_class) = ($package =~ /^(.*)::\w+$/);
  87             my ($rel_class) = ($attr_name =~ /^(.*?)(_list)?$/);
  88             $rel_class = join '', map{ ucfirst($_) } split '_', $rel_class;
  89             $rel_attrs{$attr_name} = "${im_class}::${rel_class}";
  90           }
  91           Class::MOP::load_class($rel_attrs{$attr_name}) ||
  92               confess "Could not load ".$rel_attrs{$attr_name};
  93
  94           #has_many rels
  95           if ($rel_accessor eq 'multi' &&
  96               ( $from_attr->type_constraint->name eq 'ArrayRef' ||
  97                 $from_attr->type_constraint->is_subtype_of('ArrayRef') )
  98              ) {
  99
 100             # # remove the old attribute and recreate it with new isa
 101             my %attr_opts = ( is => 'ro',
 102                               lazy_build => 1,
 103                               isa => Collection,
 104                               clearer => "_clear_${attr_name}",
 105                               domain_model => $dm_name,
 106                               orig_attr_name => $attr_name,
 107                             );
 108             $meta->add_attribute( $attr_name, %attr_opts);
 109
 110             #remove old build and add a better one
 111             #proper collections will remove the result_class uglyness.
 112             my $build_method = sub {
 113               my $rs = shift->$dm_name->search_related_rs
 114                 ($attr_name, {},
 115                  {
 116                   result_class => $rel_attrs{$attr_name} });
 117               return bless($rs => Collection);
 118             };
 119             $meta->remove_method( "build_${attr_name}");
 120             $meta->add_method( "build_${attr_name}", $build_method);
 121           } elsif ($rel_accessor eq 'single') {
 122             # # remove the old attribute and recreate it with new isa
 123             my %attr_opts = ( is => 'ro',
 124                               lazy_build => 1,
 125                               isa => $rel_attrs{$attr_name},
 126                               clearer => "_clear_${attr_name}",
 127                               domain_model => $dm_name,
 128                               orig_attr_name => $attr_name,
 129                             );
 130             $meta->add_attribute( $attr_name, %attr_opts);
 131
 132             #delete and recreate the build method to properly inflate the
 133             #result into an IM::O class instead of the original
 134             #this probably needs some cleaning
 135             #proper collections will remove the result_class uglyness.
 136             my $build_method = sub {
 137               shift->$dm_name->find_related
 138                 ($attr_name, {},
 139                  {
 140                   result_class => $rel_attrs{$attr_name}});
 141             };
 142             $meta->remove_method( "build_${attr_name}");
 143             $meta->add_method( "build_${attr_name}", $build_method);
 144           }
 145         } elsif ( $from_attr->type_constraint->name eq 'ArrayRef' ||
 146                   $from_attr->type_constraint->is_subtype_of('ArrayRef')
 147                 ) {
 148           #m2m magicness
 149           next unless $attr_name =~ m/^(.*)_list$/;
 150           my $mm_name = $1;
 151           my ($hm_source, $far_side);
 152           # we already get one for the rel info check, unify that??
 153           my $source = $opts{isa}->result_source_instance;
 154           eval { $hm_source = $source->related_source("links_to_${mm_name}_list"); }
 155             || confess "Can't find links_to_${mm_name}_list has_many for ${mm_name}_list";
 156           eval { $far_side = $hm_source->related_source($mm_name); }
 157             || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 158               ." traversing many-many for ${mm_name}_list";
 159
 160           # # remove the old attribute and recreate it with new isa
 161           my %attr_opts = ( is => 'ro',
 162                             lazy_build => 1,
 163                             isa => Collection,
 164                             clearer => "_clear_${attr_name}",
 165                             domain_model => $dm_name,
 166                             orig_attr_name => $attr_name,
 167                           );
 168           $meta->add_attribute( $attr_name, %attr_opts);
 169
 170           #proper collections will remove the result_class uglyness.
 171           my $build_method = sub {
 172             my $rs = shift->$dm_name->result_source
 173               ->related_source("links_to_${mm_name}_list")
 174                 ->related_source(${mm_name})
 175                   ->resultset->search_rs
 176                     ({},{result_class => $rel_attrs{$attr_name} });
 177             return bless($rs => Collection);
 178           };
 179           $meta->remove_method( "build_${attr_name}");
 180           $meta->add_method( "build_${attr_name}", $build_method);
 181         }
 182       }
 183     };
 184     return %exports;
 185   };
 186 };
 187
 188
 189 sub reflect_action{
 190   my($self, $meta, $action_class, $super, $attrs) = @_;
 191
 192   Class::MOP::load_class($_) for @$super;
 193
 194   #create the class
 195   my $ok = eval { Class::MOP::load_class($action_class) };
 196
 197   confess("Class '${action_class}' does not seem to support method 'meta'")
 198     if $ok && !$action_class->can('meta');
 199
 200   my $action_meta = $ok ?
 201     $action_class->meta : ActionClass->create($action_class, superclasses => $super);
 202
 203   $action_meta->make_mutable if $action_meta->is_immutable;
 204
 205   foreach my $attr_name (@$attrs){
 206     my $attr = $meta->find_attribute_by_name($attr_name);
 207     my $dm_isa = $meta->find_attribute_by_name($attr->domain_model)->_isa_metadata;
 208     my $from_attr = $dm_isa->meta->find_attribute_by_name($attr->orig_attr_name);
 209
 210     #Don't reflect read-only attributes to actions
 211     if ($from_attr->_is_metadata ne 'rw') {
 212       warn("Not relecting read-only attribute ${attr_name} to ${action_class}");
 213       next;
 214     }
 215
 216     #add the attribute to the class
 217     $action_class->meta->add_attribute
 218       ( $attr_name =>
 219         $self->reflected_attr_opts($meta, $dm_isa, $from_attr)
 220       );
 221   }
 222
 223   $action_class->meta->make_immutable;
 224 }
 225
 226 sub reflected_attr_opts{
 227   my ($self, $meta, $dm, $attr) = @_;
 228   my $attr_name = $attr->name;
 229
 230   my %opts = (
 231               is        => 'rw',
 232               isa       => $attr->_isa_metadata,
 233               required  => $attr->is_required,
 234               predicate => "has_${attr_name}",
 235              );
 236
 237   if ($opts{required}) {
 238     $opts{default} = !$attr->has_default ?
 239       sub{confess("${attr_name} must be provided before calling reader")}
 240         : $attr->default;
 241     $opts{lazy} = 1;
 242   }
 243
 244   #test for relationships
 245   my $source = $dm->result_source_instance;
 246   my $constraint = $attr->type_constraint;
 247   if (my $info = $source->relationship_info($attr_name)) {
 248     if ( $info->{attrs}->{accessor} &&
 249          $info->{attrs}->{accessor} eq 'multi') {
 250       confess "${attr_name} is multi and rw. we are confoos.";
 251     } else {
 252       $opts{valid_values} = sub {
 253         $_[0]->target_model->result_source
 254           ->related_source($attr_name)->resultset;
 255       };
 256     }
 257   } elsif ($constraint->name eq 'ArrayRef' ||
 258            $constraint->is_subtype_of('ArrayRef')) {
 259     # it's a many-many. time for some magic.
 260     my $link_rel = "links_to_${attr_name}";
 261     my ($mm_name) = ($attr_name =~ m/^(.*)_list$/);
 262     confess "Many-many attr must be called <name>_list for reflection"
 263       unless $mm_name;
 264
 265     my ($hm_source, $far_side);
 266     eval { $hm_source = $source->related_source($link_rel); }
 267       || confess "Can't find ${link_rel} has_many for ${attr_name}";
 268     eval { $far_side = $hm_source->related_source($mm_name); }
 269       || confess "Can't find ${mm_name} belongs_to on " .
 270         $hm_source->result_class." traversing many-many for ${attr_name}";
 271
 272     $opts{default} = sub { [] };
 273     $opts{valid_values} = sub {
 274       $_[0]->target_model->result_source->related_source($link_rel)
 275         ->related_source($mm_name)->resultset;
 276     };
 277   }
 278
 279   return \%opts;
 280 }
 281
 282 1;
 283
 284 =head1 NAME
 285
 286 Reaction::InterfaceModel::DBIC::ObjectClass
 287
 288 =head1 SYNOPSIS
 289
 290 =head2 domain_model
 291
 292     package Prefab::AdminModel::User;
 293
 294     class User, is Object, which{
 295         #create an attribute _user_store with type constraint MyApp::DB::User
 296         domain_model '_user_store' =>
 297             (isa => 'MyApp::DB::User',
 298              #mirror the following attributes from MyApp::DB::User
 299              #will create collections for rels which use result_classes of:
 300              # Prefab::AdminModel::(Group|ImagedDocument)
 301              # Prefab::AdminModel::DocumentNotes
 302              reflect => [qw/id username password created_d group_list imaged_document/,
 303                          [doc_notes_list => 'Prefab::AdminModel::DocumentNotes']
 304                         ],
 305              #automatically add a sub inflate_result that inflates the DBIC obj
 306              #to a Prefab::AdminModel::User with the dbic obj in _user_store
 307              inflate_result => 1,
 308             );
 309     };
 310
 311 =head2 reflect_actions
 312
 313   reflect_actions
 314     (
 315      Create => { attrs =>[qw(first_name last_name baz_list)] },
 316      Update => { attrs =>[qw(first_name last_name baz_list)] },
 317      Delete => {},
 318     );
 319
 320 =head1 DESCRIPTION
 321
 322 =head1 ATTRIBUTES
 323
 324 =head2 isa
 325
 326 =head2 reflect
 327
 328 =head2 inflate_result
 329
 330 =head2 handles
 331
 332 =head1 METHODS
 333
 334 =head2 reflect_actions
 335
 336 =head1 AUTHORS
 337
 338 See L<Reaction::Class> for authors.
 339
 340 =head1 LICENSE
 341
 342 See L<Reaction::Class> for the license.
 343
 344 =cut