Created
January 6, 2025 16:03
-
-
Save dennisjbell/713e6f2541e37da43376738f646657ab to your computer and use it in GitHub Desktop.
prove-only - a command line tool for only running perl tests through prove that match a specific pattern
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #!/usr/bin/env perl | |
| use strict; | |
| use warnings; | |
| use File::Basename qw(basename); | |
| use File::Temp qw(tempfile); | |
| use Text::Glob qw(match_glob); | |
| =head1 NAME | |
| prove-only - Run specific subtests in a Perl test script | |
| =head1 SYNOPSIS | |
| prove-only <test_script> <subtest_pattern1> [... <subtest_patternN>] | |
| =head1 DESCRIPTION | |
| The C<prove-only> script allows you to run specific subtests in a Perl test script. You can specify the subtests to run using glob-style pattern matching. Subtests that are inside other subtests can be referenced with C<< <parent test>/<child test> >> by default. The separator can be changed with an environmental variable if it conflicts with test names. | |
| If the pattern is less deep than the subtests, all subtests that are under a matching parent subtest will be run. In other words, the pattern '*' will match all subtests. If a subtest matches more than one pattern, it will be run only once. | |
| =head1 USAGE | |
| prove-only <test_script> <subtest_pattern1> [... <subtest_patternN>] | |
| =head1 ARGUMENTS | |
| =over 4 | |
| =item C<< <test_script> >> | |
| The path to the Perl test script you want to run. | |
| =item C<< <subtest_pattern1> [... <subtest_patternN>] >> | |
| One or more patterns specifying the subtests to run. Patterns can use glob-style matching. Subtests inside other subtests can be referenced with C<< <parent test>/<child test> >> by default. | |
| =back | |
| =head1 ENVIRONMENT VARIABLES | |
| =over 4 | |
| =item C<< PROVE_ONLY_TEST_SEPARATOR >> | |
| The separator used to reference subtests inside other subtests. The default is C</>. You can change this if it conflicts with test names. | |
| =item C<< PROVE_ONLY_TEST_OPTIONS >> | |
| Options to pass to the prove command to run the test script. The default is C<-lv>. | |
| =back | |
| =head1 EXAMPLES | |
| # Run only the 'cmp method' subtest | |
| perl prove-only t/00-utils-ip4.t 'cmp method' | |
| # Run the 'slice method/first' subtest inside the 'slice method' subtest | |
| perl prove-only t/00-utils-ip4.t 'slice method/first' | |
| # Run multiple subtests | |
| perl prove-only t/00-utils-ip4.t 'cmp method' 'slice method/first' | |
| # Change the separator to ':' | |
| export PROVE_ONLY_TEST_SEPARATOR=':' | |
| perl prove-only t/00-utils-ip4.t 'slice method:first' | |
| =head1 AUTHOR | |
| Dennis J. Bell <[email protected]> | |
| =head1 COPYRIGHT AND LICENSE | |
| Copyright (C) 2024 Rubidium Studios, Ltd. | |
| This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. | |
| =cut | |
| sub read_file { | |
| my ($file) = @_; | |
| open my $fh, "<", $file | |
| or die "failed to open '$file' for reading: $!\n"; | |
| my $contents = do { local $/; <$fh> }; | |
| close $fh; | |
| return $contents; | |
| } | |
| # Usage: perl skip_subtests.pl <test_script> <subtest_pattern1> <subtest_pattern2> ... | |
| my ($test_script, @patterns) = @ARGV; | |
| if (!@patterns) { | |
| die "Usage: $0 <test_script> <subtest_pattern1> <subtest_pattern2> ...\n"; | |
| } | |
| # Read the test script | |
| my $content = read_file($test_script); | |
| # Parse the test script and skip subtests that do not match the patterns | |
| my @lines = split /\n/, $content; | |
| my @output; | |
| my @stack; | |
| my @indents; | |
| my @skip; | |
| my @tests; | |
| my @skipped_tests; | |
| my @expected_tests; | |
| my $first_time = 1; | |
| my $done_testing = 0; | |
| my $separator = $ENV{PROVE_ONLY_TEST_SEPARATOR} // '/'; | |
| my $cmd_opts = $ENV{PROVE_ONLY_TEST_OPTIONS} // '-lv'; | |
| use Pry; pry; | |
| foreach my $line (@lines) { | |
| if ($line =~ /^(\s*use Test::More)(.*?)\s*tests\s*=>\s*(\d+)(.*)$/) { | |
| push @output, "$1$2$4"; | |
| next; | |
| } elsif ($line =~ /^(\s*)subtest\s+["']([^'"]+)['"]/) { | |
| if ($first_time) { | |
| push @output, "diag \"\\nRunning tests from $test_script that match the patterns: " . join(", ", @patterns) . "\\n\\n\";"; | |
| $first_time = 0; | |
| } | |
| my $subtest_name = $2; | |
| my $indent = $1; | |
| my $full_name = join($separator, @stack, $subtest_name); | |
| push @stack, $subtest_name; | |
| push @indents, $indent; | |
| my @level_patterns = (); | |
| my $level = scalar(@stack); | |
| for my $pattern (@patterns) { | |
| my @parts = split /${separator}/, $pattern; | |
| push @parts, '*' while @parts < $level; | |
| my $level_pattern = join($separator, @parts[0..$level-1]); | |
| push @level_patterns, $level_pattern | |
| unless grep { $_ eq $level_pattern } @level_patterns; | |
| } | |
| push @skip, scalar(grep { match_glob($_, $full_name) } @level_patterns) ? 0 : 1; | |
| if ($skip[-1]) { | |
| push @output, "${indent}diag \"\\e[30;1;3mSkipping subtest \\e[36m$full_name\\e[37n'\\e[0m\";" unless $skip[-2]; | |
| $skipped_tests[-1]++ if @skipped_tests; | |
| } else { | |
| $tests[-1]++ if @tests; | |
| } | |
| push @tests, 0; | |
| push @skipped_tests, 0; | |
| push @expected_tests, undef; | |
| } elsif (@indents && $line =~ /^$indents[-1]\};/) { | |
| my $name =pop @stack; | |
| my $skip = pop @skip; | |
| my $indent = pop @indents; | |
| my $tests = pop @tests; | |
| my $expected_tests = pop @expected_tests; | |
| my $skipped_tests = pop @skipped_tests; | |
| if (!$skip) { | |
| if (defined $expected_tests[-1]) { | |
| $expected_tests -= $skipped_tests; | |
| if ($expected_tests <= 0) { | |
| push @output, "$indent plan skip_all => \"No matching subtests to run\\n\\n\";"; | |
| } else { | |
| push @output, "$indent done_testing($expected_tests);"; | |
| } | |
| } elsif ($tests) { | |
| push @output, "$indent done_testing($tests);"; | |
| } else { | |
| push @output, "$indent plan skip_all => \"No matching subtests to run\\n\\n\";"; | |
| } | |
| push @output, $line; | |
| } | |
| $done_testing = 0; | |
| next; | |
| } elsif ($line =~ /^\s*plan tests => (\d+);/) { | |
| $expected_tests[-1] = $1; | |
| #push @output, "plan skip_all => 'Skipped by $0';" if $skip; | |
| next | |
| } elsif ($line =~ /^\s*done_testing\(\);/) { | |
| push @output, "done_testing();" unless $skip[-1]; | |
| $done_testing = 1; | |
| next | |
| } | |
| push @output, $line unless $skip[-1]; | |
| } | |
| push @output, "done_testing();" unless $done_testing; | |
| # Write the modified test script to a temporary file | |
| my $input_name = basename($test_script); | |
| my $suffix = (split /\./, $input_name)[-1]; | |
| my ($fh, $filename) = tempfile("${input_name}-skipped-XXXX", SUFFIX => $suffix, TMPDIR => 1); | |
| print $fh join("\n", @output); | |
| close $fh; | |
| # Run prove on the temporary file | |
| system("prove", grep {$_} ($cmd_opts), $filename); | |
| # Delete the temporary file | |
| unlink $filename; | |
| print "Temporary test script $filename has been deleted.\n"; |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment