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