lib/Catalyst/TraitFor/Model/DBIC/Schema/SchemaProxy.pm

   1 package Catalyst::TraitFor::Model::DBIC::Schema::SchemaProxy;
   2
   3 use namespace::autoclean;
   4 use Moose::Role;
   5 use Carp::Clan '^Catalyst::Model::DBIC::Schema';
   6
   7 =head1 NAME
   8
   9 Catalyst::TraitFor::Model::DBIC::Schema::SchemaProxy - Proxy Schema Methods and
  10 Options from Model
  11
  12 =head1 DESCRIPTION
  13
  14 Allows you to call L<DBIx::Class::Schema> methods directly on the Model
  15 instance, and passes config options to the L<DBIx::Class::Schema> attributes at
  16 C<BUILD> time.
  17
  18 This trait is loaded by default, but can be disabled by adding C<-SchemaProxy>
  19 to the L<Catalyst::Model::DBIC::Schema/traits> array.
  20
  21 =cut
  22
  23 after setup => sub {
  24     my ($self, $args) = @_;
  25
  26     my $was_mutable = $self->meta->is_mutable;
  27
  28     $self->meta->make_mutable;
  29     $self->meta->add_attribute('schema',
  30         is => 'rw',
  31         isa => 'DBIx::Class::Schema',
  32         handles => $self->_delegates # this removes the attribute too
  33     );
  34     $self->meta->make_immutable unless $was_mutable;
  35 };
  36
  37 after BUILD => sub {
  38     my ($self, $args) = @_;
  39
  40     $self->_pass_options_to_schema($args);
  41 };
  42
  43 sub _delegates {
  44     my $self = shift;
  45
  46     my $schema_meta = Class::MOP::Class->initialize($self->schema_class);
  47     my @schema_methods = $schema_meta->get_all_method_names;
  48
  49 # combine with any already added by other schemas
  50     my @handles = eval {
  51         @{ $self->meta->find_attribute_by_name('schema')->handles }
  52     };
  53
  54 # now kill the attribute, otherwise add_attribute in BUILD will not do the right
  55 # thing (it clears the handles for some reason.) May be a Moose bug.
  56     eval { $self->meta->remove_attribute('schema') };
  57
  58     my %schema_methods;
  59     @schema_methods{ @schema_methods, @handles } = ();
  60     @schema_methods = keys %schema_methods;
  61
  62     my @my_methods = $self->meta->get_all_method_names;
  63     my %my_methods;
  64     @my_methods{@my_methods} = ();
  65
  66     my @delegates;
  67     for my $method (@schema_methods) {
  68         push @delegates, $method unless exists $my_methods{$method};
  69     }
  70
  71     return \@delegates;
  72 }
  73
  74 sub _pass_options_to_schema {
  75     my ($self, $args) = @_;
  76
  77     my @attributes = map {
  78         $_->init_arg || ()
  79     } $self->meta->get_all_attributes;
  80
  81     my %attributes;
  82     @attributes{@attributes} = ();
  83
  84     for my $opt (keys %$args) {
  85         if (not exists $attributes{$opt}) {
  86             next unless $self->schema->can($opt);
  87             $self->schema->$opt($self->{$opt});
  88         }
  89     }
  90 }
  91
  92 =head1 SEE ALSO
  93
  94 L<Catalyst::Model::DBIC::Schema>, L<DBIx::Class::Schema>
  95
  96 =head1 AUTHOR
  97
  98 See L<Catalyst::Model::DBIC::Schema/AUTHOR> and
  99 L<Catalyst::Model::DBIC::Schema/CONTRIBUTORS>.
 100
 101 =head1 COPYRIGHT
 102
 103 See L<Catalyst::Model::DBIC::Schema/COPYRIGHT>.
 104
 105 =head1 LICENSE
 106
 107 This program is free software, you can redistribute it and/or modify it
 108 under the same terms as Perl itself.
 109
 110 =cut
 111
 112 1;