File Coverage

lib/App/pherkin.pm
Criterion Covered Total %
statement 262 309 84.7
branch 78 118 66.1
condition 16 32 50.0
subroutine 32 34 94.1
pod 1 1 100.0
total 389 494 78.7


line stmt bran cond sub pod time code
1 4     4   260585 use v5.14;
  4         36  
2 4     4   25 use warnings;
  4         7  
  4         179  
3              
4             package App::pherkin 0.85;
5              
6              
7 4     4   561 use lib;
  4         767  
  4         29  
8 4     4   3507 use Getopt::Long;
  4         46266  
  4         20  
9 4     4   1723 use Module::Runtime qw(use_module module_notional_filename);
  4         3613  
  4         31  
10 4     4   261 use List::Util qw(max);
  4         9  
  4         248  
11 4     4   3138 use Pod::Usage;
  4         200250  
  4         672  
12 4     4   2240 use FindBin qw($RealBin $Script);
  4         4668  
  4         471  
13 4     4   1904 use YAML qw( LoadFile );
  4         28649  
  4         242  
14 4     4   2743 use Data::Dumper;
  4         26082  
  4         248  
15 4     4   38 use File::Spec;
  4         9  
  4         105  
16 4     4   1386 use Path::Class qw/file dir/;
  4         111979  
  4         304  
17              
18 4     4   2022 use Cucumber::TagExpressions;
  4         100360  
  4         206  
19              
20             use Test::BDD::Cucumber::I18n
21 4     4   1545 qw(languages langdef readable_keywords keyword_to_subname);
  4         12  
  4         410  
22 4     4   1693 use Test::BDD::Cucumber::Loader;
  4         29  
  4         166  
23              
24 4     4   27 use Moo;
  4         9  
  4         19  
25 4     4   1577 use Types::Standard qw( ArrayRef Bool Str );
  4         10  
  4         23  
