File Coverage

blib/lib/Perl/ToPerl6/Config.pm
Criterion Covered Total %
statement 373 397 93.9
branch 88 104 84.6
condition 26 35 74.2
subroutine 69 70 98.5
pod 26 26 100.0
total 582 632 92.0


line stmt bran cond sub pod time code
1             package Perl::ToPerl6::Config;
2              
3 13     13   1510 use 5.006001;
  13         38  
4 13     13   59 use strict;
  13         18  
  13         274  
5 13     13   83 use warnings;
  13         21  
  13         360  
6              
7 13     13   55 use English qw(-no_match_vars);
  13         18  
  13         81  
8 13     13   4690 use Readonly;
  13         29  
  13         621  
9              
10 13     13   66 use List::MoreUtils qw(any none apply);
  13         19  
  13         110  
11 13     13   5920 use Scalar::Util qw(blessed);
  13         24  
  13         707  
12              
13 13     13   1110 use Perl::ToPerl6::Exception::AggregateConfiguration;
  13         26  
  13         580  
14 13     13   437 use Perl::ToPerl6::Exception::Configuration;
  13         21  
  13         529  
15 13     13   6965 use Perl::ToPerl6::Exception::Configuration::Option::Global::ParameterValue;
  13         31  
  13         746  
16 13     13   75 use Perl::ToPerl6::Exception::Fatal::Internal qw{ throw_internal };
  13         17  
  13         566  
17 13     13   1731 use Perl::ToPerl6::TransformerFactory;
  13         1106  
  13         109  
18 13     13   5162 use Perl::ToPerl6::Theme qw( $RULE_INVALID_CHARACTER_REGEX cook_rule );
  13         28  
  13         242  
19 13     13   5687 use Perl::ToPerl6::UserProfile qw();
  13         28  
  13         424  
20 13         761 use Perl::ToPerl6::Utils qw{
21             :booleans :characters :severities :internal_lookup :classification
22             :data_conversion
23 13     13   67 };
  13         19  
24 13         1945 use Perl::ToPerl6::Utils::Constants qw<
25             :profile_strictness
26             $_MODULE_VERSION_TERM_ANSICOLOR
27 13     13   6295 >;
  13         17  
28 13     13   72 use Perl::ToPerl6::Utils::DataConversion qw< boolean_to_number dor >;
  13         21  
  13         49040  
