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