26             has 'step_paths' => ( is => 'rw', isa => ArrayRef, default => sub { [] } );
27             has 'extensions' => ( is => 'rw', isa => ArrayRef, default => sub { [] } );
28             has 'tags' => ( is => 'rw', isa => Str, required => 0 );
29             has 'match_only' => ( is => 'rw', isa => Bool, default => 0 );
30             has 'matching' => ( is => 'rw', isa => Str, default => 'first');
31             has 'strict' => ( is => 'rw', isa => Bool, default => 0 );
32              
33             has 'harness' => ( is => 'rw' );
34              
35             =head1 NAME
36              
37             App::pherkin - Run Cucumber tests from the command line
38              
39             =head1 VERSION
40              
41             version 0.85
42              
43             =head1 SYNOPSIS
44              
45             pherkin
46             pherkin some/path/features/
47              
48             =head1 DESCRIPTION
49              
50             C will search the directory specified (or C<./features/>) for
51             feature files (any file matching C<*.feature>) and step definition files (any
52             file matching C<*_steps.pl>), loading the step definitions and then executing
53             the features.
54              
55             Steps that pass will be printed in green, those that fail in red, and those
56             for which there is no step definition as yellow (for TODO), assuming you're
57             using the default output harness.
58              
59             =head1 METHODS
60              
61             =head2 run
62              
63             The C class, which is what the C command uses, makes
64             use of the C method, which accepts currently a single path as a string,
65             or nothing.
66              
67             Returns a L object for all steps run.
68              
69             =cut
70              
71             sub _pre_run {
72 1     1   3 my ( $self, @arguments ) = @_;
73              
74             # localized features will have utf8 in them and options may output utf8 as
75             # well
76 1         6 binmode STDOUT, ':utf8';
77              
78 1         4 my ($features_path) = $self->_process_arguments(@arguments);
79 1   50     4 $features_path ||= './features/';
80              
81 1         8 my ( $executor, @features ) =
82             Test::BDD::Cucumber::Loader->load( $features_path );
83 1 50       4 die "No feature files found in $features_path" unless @features;
84              
85 1         25 $executor->matching( $self->matching );
86 1         57 $executor->add_extensions($_) for @{ $self->extensions };
  1         18  
87 1         90 $_->pre_execute($self) for @{ $self->extensions };
  1         18  
88              
89             Test::BDD::Cucumber::Loader->load_steps( $executor, $_ )
90 1         3 for @{ $self->step_paths };
  1         17  
91              
92 1         11 return ( $executor, @features );
93             }
94              
95             sub _post_run {
96 1     1   3 my $self = shift;
97              
98 1         2 $_->post_execute() for reverse @{ $self->extensions };
  1         18  
99             }
100              
101              
102             sub run {
103 1     1 1 4984 my ( $self, @arguments ) = @_;
104 1         4 my ( $executor, @features ) = $self->_pre_run(@arguments);
105              
106 1 50       19 if ( $self->match_only ) {
107 1 50       21 $self->_make_executor_match_only($executor) if $self->match_only;
108 1         5 $self->_rename_feature_steps( @features );
109             }
110              
111 1         46 my $result = $self->_run_tests( $executor, @features );
112 1         6 $self->_post_run;
113 1         35 return $result;
114             }
115              
116             sub _run_tests {
117 1     1   4 my ( $self, $executor, @features ) = @_;
118              
119 1         3 my $harness = $self->harness;
120 1         9 $harness->startup();
121              
122 1         2 my $tag_spec;
123 1 50       19 if ( $self->tags ) {
124 0         0 $tag_spec = Cucumber::TagExpressions->parse( $self->tags );
125             }
126              
127 1         27 $executor->execute( $_, $harness, $tag_spec ) for @features;
128              
129 1         4 $harness->shutdown();
130              
131 1         32 my $exit_code = 0;
132 1         15 my $result = $harness->result->result;
133 1 50       111 if ($result eq 'failing') {
    50          
134 0         0 $exit_code = 2;
135             }
136             elsif ($self->strict) {
137 0 0 0     0 if ($result eq 'pending'
138             or $result eq 'undefined') {
139 0         0 $exit_code = 1;
140             }
141             }
142              
143 1         14 return $exit_code;
144             }
145              
146             sub _initialize_harness {
147 12     12   243 my ( $self, $harness_module ) = @_;
148              
149 12         25 my $harness_args_string = undef;
150 12         36 ( $harness_module, $harness_args_string ) = split /\(/, $harness_module, 2;
151            
152 12 100       52 unless ( $harness_module =~ m/::/ ) {
153 8         26 $harness_module = "Test::BDD::Cucumber::Harness::" . $harness_module;
154             }
155              
156 12 50       20 eval { use_module($harness_module) }
  12         43  
157             || die "Unable to load harness [$harness_module]: $@";
158              
159 12 100       309 if ( $harness_args_string ) {
160 1         3 my %harness_args;
161 1 50       55 eval "%harness_args = ($harness_args_string; 1"
162             or die $@;
163 1         22 $self->harness( $harness_module->new( %harness_args ) );
164             } else {
165 11         131 $self->harness( $harness_module->new() );
166             }
167            
168             }
169              
170             sub _find_config_file {
171 18     18   182 my ( $self, $config_filename, $debug ) = @_;
172              
173 18 100       65 return $config_filename if $config_filename;
174              
175 8   100     47 for (
176             ( $ENV{'PHERKIN_CONFIG'} || () ),
177              
178             # Allow .yaml or .yml for all of the below
179 40         2160 map { ( "$_.yaml", "$_.yml" ) } (
180              
181             # Relative locations
182 32         2019 ( map { file($_) }
183             qw!.pherkin config/pherkin ./.config/pherkin t/.pherkin!
184             ),
185              
186             # Home locations
187 8         26 ( map { dir($_)->file('.pherkin') }
188 16         30 grep {$_} map { $ENV{$_} } qw/HOME USERPROFILE/
  16         574  
189             )
190             )
191             )
192             {
193 71 100       1006 return $_ if -f $_;
194 70 50       194 print "No config file found in $_\n" if $debug;
195             }
196 7         83 return undef;
197             }
198              
199             sub _replace_helper {
200 3     3   8 my $inval = shift;
201              
202 3   66     20 return $ENV{$inval} // "Environment variable $inval not defined";
203             }
204              
205             sub _resolve_envvars {
206 170     170   293 my ( $config_data ) = shift;
207              
208 170 100       272 if (ref $config_data) {
209 92 100       171 if (ref $config_data eq 'HASH') {
    50          
210             return {
211             map {
212 66         173 $_ => _resolve_envvars( $config_data->{$_} )
  123         236  
213             } keys %$config_data
214             };
215             }
216             elsif (ref $config_data eq 'ARRAY') {
217 26         44 return [ map { _resolve_envvars( $_ ) } @$config_data ];
  39         60  
218             }
219             else {
220 0         0 die 'Unhandled reference type in configuration data';
221             }
222             }
223             else {
224             # replace (in-place) ${ENVVAR_NAME} sequences with the envvar value
225 78         124 $config_data =~ s/(?
  3         8  
226             # remove any escaping double dollar-signs
227 78         134 $config_data =~ s/\$(\$\{[a-zA-Z0-9_]+\})/$1/g;
228             }
229              
230 78         317 return $config_data;
231             }
232              
233             sub _load_config {
234 16     16   8054 my ( $self, $profile_name, $proposed_config_filename, $debug ) = @_;
235              
236 16         48 my $config_filename
237             = $self->_find_config_file( $proposed_config_filename, $debug );
238 16         77 my $config_data_whole;
239              
240             # Check we can actually load some data from that file if required
241 16 100       40 if ($config_filename) {
242 9 50       56 print "Found [$config_filename], reading...\n" if $debug;
243 9         33 $config_data_whole = LoadFile($config_filename);
244 8 50       90861 $config_data_whole = _resolve_envvars( $config_data_whole )
245             if $config_data_whole;
246             } else {
247 7 50       17 if ($profile_name) {
248 0 0       0 print "No configuration files found\n" if $debug;
249 0         0 die
250             "Profile name [$profile_name] specified, but no configuration file found (use --debug-profiles to debug)";
251             } else {
252 7 50       24 print "No configuration files found, and no profile specified\n"
253             if $debug;
254 7         27 return;
255             }
256             }
257              
258 8 100       60 $profile_name = 'default' unless defined $profile_name;
259              
260             # Check the config file has the right type of data at the profile name
261 8 100       35 unless ( ref $config_data_whole eq 'HASH' ) {
262 1         6 die
263             "Config file [$config_filename] doesn't return a hashref on parse, instead a ["
264             . ref($config_data_whole) . ']';
265             }
266 7         19 my $config_data = $config_data_whole->{$profile_name};
267             my $profile_problem = sub {
268 3     3   16 return "Config file [$config_filename] profile [$profile_name]: "
269             . shift();
270 7         37 };
271 7 100       19 unless ($config_data) {
272 1         8 die $profile_problem->("Profile not found");
273             }
274 6 100       16 unless ( ( my $reftype = ref $config_data ) eq 'HASH' ) {
275 1         4 die $profile_problem->("[$reftype] but needs to be a HASH");
276             }
277 5 50       19 print "Using profile [$profile_name]\n" if $debug;
278              
279             # Transform it in to an argument list
280 5         7 my @arguments;
281 5         23 for my $key ( sort keys %$config_data ) {
282 9         18 my $value = $config_data->{$key};
283              
284 9 100       22 if ( my $reftype = ref $value ) {
285 6 100       23 if ( $key ne 'extensions' ) {
286 4 100       41 die $profile_problem->(
287             "Option $key is a [$reftype] but can only be a single value or ARRAY"
288             ) unless $reftype eq 'ARRAY';
289 3         16 push( @arguments, $key, $_ ) for @$value;
290             } else {
291 2 50 33     18 die $profile_problem->(
292             "Option $key is a [$reftype] but can only be a HASH as '$key' is"
293             . " a special case - see the documentation for details"
294             ) unless $reftype eq 'HASH' && $key eq 'extensions';
295 2         9 push( @arguments, $key, $value );
296             }
297             } else {
298 3         7 push( @arguments, $key, $value );
299             }
300             }
301              
302 4 50       11 if ($debug) {
303 0         0 print "Arguments to add: " . ( join ' ', @arguments ) . "\n";
304             }
305              
306 4         81 return @arguments;
307             }
308              
309             sub _process_arguments {
310 7     7   360 my ( $self, @args ) = @_;
311 7         25 local @ARGV = @args;
312              
313             # Allow -Ilib, -bl
314 7         41 Getopt::Long::Configure( 'bundling', 'pass_through' );
315              
316 7         420 my %options = (
317              
318             # Relating to other configuration options
319             config => ['g|config=s'],
320             profile => ['p|profile=s'],
321             debug_profiles => ['debug-profiles'],
322              
323             # Standard
324             help => [ 'h|help|?' ],
325             version => [ 'version' ],
326             includes => [ 'I=s@', [] ],
327             lib => [ 'l|lib' ],
328             blib => [ 'b|blib' ],
329             output => [ 'o|output=s' ],
330             strict => [ 'strict' ],
331             steps => [ 's|steps=s@', [] ],
332             tags => [ 't|tags=s' ],
333             i18n => [ 'i18n=s' ],
334             extensions => [ 'e|extension=s@', [] ],
335             matching => [ 'matching=s' ],
336             match_only => [ 'm|match' ],
337             );
338              
339             GetOptions(
340             map {
341 7         32 my $x;
  112         131  
342 112 100       229 $_->[1] = \$x unless defined $_->[1];
343 112         232 ( $_->[0] => $_->[1] );
344             } values %options
345             );
346              
347             my $deref = sub {
348 132     132   203 my $key = shift;
349 132         211 my $value = $options{$key}->[1];
350 132 100       734 return ( ref $value eq 'ARRAY' ) ? $value : $$value;
351 7         9936 };
352              
353 7 50       23 if ( $deref->('version') ) {
354 0         0 my ($vol, $dirs, $file) = File::Spec->splitpath( $0 );
355 0   0     0 my $version = $App::pherkin::VERSION || '(development)';
356 0         0 print "$file $version\n";
357              
358 0         0 exit 0;
359             }
360              
361             pod2usage(
362 7 50       21 -verbose => 1,
363             -input => "$RealBin/$Script",
364             ) if $deref->('help');
365              
366 7         14 my @parsed_extensions;
367 7         11 for my $e ( @{ $deref->('extensions') } ) {
  7         19  
368 2         5 my $e_args = "()";
369 2 50       21 $e_args = $1 if $e =~ s/\((.+)\)$//;
370 2         116 my @e_args = eval $e_args;
371 2 50       20 die "Bad arguments in [$e]: $@" if $@;
372              
373 2         12 push( @parsed_extensions, [ $e, \@e_args ] );
374             }
375 7         33 $options{extensions}->[1] = \@parsed_extensions;
376              
377             # Load the configuration file
378 7         23 my @configuration_options = $self->_load_config( map { $deref->($_) }
  21         38  
379             qw/profile config debug_profiles/ );
380              
381             # Merge those configuration items
382             # First we need a list of matching keys
383             my %keys = map {
384 7         39 my ( $key_basis, $ref ) = @{ $options{$_} };
  112         141  
  112         194  
385 301         593 map { $_ => $ref }
386 112         217 map { s/=.+//; $_ } ( split( /\|/, $key_basis ), $_ );
  301         513  
  301         486  
387             } keys %options;
388              
389             # Now let's go through each option. For arrays, we want the configuration
390             # options to appear in order at the front. So if configuration had 1, 2,
391             # and command line options were 3, 4, we want: 1, 2, 3, 4. This is not
392             # straight forward.
393 7         49 my %additions;
394 7         30 while (@configuration_options) {
395 5         11 my ($key) = shift(@configuration_options);
396 5         11 my ($value) = shift(@configuration_options);
397 5   50     14 my $target = $keys{$key} || die "Unknown configuration option [$key]";
398              
399 5 100 66     31 if ( $key eq 'extensions' || $key eq 'extension' ) {
    100          
400 1 50       8 die "Value of $key in config file expected to be HASH but isn't"
401             if ref $value ne 'HASH';
402              
403             # if the configuration of the extension is 'undef', then
404             # none was defined. Replace it with an empty hashref, which
405             # is what Moo's 'new()' method wants later on
406 1   50     4 my @e = map { [ $_, [ $value->{$_} || {} ] ] } keys %$value;
  1         8  
407 1         4 $value = \@e;
408 1   50     8 my $array = $additions{ 0 + $target } ||= [];
409 1         4 push( @$array, @$value );
410 1 50       4 print "Adding extensions near the front of $key"
411             if $deref->('debug_profiles');
412             } elsif ( ref $target ne 'ARRAY' ) {
413              
414             # Only use it if we don't have something already
415 2 100       18 if ( defined $$target ) {
416 1 50       4 print
417             "Ignoring $key from config file because set on cmd line as $$target\n"
418             if $deref->('debug_profiles');
419             } else {
420 1         6 $$target = $value;
421 1 50       7 print "Set $key to $target from config file\n"
422             if $deref->('debug_profiles');
423             }
424              
425             } else {
426 2   100     15 my $array = $additions{ 0 + $target } ||= [];
427 2         6 push( @$array, $value );
428 2 50       4 print "Adding $value near the front of $key\n"
429             if $deref->('debug_profiles');
430             }
431             }
432 7         33 for my $target ( values %options ) {
433 112 100       221 next unless ref $target->[1] eq 'ARRAY';
434 21         56 my $key = $target->[1] + 0;
435 21 100       28 unshift( @{ $target->[1] }, @{ $additions{$key} || [] } );
  21         36  
  21         101  
436             }
437              
438 7 50       37 if ( $deref->('debug_profiles') ) {
439 0         0 print "Values are:\n";
440 0         0 for ( sort keys %options ) {
441 0         0 printf( " %16s: ", $_ );
442 0         0 my $value = $deref->($_);
443 0 0       0 if ( ref $value ) {
444 0         0 print join ', ', @$value;
445             } else {
446 0 0       0 print( ( defined $value ) ? $value : '[undefined]' );
447             }
448 0         0 print "\n";
449             }
450 0         0 exit;
451             }
452              
453 7 50       19 if ( my $i18n = $deref->('i18n') ) {
454 0 0       0 _print_langdef($i18n) unless $i18n eq 'help';
455 0         0 _print_languages();
456             }
457              
458 7 100       21 unshift @{ $deref->('includes') }, 'lib' if $deref->('lib');
  3         6  
459 7 100       15 unshift @{ $deref->('includes') }, 'blib/lib', 'blib/arch'
  2         7  
460             if $deref->('blib');
461              
462             # We may need some of the imported paths...
463 7         22 lib->import( @{ $deref->('includes') } );
  7         20  
464              
465             # Load any extensions
466 7         818 for my $e ( @{ $deref->('extensions') } ) {
  7         16  
467 3         12 my ( $c, $a ) = @$e;
468 3         13 use_module $c;
469              
470 3         3100 my $instance = $c->new(@$a);
471 3         2163 push( @{ $self->extensions }, $instance );
  3         94  
472              
473 3         33 my $dir = file( $INC{ module_notional_filename($c) } )->dir;
474 3         46 my @step_dirs = map { File::Spec->rel2abs( $_, $dir ) }
475 3         354 @{ $instance->step_directories };
  3         9  
476 3         288 unshift( @{ $deref->('steps') }, @step_dirs );
  3         9  
477             }
478              
479             # Munge the output harness
480 7   50     20 $self->_initialize_harness( $deref->('output') || "TermColor" );
481              
482             # Store any extra step paths
483 7         196 $self->step_paths( $deref->('steps') );
484              
485 7 50       193 $self->matching( $deref->('matching') )
486             if $deref->('matching');
487              
488             # Match only?
489 7         21 $self->match_only( $deref->('match_only') );
490              
491 7 50       196 $self->strict( $deref->('strict') )
492             if $deref->('strict');
493              
494 7         120 return ( pop @ARGV );
495             }
496              
497             sub _print_languages {
498              
499 0     0   0 my @languages = languages();
500              
501 0         0 my $max_code_length = max map {length} @languages;
  0         0  
502             my $max_name_length
503 0         0 = max map { length( langdef($_)->{name} ) } @languages;
  0         0  
504             my $max_native_length
505 0         0 = max map { length( langdef($_)->{native} ) } @languages;
  0         0  
506              
507 0         0 my $format
508             = "| %-${max_code_length}s | %-${max_name_length}s | %-${max_native_length}s |\n";
509              
510 0         0 for my $language ( sort @languages ) {
511 0         0 my $langdef = langdef($language);
512 0         0 printf $format, $language, $langdef->{name}, $langdef->{native};
513             }
514 0         0 exit;
515             }
516              
517             sub _print_langdef {
518 0     0   0 my ($language) = @_;
519              
520 0         0 my $langdef = langdef($language);
521              
522 0         0 my @keywords = qw(feature background scenario scenarioOutline examples
523             given when then and but);
524             my $max_length
525 0         0 = max map { length readable_keywords( $langdef->{$_} ) } @keywords;
  0         0  
526              
527 0         0 my $format = "| %-16s | %-${max_length}s |\n";
528 0         0 for my $keyword (
529             qw(feature background scenario scenarioOutline
530             examples given when then and but )
531             )
532             {
533 0         0 printf $format, $keyword, readable_keywords( $langdef->{$keyword} );
534             }
535              
536 0         0 my $codeformat = "| %-16s | %-${max_length}s |\n";
537 0         0 for my $keyword (qw(given when then )) {
538             printf $codeformat, $keyword . ' (code)',
539 0         0 readable_keywords( $langdef->{$keyword}, \&keyword_to_subname );
540             }
541              
542 0         0 exit;
543             }
544              
545             sub _make_executor_match_only {
546 1     1   12 my ($self, $executor) = @_;
547              
548             my $match_sub = sub {
549 3     3   5 my $context = shift;
550 3         104 $Test::Builder::Test->ok( 1, "Test matched" );
551 3         1170 return 1;
552 1         4 };
553              
554 1         2 for my $verb ( keys %{$executor->steps} ) {
  1         19  
555 3         14 for my $step_tuple ( @{ $executor->steps->{$verb} } ) {
  3         47  
556 3         23 $step_tuple->[2] = $match_sub;
557             }
558             }
559              
560 1         3 return 1;
561             }
562              
563             sub _rename_feature_steps {
564 1     1   3 my ($self, @features) = @_;
565              
566 1         2 my %steps;
567 1         2 for my $feature ( @features ) {
568 1         21 for my $scenario ( $feature->background, @{ $feature->scenarios } ) {
  1         22  
569 2 100       10 next unless $scenario;
570 1         3 for my $step ( @{ $scenario->steps } ) {
  1         16  
571 3         15 $steps{ $step . '' } = $step;
572             }
573             }
574             }
575              
576 1         3 for my $step_object ( values %steps ) {
577 3   33     146 $step_object->verb_original(
578             'MATCH MODE: ' . ( $step_object->verb_original || $step_object->verb )
579             );
580             }
581             }
582              
583             =head1 AUTHOR
584              
585             Peter Sergeant C
586              
587             =head1 LICENSE
588              
589             Copyright 2019-2023, Erik Huelsmann
590             Copyright 2011-2019, Peter Sergeant; Licensed under the same terms as Perl
591              
592             =cut
593              
594             1;