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