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       $attr_opts{lazy} = 1;
 817       $attr_opts{default} = $from_attr->has_default ?
 818         $from_attr->default : sub{};
 819     }
 820
 821     #test for relationships
 822     my $constraint_is_ArrayRef =
 823       $from_attr->type_constraint->name eq 'ArrayRef' ||
 824         $from_attr->type_constraint->is_subtype_of('ArrayRef');
 825
 826     my $source = $source_class->result_source_instance;
 827     if (my $rel_info = $source->relationship_info($attr_name)) {
 828       my $rel_accessor = $rel_info->{attrs}->{accessor};
 829
 830       if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 831         confess "${attr_name} is a rw has_many, this won't work.";
 832       } elsif( $rel_accessor eq 'single') {
 833         $attr_opts{valid_values} = sub {
 834           shift->target_model->result_source->related_source($attr_name)->resultset;
 835         };
 836       }
 837     } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
 838       my $mm_name = $1;
 839       my $link_table = "links_to_${mm_name}_list";
 840       my ($hm_source, $far_side);
 841       eval { $hm_source = $source->related_source($link_table); }
 842         || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 843       eval { $far_side = $hm_source->related_source($mm_name); }
 844         || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 845           ." traversing many-many for ${mm_name}_list";
 846
 847       $attr_opts{default} = sub { [] };
 848       $attr_opts{valid_values} = sub {
 849         shift->target_model->result_source->related_source($link_table)
 850           ->related_source($mm_name)->resultset;
 851       };
 852     }
 853     #use Data::Dumper;
 854     #print STDERR "\n" .$attr_name ." - ". $object . "\n";
 855     #print STDERR Dumper(\%attr_opts);
 856     return \%attr_opts;
 857   };
 858
 859 };
 860
 861 1;
 862
 863 #--------#---------#---------#---------#---------#---------#---------#---------#
 864 __END__;
 865
 866 =head1 NAME
 867
 868 Reaction::InterfaceModel::Reflector::DBIC -
 869 Automatically Generate InterfaceModels from DBIx::Class models
 870
 871 =head1 DESCRIPTION
 872
 873 The InterfaceModel reflectors are classes that are meant to aid you in easily
 874 generating Reaction::InterfaceModel classes that represent their underlying
 875 DBIx::Class domain models by introspecting your L<DBIx::Class::ResultSource>s
 876 and creating a collection of L<Reaction::InterfaceModel::Object> and
 877 L<Reaction::InterfaceModel::Collection> classes for you to use.
 878
 879 The default base class of all Object classes will be
 880  L<Reaction::InterfaceModel::Object> and the default Collection type will be
 881 L<Reaction::InterfaceModel::Collection::Virtual::ResultSet>.
 882
 883 Additionally, the reflector can create InterfaceModel actions that interact
 884 with the supplied L<Reaction::UI::Controller::Collection::CRUD>, allowing you
 885 to easily set up a highly customizable CRUD interface in minimal time.
 886
 887 At this time, supported collection actions consist of:
 888
 889 =over 4
 890
 891 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::Create>
 892
 893 Creates a new item in the collection and underlying ResultSet.
 894
 895 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::DeleteAll>
 896
 897 Deletes all the items in a collection and it's underlying resultset using
 898 C<delete_all>
 899
 900 =back
 901
 902 And supported object actions are :
 903
 904 =over 4
 905
 906 =item B<Update> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Update>
 907
 908 Updates an existing object.
 909
 910 =item B<Delete> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Delete>
 911
 912 Deletes an existing object.
 913
 914 =back
 915
 916 =head1 SYNOPSIS
 917
 918     package MyApp::IM::TestModel;
 919     use base 'Reaction::InterfaceModel::Object';
 920     use Reaction::Class;
 921     use Reaction::InterfaceModel::Reflector::DBIC;
 922     my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
 923
 924     #Reflect everything
 925     $reflector->reflect_schema
 926       (
 927        model_class  => __PACKAGE__,
 928        schema_class => 'MyApp::Schema',
 929       );
 930
 931 =head2 Selectively including and excluding sources
 932
 933     #reflect everything except for the FooBar and FooBaz classes
 934     $reflector->reflect_schema
 935       (
 936        model_class  => __PACKAGE__,
 937        schema_class => 'MyApp::Schema',
 938        sources => [-exclude => [qw/FooBar FooBaz/] ],
 939        # you could also do:
 940        sources => [-exclude => qr/(?:FooBar|FooBaz)/,
 941        # or even
 942        sources => [-exclude => [qr/FooBar/, qr/FooBaz/],
 943       );
 944
 945     #reflect only the Foo family of sources
 946     $reflector->reflect_schema
 947       (
 948        model_class  => __PACKAGE__,
 949        schema_class => 'MyApp::Schema',
 950        sources => qr/^Foo/,
 951       );
 952
 953 =head2 Selectively including and excluding fields in sources
 954
 955     #Reflect Foo and Baz in their entirety and exclude the field 'avatar' in the Bar ResultSource
 956     $reflector->reflect_schema
 957       (
 958        model_class  => __PACKAGE__,
 959        schema_class => 'MyApp::Schema',
 960        sources => [qw/Foo Baz/,
 961                    [ Bar => {attributes => [[-exclude => 'avatar']] } ],
 962                    # or exclude by regex
 963                    [ Bar => {attributes => [-exclude => qr/avatar/] } ],
 964                    # or simply do not include it...
 965                    [ Bar => {attributes => [qw/id name description/] } ],
 966                   ],
 967       );
 968
 969 =head1 ATTRIBUTES
 970
 971 =head2 make_classes_immutable
 972
 973 =head2 object_actions
 974
 975 =head2 collection_actions
 976
 977 =head2 default_object_actions
 978
 979 =head2 default_collection_actions
 980
 981 =head2 builtin_object_actions
 982
 983 =head2 builtin_collection_actions
 984
 985 =head1 METHODS
 986
 987 =head2 new
 988
 989 =head2 _all_object_actions
 990
 991 =head2 _all_collection_actions
 992
 993 =head2 dm_name_from_class_name
 994
 995 =head2 dm_name_from_source_name
 996
 997 =head2 class_name_from_source_name
 998
 999 =head2 class_name_for_collection_of
1000
1001 =head2 merge_hashes
1002
1003 =head2 parse_reflect_rules
1004
1005 =head2 merge_reflect_rules
1006
1007 =head2 reflect_schema
1008
1009 =head2 _compute_source_options
1010
1011 =head2 add_source
1012
1013 =head2 reflect_source
1014
1015 =head2 reflect_source_collection
1016
1017 =head2 reflect_source_object
1018
1019 =head2 reflect_source_object_attribute
1020
1021 =head2 parameters_for_source_object_attribute
1022
1023 =head2 reflect_source_action
1024
1025 =head2 parameters_for_source_object_action_attribute
1026
1027 =head1 TODO
1028
1029 Allow the reflector to dump the generated code out as files, eliminating the need to
1030 reflect on startup every time. This will likely take quite a bit of work though. The
1031 main work is already in place, but the grunt work is still left. At the moment there
1032 is no closures that can't be dumped out as code with a little bit of work.
1033
1034 =head1 AUTHORS
1035
1036 See L<Reaction::Class> for authors.
1037
1038 =head1 LICENSE
1039
1040 See L<Reaction::Class> for the license.
1041
1042 =cut