29              
30             #-----------------------------------------------------------------------------
31              
32             our $VERSION = '0.03';
33              
34             #-----------------------------------------------------------------------------
35              
36             Readonly::Scalar my $SINGLE_POLICY_CONFIG_KEY => 'single-transformer';
37              
38             #-----------------------------------------------------------------------------
39             # Constructor
40              
41             sub new {
42              
43 73     73 1 33517 my ( $class, %args ) = @_;
44 73         239 my $self = bless {}, $class;
45 73         397 $self->_init( %args );
46 69         385 return $self;
47             }
48              
49             #-----------------------------------------------------------------------------
50              
51             sub _init {
52 73     73   215 my ( $self, %args ) = @_;
53              
54             # -top or -theme imply that -severity is 1, unless it is already defined
55 73 100 100     704 if ( defined $args{-top} || defined $args{-theme} ) {
56 7   66     48 $args{-severity} ||= $SEVERITY_LOWEST;
57             }
58              
59 73         450 my $errors = Perl::ToPerl6::Exception::AggregateConfiguration->new();
60              
61             # Construct the UserProfile to get default options.
62 73         25532 my $profile_source = $args{-profile}; # Can be file path or data struct
63 73         592 my $profile = Perl::ToPerl6::UserProfile->new( -profile => $profile_source );
64 73         316 my $options_processor = $profile->options_processor();
65 73         203 $self->{_profile} = $profile;
66              
67             $self->_validate_and_save_profile_strictness(
68 73         422 $args{'-profile-strictness'},
69             $errors,
70             );
71              
72             # If given, these options should always have a true value.
73             $self->_validate_and_save_regex(
74 73         453 'include', $args{-include}, $options_processor->include(), $errors
75             );
76             $self->_validate_and_save_regex(
77 73         474 'exclude', $args{-exclude}, $options_processor->exclude(), $errors
78             );
79             $self->_validate_and_save_regex(
80             $SINGLE_POLICY_CONFIG_KEY,
81 73         435 $args{ qq/-$SINGLE_POLICY_CONFIG_KEY/ },
82             $options_processor->single_transformer(),
83             $errors,
84             );
85             $self->_validate_and_save_color_severity(
86 73         449 'color_severity_highest', $args{'-color-severity-highest'},
87             $options_processor->color_severity_highest(), $errors
88             );
89             $self->_validate_and_save_color_severity(
90 73         553 'color_severity_high', $args{'-color-severity-high'},
91             $options_processor->color_severity_high(), $errors
92             );
93             $self->_validate_and_save_color_severity(
94 73         419 'color_severity_medium', $args{'-color-severity-medium'},
95             $options_processor->color_severity_medium(), $errors
96             );
97             $self->_validate_and_save_color_severity(
98 73         414 'color_severity_low', $args{'-color-severity-low'},
99             $options_processor->color_severity_low(), $errors
100             );
101             $self->_validate_and_save_color_severity(
102 73         426 'color_severity_lowest', $args{'-color-severity-lowest'},
103             $options_processor->color_severity_lowest(), $errors
104             );
105              
106 73         403 $self->_validate_and_save_verbosity($args{-verbose}, $errors);
107 73         361 $self->_validate_and_save_severity($args{-severity}, $errors);
108 73         351 $self->_validate_and_save_top($args{-top}, $errors);
109 73         333 $self->_validate_and_save_theme($args{-theme}, $errors);
110 73         387 $self->_validate_and_save_pager($args{-pager}, $errors);
111             $self->_validate_and_save_program_extensions(
112 73         331 $args{'-program-extensions'}, $errors);
113              
114             # If given, these options can be true or false (but defined)
115             # We normalize these to numeric values by multiplying them by 1;
116 73         460 $self->{_force} = boolean_to_number( dor( $args{-force}, $options_processor->force() ) );
117 73         431 $self->{_only} = boolean_to_number( dor( $args{-only}, $options_processor->only() ) );
118 73         376 $self->{_color} = boolean_to_number( dor( $args{-color}, $options_processor->color() ) );
119             $self->{_unsafe_allowed} =
120             boolean_to_number(
121 73         342 dor( $args{'-allow-unsafe'}, $options_processor->allow_unsafe()
122             ) );
123             $self->{_mogrification_fatal} =
124             boolean_to_number(
125 73         358 dor( $args{'-mogrification-fatal'}, $options_processor->mogrification_fatal() )
126             );
127              
128              
129             # Construct a Factory with the Profile
130 73         398 my $factory =
131             Perl::ToPerl6::TransformerFactory->new(
132             -profile => $profile,
133             -errors => $errors,
134             '-profile-strictness' => $self->profile_strictness(),
135             );
136 73         196 $self->{_factory} = $factory;
137              
138             # Initialize internal storage for Transformers
139 73         147 $self->{_all_transformers_enabled_or_not} = [];
140 73         137 $self->{_transformers} = [];
141              
142             # "NONE" means don't load any transformers
143 73 100 100     391 if ( not defined $profile_source or $profile_source ne 'NONE' ) {
144             # Heavy lifting here...
145 32         117 $self->_load_transformers($errors);
146             }
147              
148 73 100       717 if ( $errors->has_exceptions() ) {
149 4         60 $errors->rethrow();
150             }
151              
152 69         2344 return $self;
153             }
154              
155             #-----------------------------------------------------------------------------
156              
157             sub apply_transform {
158              
159 882     882 1 2712 my ( $self, %args ) = @_;
160              
161 882 100       4105 if ( not $args{-transformer} ) {
162 1         5 throw_internal q{The -transformer argument is required};
163             }
164              
165 881         18917 my $transformer = $args{-transformer};
166              
167             # If the -transformer is already a blessed object, then just add it directly.
168 881 100       3087 if ( blessed $transformer ) {
169 880         1731 $self->_apply_transform_if_enabled($transformer);
170 880         2339 return $self;
171             }
172              
173             # NOTE: The "-config" option is supported for backward compatibility.
174 1   33     11 my $params = $args{-params} || $args{-config};
175              
176 1         2 my $factory = $self->{_factory};
177 1         6 my $transformer_object =
178             $factory->create_transformer(-name=>$transformer, -params=>$params);
179 0         0 $self->_apply_transform_if_enabled($transformer_object);
180              
181 0         0 return $self;
182             }
183              
184             #-----------------------------------------------------------------------------
185              
186             sub _apply_transform_if_enabled {
187 880     880   1035 my ( $self, $transformer_object ) = @_;
188              
189 880 50       2329 my $config = $transformer_object->__get_config()
190             or throw_internal
191             q{Transformer was not set up properly because it does not have }
192             . q{a value for its config attribute.};
193              
194 880         864 push @{ $self->{_all_transformers_enabled_or_not} }, $transformer_object;
  880         1733  
195 880 50       2845 if ( $transformer_object->initialize_if_enabled( $config ) ) {
196 880         2340 $transformer_object->__set_enabled($TRUE);
197 880         721 push @{ $self->{_transformers} }, $transformer_object;
  880         1460  
198             }
199             else {
200 0         0 $transformer_object->__set_enabled($FALSE);
201             }
202              
203 880         1015 return;
204             }
205              
206             #-----------------------------------------------------------------------------
207              
208             sub _load_transformers {
209              
210 32     32   63 my ( $self, $errors ) = @_;
211 32         75 my $factory = $self->{_factory};
212 32         142 my @transformers = $factory->create_all_transformers( $errors );
213              
214 32 100       178 return if $errors->has_exceptions();
215              
216 30         261 for my $transformer ( @transformers ) {
217              
218             # If -single-transformer is true, only load transformers that match it
219 1140 100       2119 if ( $self->single_transformer() ) {
220 152 100       199 if ( $self->_transformer_is_single_transformer( $transformer ) ) {
221 40         119 $self->apply_transform( -transformer => $transformer );
222             }
223 152         284 next;
224             }
225              
226             # Always exclude unsafe transformers, unless instructed not to
227 988 100 100     3756 next if not ( $transformer->is_safe() or $self->unsafe_allowed() );
228              
229             # To load, or not to load -- that is the question.
230 987 100       1775 my $load_me = $self->only() ? $FALSE : $TRUE;
231              
232 987 100       1612 $load_me = $FALSE if $self->_transformer_is_disabled( $transformer );
233 987 100       1987 $load_me = $TRUE if $self->_transformer_is_enabled( $transformer );
234 987 100       1737 $load_me = $FALSE if $self->_transformer_is_unimportant( $transformer );
235 987 100       1707 $load_me = $FALSE if not $self->_transformer_is_thematic( $transformer );
236 987 50       2244 $load_me = $TRUE if $self->_transformer_is_included( $transformer );
237 987 100       2810 $load_me = $FALSE if $self->_transformer_is_excluded( $transformer );
238              
239              
240 987 100       2457 next if not $load_me;
241 840         2307 $self->apply_transform( -transformer => $transformer );
242             }
243              
244             # When using -single-transformer, only one transformer should ever be loaded.
245 30 100 100     85 if ($self->single_transformer() && scalar $self->transformers() != 1) {
246 2         9 $self->_add_single_transformer_exception_to($errors);
247             }
248              
249 30         1063 return;
250             }
251              
252             #-----------------------------------------------------------------------------
253              
254             sub _transformer_is_disabled {
255 987     987   1094 my ($self, $transformer) = @_;
256 987         1749 my $profile = $self->_profile();
257 987         2766 return $profile->transformer_is_disabled( $transformer );
258             }
259              
260             #-----------------------------------------------------------------------------
261              
262             sub _transformer_is_enabled {
263 987     987   1066 my ($self, $transformer) = @_;
264 987         1401 my $profile = $self->_profile();
265 987         2383 return $profile->transformer_is_enabled( $transformer );
266             }
267              
268             #-----------------------------------------------------------------------------
269              
270             sub _transformer_is_thematic {
271 987     987   959 my ($self, $transformer) = @_;
272 987         1470 my $theme = $self->theme();
273 987         3344 return $theme->transformer_is_thematic( -transformer => $transformer );
274             }
275              
276             #-----------------------------------------------------------------------------
277              
278             sub _transformer_is_unimportant {
279 987     987   1111 my ($self, $transformer) = @_;
280 987         2983 my $transformer_severity = $transformer->get_severity();
281 987         1367 my $min_severity = $self->{_severity};
282 987         2115 return $transformer_severity < $min_severity;
283             }
284              
285             #-----------------------------------------------------------------------------
286              
287             sub _transformer_is_included {
288 987     987   1135 my ($self, $transformer) = @_;
289 987         1353 my $transformer_long_name = ref $transformer;
290 987         1854 my @inclusions = $self->include();
291 987     114   5449 return any { $transformer_long_name =~ m/$_/ixms } @inclusions;
  114         861  
292             }
293              
294             #-----------------------------------------------------------------------------
295              
296             sub _transformer_is_excluded {
297 987     987   1075 my ($self, $transformer) = @_;
298 987         1072 my $transformer_long_name = ref $transformer;
299 987         1547 my @exclusions = $self->exclude();
300 987     227   3497 return any { $transformer_long_name =~ m/$_/ixms } @exclusions;
  227         1508  
301             }
302              
303             #-----------------------------------------------------------------------------
304              
305             sub _transformer_is_single_transformer {
306 152     152   128 my ($self, $transformer) = @_;
307              
308 152         164 my @patterns = $self->single_transformer();
309 152 50       242 return if not @patterns;
310              
311 152         201 my $transformer_long_name = ref $transformer;
312 152     152   391 return any { $transformer_long_name =~ m/$_/ixms } @patterns;
  152         579  
313             }
314              
315             #-----------------------------------------------------------------------------
316              
317             sub _new_global_value_exception {
318 16     16   89 my ($self, @args) = @_;
319              
320             return
321 16         104 Perl::ToPerl6::Exception::Configuration::Option::Global::ParameterValue
322             ->new(@args);
323             }
324              
325             #-----------------------------------------------------------------------------
326              
327             sub _add_single_transformer_exception_to {
328 2     2   4 my ($self, $errors) = @_;
329              
330 2         5 my $message_suffix = $EMPTY;
331 2         7 my $patterns = join q{", "}, $self->single_transformer();
332              
333 2 100       6 if (scalar $self->transformers() == 0) {
334 1         3 $message_suffix =
335             q{did not match any transformers (in combination with }
336             . q{other transformer restrictions).};
337             }
338             else {
339 1         3 $message_suffix = qq{matched multiple transformers:\n\t};
340 1     38   5 $message_suffix .= join qq{,\n\t}, apply { chomp } sort $self->transformers();
  38         1164  
341             }
342              
343 2         458 $errors->add_exception(
344             $self->_new_global_value_exception(
345             option_name => $SINGLE_POLICY_CONFIG_KEY,
346             option_value => $patterns,
347             message_suffix => $message_suffix,
348             )
349             );
350              
351 2         5 return;
352             }
353              
354             #-----------------------------------------------------------------------------
355              
356             sub _validate_and_save_regex {
357 219     219   427 my ($self, $option_name, $args_value, $default_value, $errors) = @_;
358              
359 219         215 my $full_option_name;
360             my $source;
361 0         0 my @regexes;
362              
363 219 100       435 if ($args_value) {
364 7         18 $full_option_name = "-$option_name";
365              
366 7 100       22 if (ref $args_value) {
367 3         6 @regexes = @{ $args_value };
  3         10  
368             }
369             else {
370 4         11 @regexes = ( $args_value );
371             }
372             }
373              
374 219 100       408 if (not @regexes) {
375 212         269 $full_option_name = $option_name;
376 212         404 $source = $self->_profile()->source();
377              
378 212 100       520 if (ref $default_value) {
    100          
379 143         177 @regexes = @{ $default_value };
  143         289  
380             }
381             elsif ($default_value) {
382 1         3 @regexes = ( $default_value );
383             }
384             }
385              
386 219         229 my $found_errors;
387 219         370 foreach my $regex (@regexes) {
388 16         239625 eval { qr/$regex/ixms }
389 16 100       31 or do {
390 3   50     13 my $cleaned_error = $EVAL_ERROR || '<unknown reason>';
391 3         26 $cleaned_error =~
392             s/ [ ] at [ ] .* Config [.] pm [ ] line [ ] \d+ [.] \n? \z/./xms;
393              
394 3         19 $errors->add_exception(
395             $self->_new_global_value_exception(
396             option_name => $option_name,
397             option_value => $regex,
398             source => $source,
399             message_suffix => qq{is not valid: $cleaned_error},
400             )
401             );
402              
403 3         11 $found_errors = 1;
404             }
405             }
406              
407 219 100       432 if (not $found_errors) {
408 216         256 my $option_key = $option_name;
409 216         493 $option_key =~ s/ - /_/xmsg;
410              
411 216         504 $self->{"_$option_key"} = \@regexes;
412             }
413              
414 219         325 return;
415             }
416              
417             #-----------------------------------------------------------------------------
418              
419             sub _validate_and_save_profile_strictness {
420 73     73   189 my ($self, $args_value, $errors) = @_;
421              
422 73         112 my $option_name;
423             my $source;
424 0         0 my $profile_strictness;
425              
426 73 50       197 if ($args_value) {
427 0         0 $option_name = '-profile-strictness';
428 0         0 $profile_strictness = $args_value;
429             }
430             else {
431 73         115 $option_name = 'profile-strictness';
432              
433 73         258 my $profile = $self->_profile();
434 73         281 $source = $profile->source();
435 73         211 $profile_strictness = $profile->options_processor()->profile_strictness();
436             }
437              
438 73 100       394 if ( not $PROFILE_STRICTNESSES{$profile_strictness} ) {
439 1         10 $errors->add_exception(
440             $self->_new_global_value_exception(
441             option_name => $option_name,
442             option_value => $profile_strictness,
443             source => $source,
444             message_suffix => q{is not one of "}
445             . join ( q{", "}, (sort keys %PROFILE_STRICTNESSES) )
446             . q{".},
447             )
448             );
449              
450 1         3 $profile_strictness = $PROFILE_STRICTNESS_FATAL;
451             }
452              
453 73         609 $self->{_profile_strictness} = $profile_strictness;
454              
455 73         141 return;
456             }
457              
458             #-----------------------------------------------------------------------------
459              
460             sub _validate_and_save_verbosity {
461 73     73   192 my ($self, $args_value, $errors) = @_;
462              
463 73         114 my $option_name;
464             my $source;
465 0         0 my $verbosity;
466              
467 73 50       166 if ($args_value) {
468 0         0 $option_name = '-verbose';
469 0         0 $verbosity = $args_value;
470             }
471             else {
472 73         122 $option_name = 'verbose';
473              
474 73         182 my $profile = $self->_profile();
475 73         223 $source = $profile->source();
476 73         231 $verbosity = $profile->options_processor()->verbose();
477             }
478              
479 73 100 66     293 if (
480             is_integer($verbosity)
481             and not is_valid_numeric_verbosity($verbosity)
482             ) {
483 1         17 $errors->add_exception(
484             $self->_new_global_value_exception(
485             option_name => $option_name,
486             option_value => $verbosity,
487             source => $source,
488             message_suffix =>
489             'is not the number of one of the pre-defined verbosity formats.',
490             )
491             );
492             }
493             else {
494 72         778 $self->{_verbose} = $verbosity;
495             }
496              
497 73         177 return;
498             }
499              
500             #-----------------------------------------------------------------------------
501              
502             sub _validate_and_save_severity {
503 73     73   147 my ($self, $args_value, $errors) = @_;
504              
505 73         124 my $option_name;
506             my $source;
507 0         0 my $severity;
508              
509 73 100       181 if ($args_value) {
510 18         34 $option_name = '-severity';
511 18         33 $severity = $args_value;
512             }
513             else {
514 55         82 $option_name = 'severity';
515              
516 55         113 my $profile = $self->_profile();
517 55         158 $source = $profile->source();
518 55         149 $severity = $profile->options_processor()->severity();
519             }
520              
521 73 100       210 if ( is_integer($severity) ) {
    100          
522 67 100 66     422 if (
523             $severity >= $SEVERITY_LOWEST and $severity <= $SEVERITY_HIGHEST
524             ) {
525 66         305 $self->{_severity} = $severity;
526             }
527             else {
528 1         8 $errors->add_exception(
529             $self->_new_global_value_exception(
530             option_name => $option_name,
531             option_value => $severity,
532             source => $source,
533             message_suffix =>
534             "is not between $SEVERITY_LOWEST (low) and $SEVERITY_HIGHEST (high).",
535             )
536             );
537             }
538             }
539 20     20   163 elsif ( not any { $_ eq lc $severity } @SEVERITY_NAMES ) {
540 1         4 $errors->add_exception(
541             $self->_new_global_value_exception(
542             option_name => $option_name,
543             option_value => $severity,
544             source => $source,
545             message_suffix =>
546             q{is not one of the valid severity names: "}
547             . join (q{", "}, @SEVERITY_NAMES)
548             . q{".},
549             )
550             );
551             }
552             else {
553 5         19 $self->{_severity} = severity_to_number($severity);
554             }
555              
556 73         152 return;
557             }
558              
559             #-----------------------------------------------------------------------------
560              
561             sub _validate_and_save_top {
562 73     73   142 my ($self, $args_value, $errors) = @_;
563              
564 73         106 my $option_name;
565             my $source;
566 0         0 my $top;
567              
568 73 100 100     309 if (defined $args_value and $args_value ne q{}) {
569 2         7 $option_name = '-top';
570 2         6 $top = $args_value;
571             }
572             else {
573 71         139 $option_name = 'top';
574              
575 71         163 my $profile = $self->_profile();
576 71         227 $source = $profile->source();
577 71         191 $top = $profile->options_processor()->top();
578             }
579              
580 73 100 66     208 if ( is_integer($top) and $top >= 0 ) {
581 72         201 $self->{_top} = $top;
582             }
583             else {
584 1         5 $errors->add_exception(
585             $self->_new_global_value_exception(
586             option_name => $option_name,
587             option_value => $top,
588             source => $source,
589             message_suffix => q{is not a non-negative integer.},
590             )
591             );
592             }
593              
594 73         120 return;
595             }
596              
597             #-----------------------------------------------------------------------------
598              
599             sub _validate_and_save_theme {
600 73     73   166 my ($self, $args_value, $errors) = @_;
601              
602 73         95 my $option_name;
603             my $source;
604 0         0 my $theme_rule;
605              
606 73 100       176 if ($args_value) {
607 4         6 $option_name = '-theme';
608 4         13 $theme_rule = $args_value;
609             }
610             else {
611 69         130 $option_name = 'theme';
612              
613 69         150 my $profile = $self->_profile();
614 69         213 $source = $profile->source();
615 69         216 $theme_rule = $profile->options_processor()->theme();
616             }
617              
618 73 50       461 if ( $theme_rule =~ m/$RULE_INVALID_CHARACTER_REGEX/xms ) {
619 0         0 my $bad_character = $1;
620              
621 0         0 $errors->add_exception(
622             $self->_new_global_value_exception(
623             option_name => $option_name,
624             option_value => $theme_rule,
625             source => $source,
626             message_suffix =>
627             qq{contains an illegal character ("$bad_character").},
628             )
629             );
630             }
631             else {
632 73         324 my $rule_as_code = cook_rule($theme_rule);
633 73         153 $rule_as_code =~ s/ [\w\d]+ / 1 /gxms;
634              
635             # eval of an empty string does not reset $@ in Perl 5.6.
636 73         134 local $EVAL_ERROR = $EMPTY;
637 73         2511 eval $rule_as_code;
638              
639 73 100       282 if ($EVAL_ERROR) {
640 1         5 $errors->add_exception(
641             $self->_new_global_value_exception(
642             option_name => $option_name,
643             option_value => $theme_rule,
644             source => $source,
645             message_suffix => q{is not syntactically valid.},
646             )
647             );
648             }
649             else {
650             eval {
651             $self->{_theme} =
652 72         544 Perl::ToPerl6::Theme->new( -rule => $theme_rule );
653             }
654 72 50       123 or do {
655 0         0 $errors->add_exception_or_rethrow( $EVAL_ERROR );
656             };
657             }
658             }
659              
660 73         146 return;
661             }
662              
663             #-----------------------------------------------------------------------------
664              
665             sub _validate_and_save_pager {
666 73     73   166 my ($self, $args_value, $errors) = @_;
667              
668 73         105 my $pager;
669 73 50       340 if ( $args_value ) {
    50          
670 0 0       0 $pager = defined $args_value ? $args_value : $EMPTY;
671             }
672             elsif ( $ENV{PERLMOGRIFY_PAGER} ) {
673 0         0 $pager = $ENV{PERLMOGRIFY_PAGER};
674             }
675             else {
676 73         166 my $profile = $self->_profile();
677 73         258 $pager = $profile->options_processor()->pager();
678             }
679              
680 73 50       232 if ($pager eq '$PAGER') {
681 0         0 $pager = $ENV{PAGER};
682             }
683 73   33     320 $pager ||= $EMPTY;
684              
685 73         124 $self->{_pager} = $pager;
686              
687 73         101 return;
688             }
689              
690             #-----------------------------------------------------------------------------
691              
692             sub _validate_and_save_color_severity {
693 365     365   724 my ($self, $option_name, $args_value, $default_value, $errors) = @_;
694              
695 365         330 my $source;
696             my $color_severity;
697 0         0 my $full_option_name;
698              
699 365 100       577 if (defined $args_value) {
700 5         5 $full_option_name = "-$option_name";
701 5         8 $color_severity = lc $args_value;
702             }
703             else {
704 360         385 $full_option_name = $option_name;
705 360         614 $source = $self->_profile()->source();
706 360         585 $color_severity = lc $default_value;
707             }
708 365         775 $color_severity =~ s/ \s+ / /xmsg;
709 365         461 $color_severity =~ s/ \A\s+ //xms;
710 365         445 $color_severity =~ s/ \s+\z //xms;
711 365         946 $full_option_name =~ s/ _ /-/xmsg;
712              
713             # Should we really be validating this?
714 365         335 my $found_errors;
715 365 50       416 if (
716             eval {
717 365         7279 require Term::ANSIColor;
718 365         37870 Term::ANSIColor->VERSION( $_MODULE_VERSION_TERM_ANSICOLOR );
719 365         1274 1;
720             }
721             ) {
722 365         828 $found_errors =
723             not Term::ANSIColor::colorvalid( words_from_string($color_severity) );
724             }
725              
726             # If we do not have Term::ANSIColor we can not validate, but we store the
727             # values anyway for the benefit of Perl::ToPerl6::ProfilePrototype.
728              
729 365 100       3681 if ($found_errors) {
730 5         17 $errors->add_exception(
731             $self->_new_global_value_exception(
732             option_name => $full_option_name,
733             option_value => $color_severity,
734             source => $source,
735             message_suffix => 'is not valid.',
736             )
737             );
738             }
739             else {
740 360         400 my $option_key = $option_name;
741 360         529 $option_key =~ s/ - /_/xmsg;
742              
743 360         868 $self->{"_$option_key"} = $color_severity;
744             }
745              
746 365         479 return;
747             }
748              
749             #-----------------------------------------------------------------------------
750              
751             sub _validate_and_save_program_extensions {
752 73     73   167 my ($self, $args_value, $errors) = @_;
753              
754 73         111 delete $self->{_program_extensions_as_regexes};
755              
756             my $extension_list = q{ARRAY} eq ref $args_value ?
757 73 50       305 [map {words_from_string($_)} @{ $args_value }] :
  0         0  
  0         0  
758             $self->_profile()->options_processor()->program_extensions();
759              
760 73         115 my %program_extensions = hashify( @{ $extension_list } );
  73         357  
761              
762 73         417 $self->{_program_extensions} = [keys %program_extensions];
763              
764 73         145 return;
765              
766             }
767              
768             #-----------------------------------------------------------------------------
769             # Begin ACCESSSOR methods
770              
771             sub _profile {
772 3033     3033   2661 my ($self) = @_;
773 3033         4966 return $self->{_profile};
774             }
775              
776             #-----------------------------------------------------------------------------
777              
778             sub all_transformers_enabled_or_not {
779 1     1 1 2 my ($self) = @_;
780 1         2 return @{ $self->{_all_transformers_enabled_or_not} };
  1         5  
781             }
782              
783             #-----------------------------------------------------------------------------
784              
785             sub transformers {
786 25     25 1 1258 my ($self) = @_;
787 25         36 return @{ $self->{_transformers} };
  25         197  
788             }
789              
790             #-----------------------------------------------------------------------------
791              
792             sub exclude {
793 991     991 1 9797 my ($self) = @_;
794 991         817 return @{ $self->{_exclude} };
  991         1796  
795             }
796              
797             #-----------------------------------------------------------------------------
798              
799             sub force {
800 12     12 1 1532 my ($self) = @_;
801 12         79 return $self->{_force};
802             }
803              
804             #-----------------------------------------------------------------------------
805              
806             sub include {
807 991     991 1 865 my ($self) = @_;
808 991         804 return @{ $self->{_include} };
  991         2227  
809             }
810              
811             #-----------------------------------------------------------------------------
812              
813             sub only {
814 995     995 1 992 my ($self) = @_;
815 995         1996 return $self->{_only};
816             }
817              
818             #-----------------------------------------------------------------------------
819              
820             sub profile_strictness {
821 76     76 1 156 my ($self) = @_;
822 76         507 return $self->{_profile_strictness};
823             }
824              
825             #-----------------------------------------------------------------------------
826              
827             sub severity {
828 12     12 1 48 my ($self) = @_;
829 12         93 return $self->{_severity};
830             }
831              
832             #-----------------------------------------------------------------------------
833              
834             sub single_transformer {
835 1327     1327 1 2376 my ($self) = @_;
836 1327         1025 return @{ $self->{_single_transformer} };
  1327         3197  
837             }
838              
839             #-----------------------------------------------------------------------------
840              
841             sub theme {
842 994     994 1 898 my ($self) = @_;
843 994         1382 return $self->{_theme};
844             }
845              
846             #-----------------------------------------------------------------------------
847              
848             sub top {
849 12     12 1 25 my ($self) = @_;
850 12         64 return $self->{_top};
851             }
852              
853             #-----------------------------------------------------------------------------
854              
855             sub verbose {
856 7     7 1 20 my ($self) = @_;
857 7         259 return $self->{_verbose};
858             }
859              
860             #-----------------------------------------------------------------------------
861              
862             sub color {
863 6     6 1 17 my ($self) = @_;
864 6         40 return $self->{_color};
865             }
866              
867             #-----------------------------------------------------------------------------
868              
869             sub pager {
870 4     4 1 12 my ($self) = @_;
871 4         25 return $self->{_pager};
872             }
873              
874             #-----------------------------------------------------------------------------
875              
876             sub unsafe_allowed {
877 7     7 1 35 my ($self) = @_;
878 7         40 return $self->{_unsafe_allowed};
879             }
880              
881             #-----------------------------------------------------------------------------
882              
883             sub mogrification_fatal {
884 3     3 1 10 my ($self) = @_;
885 3         22 return $self->{_mogrification_fatal};
886             }
887              
888             #-----------------------------------------------------------------------------
889              
890             sub site_transformer_names {
891 0     0 1 0 return Perl::ToPerl6::TransformerFactory::site_transformer_names();
892             }
893              
894             #-----------------------------------------------------------------------------
895              
896             sub color_severity_highest {
897 6     6 1 19 my ($self) = @_;
898 6         45 return $self->{_color_severity_highest};
899             }
900              
901             #-----------------------------------------------------------------------------
902              
903             sub color_severity_high {
904 6     6 1 16 my ($self) = @_;
905 6         37 return $self->{_color_severity_high};
906             }
907              
908             #-----------------------------------------------------------------------------
909              
910             sub color_severity_medium {
911 6     6 1 16 my ($self) = @_;
912 6         34 return $self->{_color_severity_medium};
913             }
914              
915             #-----------------------------------------------------------------------------
916              
917             sub color_severity_low {
918 6     6 1 20 my ($self) = @_;
919 6         38 return $self->{_color_severity_low};
920             }
921              
922             #-----------------------------------------------------------------------------
923              
924             sub color_severity_lowest {
925 6     6 1 16 my ($self) = @_;
926 6         37 return $self->{_color_severity_lowest};
927             }
928              
929             #-----------------------------------------------------------------------------
930              
931             sub program_extensions {
932 9     9 1 20 my ($self) = @_;
933 9         14 return @{ $self->{_program_extensions} };
  9         48  
934             }
935              
936             #-----------------------------------------------------------------------------
937              
938             sub program_extensions_as_regexes {
939 5     5 1 13 my ($self) = @_;
940              
941 0         0 return @{ $self->{_program_extensions_as_regexes} }
942 5 50       21 if $self->{_program_extensions_as_regexes};
943              
944 5         20 my %program_extensions = hashify( $self->program_extensions() );
945 5         13 $program_extensions{'.PL'} = 1;
946             return @{
947 5         9 $self->{_program_extensions_as_regexes} = [
948 5         18 map { qr< @{[quotemeta $_]} \z >smx } sort keys %program_extensions
  5         11  
  5         144  
949             ]
950             };
951             }
952              
953             1;
954              
955             #-----------------------------------------------------------------------------
956              
957             __END__
958              
959             =pod
960              
961             =for stopwords colour INI-style -params
962              
963             =head1 NAME
964              
965             Perl::ToPerl6::Config - The final derived Perl::ToPerl6 configuration, combined from any profile file and command-line parameters.
966              
967              
968             =head1 DESCRIPTION
969              
970             Perl::ToPerl6::Config takes care of finding and processing
971             user-preferences for L<Perl::ToPerl6|Perl::ToPerl6>. The Config object
972             defines which Transformer modules will be loaded into the Perl::ToPerl6
973             engine and how they should be configured. You should never really
974             need to instantiate Perl::ToPerl6::Config directly because the
975             Perl::ToPerl6 constructor will do it for you.
976              
977              
978             =head1 INTERFACE SUPPORT
979              
980             This is considered to be a non-public class. Its interface is subject
981             to change without notice.
982              
983              
984             =head1 CONSTRUCTOR
985              
986             =over
987              
988             =item C<< new(...) >>
989              
990             Not properly documented because you shouldn't be using this.
991              
992              
993             =back
994              
995             =head1 METHODS
996              
997             =over
998              
999             =item C<< apply_transform( -transformer => $transformer_name, -params => \%param_hash ) >>
1000              
1001             Creates a Transformer object and loads it into this Config. If the object
1002             cannot be instantiated, it will throw a fatal exception. Otherwise,
1003             it returns a reference to this ToPerl6.
1004              
1005             B<-transformer> is the name of a
1006             L<Perl::ToPerl6::Transformer|Perl::ToPerl6::Transformer> subclass module. The
1007             C<'Perl::ToPerl6::Transformer'> portion of the name can be omitted for
1008             brevity. This argument is required.
1009              
1010             B<-params> is an optional reference to a hash of Transformer parameters.
1011             The contents of this hash reference will be passed into to the
1012             constructor of the Transformer module. See the documentation in the
1013             relevant Transformer module for a description of the arguments it supports.
1014              
1015              
1016             =item C< all_transformers_enabled_or_not() >
1017              
1018             Returns a list containing references to all the Transformer objects that
1019             have been seen. Note that the state of these objects is not
1020             trustworthy. In particular, it is likely that some of them are not
1021             prepared to examine any documents.
1022              
1023              
1024             =item C< transformers() >
1025              
1026             Returns a list containing references to all the Transformer objects that
1027             have been enabled and loaded into this Config.
1028              
1029              
1030             =item C< exclude() >
1031              
1032             Returns the value of the C<-exclude> attribute for this Config.
1033              
1034              
1035             =item C< include() >
1036              
1037             Returns the value of the C<-include> attribute for this Config.
1038              
1039              
1040             =item C< force() >
1041              
1042             Returns the value of the C<-force> attribute for this Config.
1043              
1044              
1045             =item C< only() >
1046              
1047             Returns the value of the C<-only> attribute for this Config.
1048              
1049              
1050             =item C< profile_strictness() >
1051              
1052             Returns the value of the C<-profile-strictness> attribute for this
1053             Config.
1054              
1055              
1056             =item C< severity() >
1057              
1058             Returns the value of the C<-severity> attribute for this Config.
1059              
1060              
1061             =item C< single_transformer() >
1062              
1063             Returns the value of the C<-single-transformer> attribute for this Config.
1064              
1065              
1066             =item C< theme() >
1067              
1068             Returns the L<Perl::ToPerl6::Theme|Perl::ToPerl6::Theme> object that was
1069             created for this Config.
1070              
1071              
1072             =item C< top() >
1073              
1074             Returns the value of the C<-top> attribute for this Config.
1075              
1076              
1077             =item C< verbose() >
1078              
1079             Returns the value of the C<-verbose> attribute for this Config.
1080              
1081              
1082             =item C< color() >
1083              
1084             Returns the value of the C<-color> attribute for this Config.
1085              
1086              
1087             =item C< pager() >
1088              
1089             Returns the value of the C<-pager> attribute for this Config.
1090              
1091              
1092             =item C< unsafe_allowed() >
1093              
1094             Returns the value of the C<-allow-unsafe> attribute for this Config.
1095              
1096              
1097             =item C< mogrification_fatal() >
1098              
1099             Returns the value of the C<-mogrifysm-fatal> attribute for this Config.
1100              
1101              
1102             =item C< color_severity_highest() >
1103              
1104             Returns the value of the C<-color-severity-highest> attribute for this
1105             Config.
1106              
1107              
1108             =item C< color_severity_high() >
1109              
1110             Returns the value of the C<-color-severity-high> attribute for this
1111             Config.
1112              
1113              
1114             =item C< color_severity_medium() >
1115              
1116             Returns the value of the C<-color-severity-medium> attribute for this
1117             Config.
1118              
1119              
1120             =item C< color_severity_low() >
1121              
1122             Returns the value of the C<-color-severity-low> attribute for this
1123             Config.
1124              
1125              
1126             =item C< color_severity_lowest() >
1127              
1128             Returns the value of the C<-color-severity-lowest> attribute for this
1129             Config.
1130              
1131             =item C< program_extensions() >
1132              
1133             Returns the value of the C<-program_extensions> attribute for this Config.
1134             This is an array of the file name extensions that represent program files.
1135              
1136             =item C< program_extensions_as_regexes() >
1137              
1138             Returns the value of the C<-program_extensions> attribute for this Config, as
1139             an array of case-sensitive regexes matching the ends of the file names that
1140             represent program files.
1141              
1142             =back
1143              
1144              
1145             =head1 SUBROUTINES
1146              
1147             Perl::ToPerl6::Config has a few static subroutines that are used
1148             internally, but may be useful to you in some way.
1149              
1150              
1151             =over
1152              
1153             =item C<site_transformer_names()>
1154              
1155             Returns a list of all the Transformer modules that are currently installed
1156             in the Perl::ToPerl6:Transformer namespace. These will include modules that
1157             are distributed with Perl::ToPerl6 plus any third-party modules that
1158             have been installed.
1159              
1160              
1161             =back
1162              
1163              
1164             =head1 CONFIGURATION
1165              
1166             Most of the settings for Perl::ToPerl6 and each of the Transformer modules
1167             can be controlled by a configuration file. The default configuration
1168             file is called F<.perlmogrifyrc>.
1169             L<Perl::ToPerl6::Config|Perl::ToPerl6::Config> will look for this file
1170             in the current directory first, and then in your home directory.
1171             Alternatively, you can set the C<PERLMOGRIFY> environment variable to
1172             explicitly point to a different file in another location. If none of
1173             these files exist, and the C<-profile> option is not given to the
1174             constructor, then all Transformers will be loaded with their default
1175             configuration.
1176              
1177             The format of the configuration file is a series of INI-style blocks
1178             that contain key-value pairs separated by '='. Comments should start
1179             with '#' and can be placed on a separate line or after the name-value
1180             pairs if you desire.
1181              
1182             Default settings for Perl::ToPerl6 itself can be set B<before the first
1183             named block.> For example, putting any or all of these at the top of
1184             your configuration file will set the default value for the
1185             corresponding Perl::ToPerl6 constructor argument.
1186              
1187             severity = 3 #Integer from 1 to 5
1188             only = 1 #Zero or One
1189             force = 0 #Zero or One
1190             verbose = 4 #Integer or format spec
1191             top = 50 #A positive integer
1192             theme = risky + (pbp * security) - cosmetic #A theme expression
1193             include = NamingConventions ClassHierarchies #Space-delimited list
1194             exclude = Variables Modules::RequirePackage #Space-delimited list
1195             color = 1 #Zero or One
1196             allow_unsafe = 1 #Zero or One
1197             color-severity-highest = bold red #Term::ANSIColor
1198             color-severity-high = magenta #Term::ANSIColor
1199             color-severity-medium = #no coloring
1200             color-severity-low = #no coloring
1201             color-severity-lowest = #no coloring
1202             program-extensions = #Space-delimited list
1203              
1204             The remainder of the configuration file is a series of blocks like
1205             this:
1206              
1207             [Perl::ToPerl6::Transformer::Category::TransformerName]
1208             severity = 1
1209             set_themes = foo bar
1210             add_themes = baz
1211             arg1 = value1
1212             arg2 = value2
1213              
1214             C<Perl::ToPerl6::Transformer::Category::TransformerName> is the full name of a
1215             module that implements the transformer. The Transformer modules distributed
1216             with Perl::ToPerl6 have been grouped into categories according to the
1217             table of contents in Damian Conway's book B<Perl Best Practices>. For
1218             brevity, you can omit the C<'Perl::ToPerl6::Transformer'> part of the module
1219             name.
1220              
1221             C<severity> is the level of importance you wish to assign to the
1222             Transformer. All Transformer modules are defined with a default severity value
1223             ranging from 1 (least severe) to 5 (most severe). However, you may
1224             disagree with the default severity and choose to give it a higher or
1225             lower severity, based on your own coding philosophy.
1226              
1227             The remaining key-value pairs are configuration parameters that will
1228             be passed into the constructor of that Transformer. The constructors for
1229             most Transformer modules do not support arguments, and those that do should
1230             have reasonable defaults. See the documentation on the appropriate
1231             Transformer module for more details.
1232              
1233             Instead of redefining the severity for a given Transformer, you can
1234             completely disable a Transformer by prepending a '-' to the name of the
1235             module in your configuration file. In this manner, the Transformer will
1236             never be loaded, regardless of the C<-severity> given to the
1237             Perl::ToPerl6::Config constructor.
1238              
1239             A simple configuration might look like this:
1240              
1241             #--------------------------------------------------------------
1242             # I think these are really important, so always load them
1243              
1244             [TestingAndDebugging::RequireUseStrict]
1245             severity = 5
1246              
1247             [TestingAndDebugging::RequireUseWarnings]
1248             severity = 5
1249              
1250             #--------------------------------------------------------------
1251             # I think these are less important, so only load when asked
1252              
1253             [Variables::ProhibitPackageVars]
1254             severity = 2
1255              
1256             [ControlStructures::ProhibitPostfixControls]
1257             allow = if unless #My custom configuration
1258             severity = 2
1259              
1260             #--------------------------------------------------------------
1261             # Give these transformers a custom theme. I can activate just
1262             # these transformers by saying (-theme => 'larry + curly')
1263              
1264             [Modules::RequireFilenameMatchesPackage]
1265             add_themes = larry
1266              
1267             [TestingAndDebugging::RequireTestLables]
1268             add_themes = curly moe
1269              
1270             #--------------------------------------------------------------
1271             # I do not agree with these at all, so never load them
1272              
1273             [-NamingConventions::Capitalization]
1274             [-ValuesAndExpressions::ProhibitMagicNumbers]
1275              
1276             #--------------------------------------------------------------
1277             # For all other Transformers, I accept the default severity, theme
1278             # and other parameters, so no additional configuration is
1279             # required for them.
1280              
1281             For additional configuration examples, see the F<perlmogrifyrc> file
1282             that is included in this F<t/examples> directory of this distribution.
1283              
1284              
1285             =head1 THE POLICIES
1286              
1287             A large number of Transformer modules are distributed with Perl::ToPerl6.
1288             They are described briefly in the companion document
1289             L<Perl::ToPerl6::TransformerSummary|Perl::ToPerl6::TransformerSummary> and in more
1290             detail in the individual modules themselves.
1291              
1292              
1293             =head1 POLICY THEMES
1294              
1295             Each Transformer is defined with one or more "themes". Themes can be used
1296             to create arbitrary groups of Transformers. They are intended to provide
1297             an alternative mechanism for selecting your preferred set of Transformers.
1298             For example, you may wish disable a certain subset of Transformers when
1299             analyzing test programs. Conversely, you may wish to enable only a
1300             specific subset of Transformers when analyzing modules.
1301              
1302             The Transformers that ship with Perl::ToPerl6 are have been broken into the
1303             following themes. This is just our attempt to provide some basic
1304             logical groupings. You are free to invent new themes that suit your
1305             needs.
1306              
1307             THEME DESCRIPTION
1308             --------------------------------------------------------------------------
1309             core All transformers that ship with Perl::ToPerl6
1310             pbp Transformers that come directly from "Perl Best Practices"
1311             bugs Transformers that prevent or reveal bugs
1312             maintenance Transformers that affect the long-term health of the code
1313             cosmetic Transformers that only have a superficial effect
1314             complexity Transformers that specificaly relate to code complexity
1315             security Transformers that relate to security issues
1316             tests Transformers that are specific to test programs
1317              
1318             Say C<`perlmogrify -list`> to get a listing of all available transformers
1319             and the themes that are associated with each one. You can also change
1320             the theme for any Transformer in your F<.perlmogrifyrc> file. See the
1321             L<"CONFIGURATION"> section for more information about that.
1322              
1323             Using the C<-theme> option, you can combine theme names with
1324             mathematical and boolean operators to create an arbitrarily complex
1325             expression that represents a custom "set" of Transformers. The following
1326             operators are supported
1327              
1328             Operator Alternative Meaning
1329             ----------------------------------------------------------------------------
1330             * and Intersection
1331             - not Difference
1332             + or Union
1333              
1334             Operator precedence is the same as that of normal mathematics. You
1335             can also use parenthesis to enforce precedence. Here are some
1336             examples:
1337              
1338             Expression Meaning
1339             ----------------------------------------------------------------------------
1340             pbp * bugs All transformers that are "pbp" AND "bugs"
1341             pbp and bugs Ditto
1342              
1343             bugs + cosmetic All transformers that are "bugs" OR "cosmetic"
1344             bugs or cosmetic Ditto
1345              
1346             pbp - cosmetic All transformers that are "pbp" BUT NOT "cosmetic"
1347             pbp not cosmetic Ditto
1348              
1349             -maintenance All transformers that are NOT "maintenance"
1350             not maintenance Ditto
1351              
1352             (pbp - bugs) * complexity All transformers that are "pbp" BUT NOT "bugs",
1353             AND "complexity"
1354             (pbp not bugs) and complexity Ditto
1355              
1356             Theme names are case-insensitive. If C<-theme> is set to an empty
1357             string, then it is equivalent to the set of all Transformers. A theme
1358             name that doesn't exist is equivalent to an empty set. Please See
1359             L<http://en.wikipedia.org/wiki/Set> for a discussion on set theory.
1360              
1361              
1362             =head1 SEE ALSO
1363              
1364             L<Perl::ToPerl6::OptionsProcessor|Perl::ToPerl6::OptionsProcessor>,
1365             L<Perl::ToPerl6::UserProfile|Perl::ToPerl6::UserProfile>
1366              
1367              
1368             =head1 AUTHOR
1369              
1370             Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>
1371              
1372              
1373             =head1 COPYRIGHT
1374              
1375             Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved.
1376              
1377             This program is free software; you can redistribute it and/or modify
1378             it under the same terms as Perl itself. The full text of this license
1379             can be found in the LICENSE file included with this module.
1380              
1381             =cut
1382              
1383             ##############################################################################
1384             # Local Variables:
1385             # mode: cperl
1386             # cperl-indent-level: 4
1387             # fill-column: 78
1388             # indent-tabs-mode: nil
1389             # c-indentation-style: bsd
1390             # End:
1391             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :