1package CatalystX::Component::Traits;
2{
3  $CatalystX::Component::Traits::VERSION = '0.19';
4}
5
6use namespace::autoclean;
7use Moose::Role;
8use Carp;
9use List::MoreUtils qw/firstidx any uniq/;
10use Scalar::Util 'reftype';
11use Class::Load qw/ load_first_existing_class /;
12with 'MooseX::Traits::Pluggable' => { -excludes => ['_find_trait'] };
13
14=head1 NAME
15
16CatalystX::Component::Traits - Automatic Trait Loading and Resolution for Catalyst Components
17
18=cut
19
20our $AUTHORITY = 'id:RKITOVER';
21
22=head1 SYNOPSIS
23
24    package Catalyst::Model::SomeModel;
25    with 'CatalystX::Component::Traits';
26
27    package MyApp::Model::MyModel;
28    use parent 'Catalyst::Model::SomeModel';
29
30    package MyApp;
31
32    __PACKAGE__->config('Model::MyModel' => {
33        traits => ['SearchedForTrait', '+Fully::Qualified::Trait']
34    });
35
36=head1 DESCRIPTION
37
38Adds a L<Catalyst::Component/COMPONENT> method to your L<Catalyst> component
39base class that reads the optional C<traits> parameter from app and component
40config and instantiates the component subclass with those traits using
41L<MooseX::Traits/new_with_traits> from L<MooseX::Traits::Pluggable>.
42
43=head1 TRAIT SEARCH
44
45Trait names qualified with a C<+> are taken to be full package names.
46
47Unqualified names are searched for, using the algorithm described below.
48
49=head2 EXAMPLE
50
51Suppose your inheritance hierarchy is:
52
53    MyApp::Model::MyModel
54    Catalyst::Model::CatModel
55    Catalyst::Model
56    Catalyst::Component
57    Moose::Object
58
59The configuration is:
60
61    traits => ['Foo']
62
63The package search order for C<Foo> will be:
64
65    MyApp::TraitFor::Model::CatModel::Foo
66    Catalyst::TraitFor::Model::CatModel::Foo
67
68=head2 A MORE PATHOLOGICAL EXAMPLE
69
70For:
71
72    My::App::Controller::AController
73    CatalystX::Something::ControllerBase::SomeController
74    Catalyst::Controller
75    Catalyst::Model
76    Catalyst::Component
77    Moose::Object
78
79With:
80
81    traits => ['Foo']
82
83Search order for C<Foo> will be:
84
85    My::App::TraitFor::Controller::SomeController::Foo
86    CatalystX::Something::TraitFor::Controller::SomeController::Foo
87
88The C<Base> after (M|V|C) is automatically removed.
89
90=head1 TRAIT MERGING
91
92Traits from component class config and app config are automatically merged if
93you set the C<_trait_merge> attribute default, e.g.:
94
95    has '+_trait_merge' => (default => 1);
96
97You can remove component class config traits by prefixing their names with a
98C<-> in the app config traits.
99
100For example:
101
102    package Catalyst::Model::Foo;
103    has '+_trait_merge' => (default => 1);
104    __PACKAGE__->config->{traits} = [qw/Foo Bar/];
105
106    package MyApp;
107    __PACKAGE__->config->{'Model::Foo'}{traits} = [qw/-Foo Baz/];
108
109Will load the traits:
110
111    Bar Baz
112
113=cut
114
115# override MX::Traits attribute
116has '_trait_namespace' => (
117    init_arg => undef,
118    isa      => 'Str',
119    (Moose->VERSION >= 0.84 ) ? (is => 'bare') : (),
120    default  => '+Trait',
121);
122
123has '_trait_merge' => (
124    init_arg => undef,
125    isa      => 'Str',
126    (Moose->VERSION >= 0.84 ) ? (is => 'bare') : (),
127    default  => 0,
128);
129
130sub COMPONENT {
131    my ($class, $app, $args) = @_;
132
133    my %class_config = %{ $class->config };
134    my %app_config   = %$args;
135
136    my $traits = $class->_merge_traits(
137        delete $class_config{traits},
138        delete $app_config{traits},
139    );
140
141    $args = $class->merge_config_hashes(\%class_config, \%app_config);
142
143    if ($traits) {
144        return $class->new_with_traits($app, {
145            traits => $traits,
146            %$args
147        });
148    }
149
150    return $class->new($app, $args);
151}
152
153sub _merge_traits {
154    my $class        = shift;
155    my $left_traits  = shift || [];
156    my $right_traits = shift || [];
157
158    my $should_merge =
159        eval { $class->meta->find_attribute_by_name('_trait_merge')->default };
160    $should_merge = $should_merge->()
161        if ref($should_merge) && reftype($should_merge) eq 'CODE';
162
163    my @right_traits = ref($right_traits) ? @$right_traits : $right_traits;
164    my @left_traits  = ref($left_traits)  ? @$left_traits  : $left_traits;
165    unless ($should_merge) {
166        return @right_traits ? \@right_traits : \@left_traits;
167    }
168
169    my @to_remove = map { /^-(.*)/ ? $1 : () } @left_traits, @right_traits;
170    @left_traits  = grep !/^-/, @left_traits;
171    @right_traits = grep !/^-/, @right_traits;
172
173    my @traits = grep {
174        my $trait = $_;
175        not any { $trait eq $_ } @to_remove;
176    } (@left_traits, @right_traits);
177
178    return [ uniq @traits ];
179}
180
181sub _find_trait {
182    my ($class, $base, $name) = @_;
183
184    load_first_existing_class($class->_trait_search_order($base, $name));
185}
186
187sub _trait_search_order {
188    my ($class, $base, $name) = @_;
189
190    my @search_ns = $class->meta->class_precedence_list;
191
192    my $MVCC = qr/(?:Model|View|Controller|Component)/;
193
194    my $possible_parent_idx =
195        (firstidx { /^CatalystX?::/ } @search_ns[1 ..  $#search_ns]) + 1;
196
197    my ($parent, $parent_idx, $parent_name, $parent_name_partial);
198
199    for my $try_parent ($possible_parent_idx, 0) {
200        $parent_idx = $try_parent;
201        $parent     = $search_ns[$parent_idx];
202
203        ($parent_name, $parent_name_partial) =
204            $parent =~ /($MVCC(?:Base)? (?: ::)? (.*))/x;
205
206        last if $parent_name_partial; # otherwise root level component
207    }
208
209    (my $resolved_parent_name = $parent_name) =~ s/($MVCC)Base\b/$1/;
210
211    my ($parent_part) = $parent =~ /($MVCC) (?:Base)? (?: ::)?/x;
212
213    my @res;
214
215    for my $ns (@search_ns[0 .. $parent_idx]) {
216        my $find_part = $parent_part;
217
218        my ($part) = $ns =~ /^(.+?)::$parent_part/;
219        push @res, "${part}::${base}For::${resolved_parent_name}::$name";
220    }
221
222    @res;
223}
224
225# we'll come back to this later...
226#    for my $ns (@search_ns[($parent_idx+1) .. $#search_ns]) {
227#       my ($part, $rest) = split /::/, $ns, 2;
228#
229#       # no non-core crap in the Moose:: namespace
230#       $part = 'MooseX' if $part eq 'Moose';
231#
232#       push @res, "${part}::${base}For::${rest}::$name";
233#    }
234#
235#    @res;
236#}
237
238=head1 AUTHOR
239
240Rafael Kitover, C<< <rkitover@cpan.org> >>
241
242=head1 CONTRIBUTORS
243
244Tomas Doran, C<< <bobtfish@bobtfish.net> >>
245
246=head1 BUGS
247
248Please report any bugs or feature requests to C<bug-catalystx-component-traits
249at rt.cpan.org>, or through the web interface at
250L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-Component-Traits>.  I
251will be notified, and then you'll automatically be notified of progress on your
252bug as I make changes.
253
254=head1 ACKNOWLEDGEMENTS
255
256Matt S. Trout and Tomas Doran helped me with the current design.
257
258=head1 COPYRIGHT & LICENSE
259
260Copyright (c) 2014, Rafael Kitover
261
262This program is free software; you can redistribute it and/or modify it
263under the same terms as Perl itself.
264
265=cut
266
267__PACKAGE__; # End of CatalystX::Component::Traits
268