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