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