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