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