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