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