File Coverage

blib/lib/Code/Style/Kit.pm
Criterion Covered Total %
statement 112 119 94.1
branch 19 26 73.0
condition 11 15 73.3
subroutine 19 19 100.0
pod 3 3 100.0
total 164 182 90.1


line stmt bran cond sub pod time code
1             package Code::Style::Kit;
2 2     2   117323 use strict;
  2         6  
  2         59  
3 2     2   11 use warnings;
  2         5  
  2         51  
4 2     2   895 use Data::OptList;
  2         12321  
  2         14  
5 2     2   997 use Import::Into;
  2         3219  
  2         63  
6 2     2   14 use Carp;
  2         4  
  2         126  
7 2     2   14 use mro ();
  2         5  
  2         52  
8 2     2   908 use Package::Stash qw(get_all_symbols);
  2         10596  
  2         72  
9 2     2   16 use Module::Runtime qw(use_module);
  2         4  
  2         11  
10              
11 2     2   109 use constant DEBUG => $ENV{CODE_STYLE_KIT_DEBUG};
  2         4  
  2         2802  
12              
13             our $VERSION = '1.0.2'; # VERSION
14             # ABSTRACT: build composable bulk exporters
15              
16              
17             sub import {
18 11     11   47621 my $class = shift;
19 11         28 my $caller = caller();
20              
21 11         60 my $self = $class->_new($caller,@_);
22 11         45 $self->_export_features;
23 9         431 return;
24             }
25              
26              
27             sub is_feature_requested {
28 4     4 1 18 my ($self, $feature) = @_;
29 4         19 return !! $self->{requested_features}{$feature};
30             }
31              
32              
33             sub also_export {
34 2     2 1 33 my ($self, $feature, $args) = @_;
35 2   50     12 local $self->{requested_features}{$feature} = $args || [];
36 2         11 $self->_export_one_feature($feature, 1);
37 2         5 return;
38             }
39              
40              
41             sub maybe_also_export {
42 7     7 1 29 my ($self, $feature, $args) = @_;
43 7   100     38 local $self->{requested_features}{$feature} = $args || [];
44 7         24 $self->_export_one_feature($feature, 0);
45 7         19 return;
46             }
47              
48             # private constructor, invoked from C
49             sub _new {
50 11     11   32 my ($class,$caller,@args) = @_;
51              
52             # get all the parts in C<@ISA> order
53 11         34 my $parent_stashes = $class->_get_parent_stashes;
54             # get the features they provide by default
55 11         44 my %feature_set = map { $_ => [] } $class->_default_features($parent_stashes);
  8         34  
56              
57 11         68 my $args = Data::OptList::mkopt(\@args,{
58             moniker => $class,
59             must_be => 'ARRAY',
60             require_unique => 1,
61             });
62             # interpret the import arguments
63 11         668 for my $arg (@{$args}) {
  11         27  
64 10         14 my ($key, $value) = @{$arg};
  10         22  
65              
66 10 50       66 if ($key =~ /^-(\w+)$/) {
    50          
67 0 0       0 if ($value) {
68 0         0 croak "providing import arguments (@{$value}) when removing a feature ($1) makes no sense";
  0         0  
69             }
70 0         0 print STDERR "$class - removing feature $1\n" if DEBUG;
71 0         0 delete $feature_set{$1};
72             }
73             elsif ($key =~ /^\w+$/) {
74 10         17 print STDERR "$class - adding feature $key\n" if DEBUG;
75 10   100     49 $feature_set{$key} = $value // [];
76             }
77             else {
78 0         0 croak "malformed feature <$key> when importing $class";
79             }
80             }
81              
82             # build the instance
83 11         56 return bless {
84             caller => $caller,
85             feature_list => [ $class->_sort_features(keys %feature_set) ],
86             requested_features => \%feature_set,
87             exported_features => {},
88             # we save this, so ->_export_one_feature doesn't have to scan
89             # the parts again
90             parent_stashes => $parent_stashes,
91             }, $class;
92             }
93              
94             sub _export_features {
95 11     11   21 my ($self) = @_;
96              
97 11         15 for my $feature (@{$self->{feature_list}}) {
  11         40  
98 17         42 $self->_export_one_feature($feature, 1);
99             }
100             }
101              
102             # all the magic is from here to the end
103              
104             # the actual exporting
105             sub _export_one_feature {
106 26     26   55 my ($self, $feature, $croak_if_not_implemented) = @_;
107 26         40 my $class = ref($self);
108 26 50       39 my @import_args = @{ $self->{requested_features}{$feature} || [] };
  26         75  
109              
110 26         36 print STDERR "$class - exporting $feature to $self->{caller} with arguments (@import_args)\n"
111             if DEBUG;
112              
113             # do nothing if we've exported it already
114 26 50       64 return if $self->{exported_features}{$feature};
115              
116 26         54 my $list_method = "feature_${feature}_export_list";
117 26         47 my $direct_method = "feature_${feature}_export";
118              
119 26         46 my $arguments_method = "feature_${feature}_takes_arguments";
120 26   66     130 my $takes_arguments = $self->can($arguments_method) && $self->$arguments_method;
121 26 100 100     80 if (@import_args && !$takes_arguments) {
122 1         228 croak "feature $feature does not take arguments, but (@import_args) were provided";
123             }
124              
125 25         50 my $provided = 0;
126             # loop over the parts in @ISA order
127 25         34 for my $parent_stash (@{$self->{parent_stashes}}) {
  25         49  
128 134         301 my $parent_class = $parent_stash->name;
129 134         164 my $method_ref;
130             # does this part provide a *_export_list sub?
131 134 100       919 if ($method_ref = $parent_stash->get_symbol("&$list_method")) {
    100          
132 1         2 print STDERR " calling ${parent_class}->$list_method\n"
133             if DEBUG;
134             # import all the packages that the sub returns
135 1         5 for my $module ($self->$method_ref) {
136 1         8 use_module($module)->import::into($self->{caller}, @import_args);
137             }
138 1         740 $provided = 1;
139             }
140             # does this part provide a *_export sub?
141             elsif ($method_ref = $parent_stash->get_symbol("&$direct_method")) {
142 21         33 print STDERR " calling ${parent_class}->$direct_method\n"
143             if DEBUG;
144             # call it and let it do whatever it needs to
145 21         66 $self->$method_ref($self->{caller},@import_args);
146 20         7597 $provided = 1;
147             }
148             }
149              
150             # did we find the feature?
151 24 100       56 if ($provided) {
    50          
152             # mark it as exported
153 21         42 $self->{exported_features}{$feature} = 1;
154             }
155             elsif ($croak_if_not_implemented) {
156             # croak if asked to
157 0         0 croak "feature <$feature> is not implemented by $class";
158             }
159              
160 24         64 return;
161             }
162              
163             # use the *_order subs
164             sub _sort_features {
165 11     11   28 my ($class, @features) = @_;
166              
167             my %feature_sort_key = map {
168 11         23 my $method = "feature_${_}_order";
  18         39  
169 18 100       129 $_ => ( $class->can($method) ? $class->$method : 100 )
170             } @features;
171              
172             @features = sort {
173 11         42 $feature_sort_key{$a} <=> $feature_sort_key{$b}
  8         27  
174             } @features;
175              
176 11         15 print "$class - sorted features: (@features)\n" if DEBUG;
177              
178 11         93 return @features;
179             }
180              
181             # use the *_default subs
182             sub _default_features {
183 11     11   26 my ($class, $parent_stashes) = @_;
184              
185 11         18 my @features;
186             # loop over the parts in @ISA order
187 11         16 for my $parent_stash (@{$parent_stashes}) {
  11         26  
188 59         428 my @subs = $parent_stash->list_all_symbols('CODE');
189 59         125 for my $sub (@subs) {
190             # we only care about sub names of this form
191 286 100       597 next unless $sub =~ /^feature_(\w+)_default$/;
192              
193 32         73 my $feature = $1;
194 32         128 my $is_default = $class->$sub;
195              
196 32         82 if (DEBUG) {
197             my $parent_class = $parent_stash->name;
198             print STDERR "$class - $parent_class provides $feature, by default ",
199             ($is_default ? 'enabled' : 'disabled' ),
200             "\n";
201             }
202              
203 32 100       81 push @features, $feature if $is_default;
204             }
205             }
206              
207 11         28 return @features;
208             }
209              
210             sub _get_parent_stashes {
211 11     11   36 my ($class) = @_;
212              
213 11   33     54 $class = ref($class) || $class;
214 11         18 return [ map { Package::Stash->new($_) } @{ mro::get_linear_isa($class) } ];
  59         356  
  11         53  
215             }
216              
217             1;
218              
219             __END__