lib/Reaction/InterfaceModel/Reflector/DBIC.pm

   1 package Reaction::InterfaceModel::Reflector::DBIC;
   2
   3 use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create';
   4 use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::DeleteAll';
   5 use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update';
   6 use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete';
   7
   8 use aliased 'Reaction::InterfaceModel::Collection::Virtual::ResultSet';
   9 use aliased 'Reaction::InterfaceModel::Object';
  10 use aliased 'Reaction::InterfaceModel::Action';
  11 use Reaction::Class;
  12 use Class::MOP;
  13
  14 use Catalyst::Utils;
  15
  16 class DBIC, which {
  17
  18   has make_classes_immutable => (isa => "Bool", is => "rw", required => 1, default => sub{ 1 });
  19
  20   #user defined actions and prototypes
  21   has object_actions     => (isa => "HashRef", is => "rw", lazy_build => 1);
  22   has collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1);
  23
  24   #which actions to create by default
  25   has default_object_actions     => (isa => "ArrayRef", is => "rw", lazy_build => 1);
  26   has default_collection_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1);
  27
  28   #builtin actions and prototypes
  29   has builtin_object_actions     => (isa => "HashRef", is => "rw", lazy_build => 1);
  30   has builtin_collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1);
  31
  32   implements _build_object_actions     => as { {} };
  33   implements _build_collection_actions => as { {} };
  34
  35   implements _build_default_object_actions     => as { [ qw/Update Delete/ ] };
  36   implements _build_default_collection_actions => as { [ qw/Create DeleteAll/ ] };
  37
  38   implements _build_builtin_object_actions => as {
  39     {
  40       Update => { name => 'Update', base => Update },
  41       Delete => { name => 'Delete', base => Delete, attributes => [] },
  42     };
  43   };
  44
  45   implements _build_builtin_collection_actions => as {
  46     {
  47       Create    => {name => 'Create',    base => Create    },
  48       DeleteAll => {name => 'DeleteAll', base => DeleteAll, attributes => [] }
  49     };
  50   };
  51
  52   implements _all_object_actions => as {
  53    my $self = shift;
  54     return $self->merge_hashes
  55       ($self->builtin_object_actions, $self->object_actions);
  56   };
  57
  58   implements _all_collection_actions => as {
  59     my $self = shift;
  60     return $self->merge_hashes
  61       ($self->builtin_collection_actions, $self->collection_actions);
  62   };
  63
  64   implements dm_name_from_class_name => as {
  65     my($self, $class) = @_;
  66     confess("wrong arguments") unless $class;
  67     $class =~ s/::/_/g;
  68     $class = "_" . lc($class) . "_store";
  69     return $class;
  70   };
  71
  72   implements dm_name_from_source_name => as {
  73     my($self, $source) = @_;
  74     confess("wrong arguments") unless $source;
  75     $source =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
  76     $source = "_" . lc($source) . "_store";
  77     return $source;
  78   };
  79
  80   implements class_name_from_source_name => as {
  81     my ($self, $model_class, $source_name) = @_;
  82     confess("wrong arguments") unless $model_class && $source_name;
  83     return join "::", $model_class, $source_name;
  84   };
  85
  86   implements class_name_for_collection_of => as {
  87     my ($self, $object_class) = @_;
  88     confess("wrong arguments") unless $object_class;
  89     return "${object_class}::Collection";
  90   };
  91
  92   implements merge_hashes => as {
  93     my($self, $left, $right) = @_;
  94     return Catalyst::Utils::merge_hashes($left, $right);
  95   };
  96
  97   implements parse_reflect_rules => as {
  98     my ($self, $rules, $haystack) = @_;
  99     confess('$rules must be an array reference')    unless ref $rules    eq 'ARRAY';
 100     confess('$haystack must be an array reference') unless ref $haystack eq 'ARRAY';
 101
 102     my $needles = {};
 103     my (@exclude, @include, $global_opts);
 104     if(@$rules == 2 && $rules->[0] eq '-exclude'){
 105       push(@exclude, (ref $rules->[1] eq 'ARRAY' ? @{$rules->[1]} : $rules->[1]));
 106     } else {
 107       for my $rule ( @$rules ){
 108         if (ref $rule eq 'ARRAY' && $rule->[0] eq '-exclude'){
 109           push(@exclude, (ref $rule->[1] eq 'ARRAY' ? @{$rule->[1]} : $rule->[1]));
 110         } elsif( ref $rule eq 'HASH' ){
 111           $global_opts = ref $global_opts eq 'HASH' ?
 112             $self->merge_hashes($global_opts, $rule) : $rule;
 113         } else {
 114           push(@include, $rule);
 115         }
 116       }
 117     }
 118     my $check_exclude = sub{
 119       for my $rule (@exclude){
 120         return 1 if(ref $rule eq 'Regexp' ? $_[0] =~ /$rule/ : $_[0] eq $rule);
 121       }
 122       return;
 123     };
 124
 125     @$haystack = grep { !$check_exclude->($_) } @$haystack;
 126     $self->merge_reflect_rules(\@include, $needles, $haystack, $global_opts);
 127     return $needles;
 128   };
 129
 130   implements merge_reflect_rules => as {
 131     my ($self, $rules, $needles, $haystack, $local_opts) = @_;
 132     for my $rule ( @$rules ){
 133       if(!ref $rule && ( grep {$rule eq $_} @$haystack ) ){
 134         $needles->{$rule} = defined $needles->{$rule} ?
 135           $self->merge_hashes($needles->{$rule}, $local_opts) : $local_opts;
 136       } elsif( ref $rule eq 'Regexp' ){
 137         for my $match ( grep { /$rule/ } @$haystack ){
 138           $needles->{$match} = defined $needles->{$match} ?
 139             $self->merge_hashes($needles->{$match}, $local_opts) : $local_opts;
 140         }
 141       } elsif( ref $rule eq 'ARRAY' ){
 142         my $opts;
 143         $opts = pop(@$rule) if @$rule > 1 and ref $rule->[$#$rule] eq 'HASH';
 144         $opts = $self->merge_hashes($local_opts, $opts) if defined $local_opts;
 145         $self->merge_reflect_rules($rule, $needles, $haystack, $opts);
 146       }
 147     }
 148   };
 149
 150   implements reflect_schema => as {
 151     my ($self, %opts) = @_;
 152     my $base    = delete $opts{base} || Object;
 153     my $model   = delete $opts{model_class};
 154     my $schema  = delete $opts{schema_class};
 155     my $dm_name = delete $opts{domain_model_name};
 156     my $dm_args = delete $opts{domain_model_args} || {};
 157     $dm_name ||= $self->dm_name_from_class_name($schema);
 158
 159     #load all necessary classes
 160     confess("model_class and schema_class are required parameters")
 161       unless($model && $schema);
 162     Class::MOP::load_class( $base );
 163     Class::MOP::load_class( $schema );
 164     my $meta = $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          my $self = $_[0];
 336          return $collection->new(
 337            _source_resultset => $self->$dm_name->resultset($source),
 338            _parent => $self,
 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                       model_class       => $opts{parent_class},
 366                       source_name       => $opts{source_name},
 367                       domain_model_name => $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
 656     #default options. lazy build but no outsider method
 657     my %attr_opts = ( is => 'ro', lazy => 1, required => 1,
 658                       clearer   => "_clear_${attr_name}",
 659                       predicate => "has_${attr_name}",
 660                       domain_model   => $dm_name,
 661                       orig_attr_name => $attr_name,
 662                     );
 663
 664     #m2m / has_many
 665     my $constraint_is_ArrayRef =
 666       $from_attr->type_constraint->name eq 'ArrayRef' ||
 667         $from_attr->type_constraint->is_subtype_of('ArrayRef');
 668
 669     if( my $rel_info = $source->relationship_info($attr_name) ){
 670       my $rel_accessor = $rel_info->{attrs}->{accessor};
 671       my $rel_moniker  = $rel_info->{class}->result_source_instance->source_name;
 672
 673       if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 674         #has_many
 675         my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker);
 676         #type constraint is a collection, and default builds it
 677         $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 678         $attr_opts{default} = sub {
 679           my $rs = shift->$dm_name->related_resultset($attr_name);
 680           return $attr_opts{isa}->new(_source_resultset => $rs);
 681         };
 682       } elsif( $rel_accessor eq 'single') {
 683         #belongs_to
 684         #type constraint is the foreign IM object, default inflates it
 685         $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
 686         $attr_opts{default} = sub {
 687           shift->$dm_name
 688             ->find_related($attr_name, {},{result_class => $attr_opts{isa}});
 689         };
 690       }
 691     } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
 692       #m2m magic
 693       my $mm_name = $1;
 694       my $link_table = "links_to_${mm_name}_list";
 695       my ($hm_source, $far_side);
 696       eval { $hm_source = $source->related_source($link_table); }
 697         || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 698       eval { $far_side = $hm_source->related_source($mm_name); }
 699         || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 700           ." traversing many-many for ${mm_name}_list";
 701
 702       my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name);
 703       $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 704
 705       #proper collections will remove the result_class uglyness.
 706       $attr_opts{default} = sub {
 707         my $rs = shift->$dm_name->related_resultset($link_table)->related_resultset($mm_name);
 708         return $attr_opts{isa}->new(_source_resultset => $rs);
 709       };
 710     } else {
 711       #no rel
 712       my $reader = $from_attr->get_read_method;
 713       $attr_opts{isa} = $from_attr->_isa_metadata;
 714       $attr_opts{default} = sub{ shift->$dm_name->$reader };
 715     }
 716     return \%attr_opts;
 717   };
 718
 719
 720   implements reflect_source_action => as{
 721     my($self, %opts) = @_;
 722     my $name   = delete $opts{name};
 723     my $class  = delete $opts{class};
 724     my $base   = delete $opts{base} || Action;
 725     my $object = delete $opts{object_class};
 726     my $source = delete $opts{source_class};
 727
 728     confess("name, object_class and source_class are required arguments")
 729       unless $source && $name && $object;
 730
 731     my $attr_rules = delete $opts{attributes};
 732     $class ||= $object->_default_action_class_for($name);
 733
 734     Class::MOP::load_class( $base   );
 735     Class::MOP::load_class( $object );
 736     Class::MOP::load_class( $source );
 737
 738     #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n";
 739     # attributes => undef,              #default to qr/./
 740     # attributes => [],                 #default to nothing
 741     # attributes => qr//,               #DWIM, treated as [qr//]
 742     # attributes => [{...}]             #DWIM, treat as [qr/./, {...} ]
 743     # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
 744     my $attr_haystack = [ map { $_->name } $object->meta->parameter_attributes ];
 745     if(!defined $attr_rules){
 746       $attr_rules = [qr/./];
 747     } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
 748       $attr_rules = [ $attr_rules ];
 749     } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
 750       #don't add a qr/./ rule if we have at least one match rule
 751       push(@$attr_rules, qr/./) unless
 752         grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
 753                 || !ref $_  || ref $_ eq 'Regexp'} @$attr_rules;
 754     }
 755
 756     #print STDERR "${name}\t${class}\t${base}\n";
 757     #print STDERR "\t${object}\t${source}\n";
 758     #print STDERR "\t",@$attr_rules,"\n";
 759
 760     my $o_meta = $object->meta;
 761     my $s_meta = $source->meta;
 762     my $attributes  = $self->parse_reflect_rules($attr_rules, $attr_haystack);
 763
 764     #create the class
 765     my $meta = $self->_load_or_create($class, $base);
 766     my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;
 767     $meta->make_mutable if $meta->is_immutable;
 768
 769     for my $attr_name (keys %$attributes){
 770       my $attr_opts   = $attributes->{$attr_name} || {};
 771       my $o_attr      = $o_meta->find_attribute_by_name($attr_name);
 772       my $s_attr_name = $o_attr->orig_attr_name || $attr_name;
 773       my $s_attr      = $s_meta->find_attribute_by_name($s_attr_name);
 774       confess("Unable to find attribute for '${s_attr_name}' via '${source}'")
 775         unless defined $s_attr;
 776       next unless $s_attr->get_write_method; #only rw attributes!
 777
 778       my $attr_params = $self->parameters_for_source_object_action_attribute
 779         (
 780          object_class   => $object,
 781          source_class   => $source,
 782          attribute_name => $attr_name
 783         );
 784       $meta->add_attribute( $attr_name => %$attr_params);
 785     }
 786
 787     $meta->make_immutable if $make_immutable;
 788     return $meta;
 789   };
 790
 791   implements parameters_for_source_object_action_attribute => as {
 792     my ($self, %opts) = @_;
 793
 794     my $object       = delete $opts{object_class};
 795     my $attr_name    = delete $opts{attribute_name};
 796     my $source_class = delete $opts{source_class};
 797     confess("object_class and attribute_name are required parameters")
 798       unless $attr_name && $object;
 799
 800     my $o_meta  = $object->meta;
 801     my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model;
 802     $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
 803     my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
 804
 805     confess("${attr_name} is not writeable and can not be reflected")
 806       unless $from_attr->get_write_method;
 807
 808     my %attr_opts = (
 809                      is        => 'rw',
 810                      isa       => $from_attr->_isa_metadata,
 811                      required  => $from_attr->is_required,
 812                      ($from_attr->is_required
 813                        ? () : (clearer => "clear_$attr_name}")),
 814                      predicate => "has_${attr_name}",
 815                     );
 816
 817     if ($attr_opts{required}) {
 818         if($from_attr->has_default) {
 819           $attr_opts{lazy} = 1;
 820           $attr_opts{default} = $from_attr->default;
 821         } else {
 822           $attr_opts{lazy_fail} = 1;
 823         }
 824     }
 825
 826     #test for relationships
 827     my $constraint_is_ArrayRef =
 828       $from_attr->type_constraint->name eq 'ArrayRef' ||
 829         $from_attr->type_constraint->is_subtype_of('ArrayRef');
 830
 831     my $source = $source_class->result_source_instance;
 832     if (my $rel_info = $source->relationship_info($attr_name)) {
 833       my $rel_accessor = $rel_info->{attrs}->{accessor};
 834
 835       if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
 836         confess "${attr_name} is a rw has_many, this won't work.";
 837       } elsif( $rel_accessor eq 'single') {
 838         $attr_opts{valid_values} = sub {
 839           shift->target_model->result_source->related_source($attr_name)->resultset;
 840         };
 841       }
 842     } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
 843       my $mm_name = $1;
 844       my $link_table = "links_to_${mm_name}_list";
 845       my ($hm_source, $far_side);
 846       eval { $hm_source = $source->related_source($link_table); }
 847         || confess "Can't find ${link_table} has_many for ${mm_name}_list";
 848       eval { $far_side = $hm_source->related_source($mm_name); }
 849         || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
 850           ." traversing many-many for ${mm_name}_list";
 851
 852       $attr_opts{default} = sub { [] };
 853       $attr_opts{valid_values} = sub {
 854         shift->target_model->result_source->related_source($link_table)
 855           ->related_source($mm_name)->resultset;
 856       };
 857     }
 858     #use Data::Dumper;
 859     #print STDERR "\n" .$attr_name ." - ". $object . "\n";
 860     #print STDERR Dumper(\%attr_opts);
 861     return \%attr_opts;
 862   };
 863
 864   implements _load_or_create => as {
 865     my ($self, $class, $base) = @_;
 866     my $meta = $self->_maybe_load_class($class) ?
 867       $class->meta : $base->meta->create($class, superclasses => [ $base ]);
 868     return $meta;
 869   };
 870
 871   implements _maybe_load_class => as {
 872     my ($self, $class) = @_;
 873     my $file = $class . '.pm';
 874     $file =~ s{::}{/}g;
 875     my $ret = eval { Class::MOP::load_class($class) };
 876     if ($INC{$file} && $@) {
 877       confess "Error loading ${class}: $@";
 878     }
 879     return $ret;
 880   };
 881
 882 };
 883
 884 1;
 885
 886 #--------#---------#---------#---------#---------#---------#---------#---------#
 887 __END__;
 888
 889 =head1 NAME
 890
 891 Reaction::InterfaceModel::Reflector::DBIC -
 892 Automatically Generate InterfaceModels from DBIx::Class models
 893
 894 =head1 DESCRIPTION
 895
 896 The InterfaceModel reflectors are classes that are meant to aid you in easily
 897 generating Reaction::InterfaceModel classes that represent their underlying
 898 DBIx::Class domain models by introspecting your L<DBIx::Class::ResultSource>s
 899 and creating a collection of L<Reaction::InterfaceModel::Object> and
 900 L<Reaction::InterfaceModel::Collection> classes for you to use.
 901
 902 The default base class of all Object classes will be
 903  L<Reaction::InterfaceModel::Object> and the default Collection type will be
 904 L<Reaction::InterfaceModel::Collection::Virtual::ResultSet>.
 905
 906 Additionally, the reflector can create InterfaceModel actions that interact
 907 with the supplied L<Reaction::UI::Controller::Collection::CRUD>, allowing you
 908 to easily set up a highly customizable CRUD interface in minimal time.
 909
 910 At this time, supported collection actions consist of:
 911
 912 =over 4
 913
 914 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::Create>
 915
 916 Creates a new item in the collection and underlying ResultSet.
 917
 918 =item B<> L<Reaction::INterfaceModel::Action::DBIC::ResultSet::DeleteAll>
 919
 920 Deletes all the items in a collection and it's underlying resultset using
 921 C<delete_all>
 922
 923 =back
 924
 925 And supported object actions are :
 926
 927 =over 4
 928
 929 =item B<Update> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Update>
 930
 931 Updates an existing object.
 932
 933 =item B<Delete> - via L<Reaction::INterfaceModel::Action::DBIC::Result::Delete>
 934
 935 Deletes an existing object.
 936
 937 =back
 938
 939 =head1 SYNOPSIS
 940
 941     package MyApp::IM::TestModel;
 942     use base 'Reaction::InterfaceModel::Object';
 943     use Reaction::Class;
 944     use Reaction::InterfaceModel::Reflector::DBIC;
 945     my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
 946
 947     #Reflect everything
 948     $reflector->reflect_schema
 949       (
 950        model_class  => __PACKAGE__,
 951        schema_class => 'MyApp::Schema',
 952       );
 953
 954 =head2 Selectively including and excluding sources
 955
 956     #reflect everything except for the FooBar and FooBaz classes
 957     $reflector->reflect_schema
 958       (
 959        model_class  => __PACKAGE__,
 960        schema_class => 'MyApp::Schema',
 961        sources => [-exclude => [qw/FooBar FooBaz/] ],
 962        # you could also do:
 963        sources => [-exclude => qr/(?:FooBar|FooBaz)/,
 964        # or even
 965        sources => [-exclude => [qr/FooBar/, qr/FooBaz/],
 966       );
 967
 968     #reflect only the Foo family of sources
 969     $reflector->reflect_schema
 970       (
 971        model_class  => __PACKAGE__,
 972        schema_class => 'MyApp::Schema',
 973        sources => qr/^Foo/,
 974       );
 975
 976 =head2 Selectively including and excluding fields in sources
 977
 978     #Reflect Foo and Baz in their entirety and exclude the field 'avatar' in the Bar ResultSource
 979     $reflector->reflect_schema
 980       (
 981        model_class  => __PACKAGE__,
 982        schema_class => 'MyApp::Schema',
 983        sources => [qw/Foo Baz/,
 984                    [ Bar => {attributes => [[-exclude => 'avatar']] } ],
 985                    # or exclude by regex
 986                    [ Bar => {attributes => [-exclude => qr/avatar/] } ],
 987                    # or simply do not include it...
 988                    [ Bar => {attributes => [qw/id name description/] } ],
 989                   ],
 990       );
 991
 992 =head1 ATTRIBUTES
 993
 994 =head2 make_classes_immutable
 995
 996 =head2 object_actions
 997
 998 =head2 collection_actions
 999
1000 =head2 default_object_actions
1001
1002 =head2 default_collection_actions
1003
1004 =head2 builtin_object_actions
1005
1006 =head2 builtin_collection_actions
1007
1008 =head1 METHODS
1009
1010 =head2 new
1011
1012 =head2 _all_object_actions
1013
1014 =head2 _all_collection_actions
1015
1016 =head2 dm_name_from_class_name
1017
1018 =head2 dm_name_from_source_name
1019
1020 =head2 class_name_from_source_name
1021
1022 =head2 class_name_for_collection_of
1023
1024 =head2 merge_hashes
1025
1026 =head2 parse_reflect_rules
1027
1028 =head2 merge_reflect_rules
1029
1030 =head2 reflect_schema
1031
1032 =head2 _compute_source_options
1033
1034 =head2 add_source
1035
1036 =head2 reflect_source
1037
1038 =head2 reflect_source_collection
1039
1040 =head2 reflect_source_object
1041
1042 =head2 reflect_source_object_attribute
1043
1044 =head2 parameters_for_source_object_attribute
1045
1046 =head2 reflect_source_action
1047
1048 =head2 parameters_for_source_object_action_attribute
1049
1050 =head1 TODO
1051
1052 Allow the reflector to dump the generated code out as files, eliminating the need to
1053 reflect on startup every time. This will likely take quite a bit of work though. The
1054 main work is already in place, but the grunt work is still left. At the moment there
1055 is no closures that can't be dumped out as code with a little bit of work.
1056
1057 =head1 AUTHORS
1058
1059 See L<Reaction::Class> for authors.
1060
1061 =head1 LICENSE
1062
1063 See L<Reaction::Class> for the license.
1064
1065 =cut