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