Skip to content

Commit 14c704b

Browse files
josegomezrokurzMartchus
committed
Unify Perl Critic
- Introducing `tools/perlcritic` an improved wrapper over perl's `perlcritic`. It automatically appends this project's policies that are defined under the `openqa` theme. - Adds a complementary GitHub Action to run `tools/perlcritic` automatically on Pull Requests & Master. - Fixed `perlcritics` complaints. Branched off os-autoinst#30. Co-authored-by: Oliver Kurz <[email protected]> Co-authored-by: Martchus <[email protected]>
1 parent aa0535c commit 14c704b

File tree

9 files changed

+245
-28
lines changed

9 files changed

+245
-28
lines changed

‎.github/workflows/perl-critic.yml

+17
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
---
2+
name: 'Perl critic'
3+
4+
on:
5+
pull_request:
6+
push:
7+
branches:
8+
- 'master'
9+
10+
perl-critic-checks:
11+
runs-on: ubuntu-latest
12+
name: "Perlcritic"
13+
container:
14+
image: perldocker/perl-tester
15+
steps:
16+
- uses: actions/checkout@v4
17+
- run: ./tools/perlcritic --quiet .

‎.perlcriticrc

+49
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,49 @@
1+
theme = community + openqa
2+
severity = 4
3+
include = strict ValuesAndExpressions::ProhibitInterpolationOfLiterals
4+
5+
verbose = ::warning file=%f,line=%l,col=%c,title=%m - severity %s::[%p] %e\n
6+
7+
# == Perlcritic Policies
8+
# -- Test::Most brings in strict & warnings
9+
[TestingAndDebugging::RequireUseStrict]
10+
equivalent_modules = Test::Most
11+
12+
[TestingAndDebugging::RequireUseWarnings]
13+
equivalent_modules = Test::Most
14+
15+
# -- Avoid double quotes unless there's interpolation or a single quote.
16+
[ValuesAndExpressions::ProhibitInterpolationOfLiterals]
17+
allow_if_string_contains_single_quote = 1
18+
severity = 3
19+
20+
# -- Prohibit deep nesting
21+
[ControlStructures::ProhibitDeepNests]
22+
severity = 4
23+
add_themes = community
24+
max_nests = 4
25+
26+
# == Community Policies
27+
# -- Test::Most brings in strict & warnings
28+
[Freenode::StrictWarnings]
29+
extra_importers = Test::Most
30+
31+
# -- Test::Most brings in strict & warnings
32+
[Community::StrictWarnings]
33+
extra_importers = Test::Most
34+
35+
[Community::DiscouragedModules]
36+
severity = 3
37+
38+
# Test modules have no package declaration
39+
[Community::PackageMatchesFilename]
40+
severity = 1
41+
42+
# == Custom Policies
43+
# -- Useless quotes on hashes
44+
[HashKeyQuotes]
45+
severity = 5
46+
47+
# -- Superfluous use strict/warning.
48+
[RedundantStrictWarning]
49+
equivalent_modules = Test::Most

‎lib/OpenQA/Test/PatchDeparse.pm

+20-21
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,8 @@ if (
1515
)
1616
{
1717

18-
#<<< do not let perltidy touch this
18+
#<<< do not let perltidy nor perlcritic touch this
19+
## no critic (TestingAndDebugging::ProhibitNoStrict ValuesAndExpressions::ProhibitInterpolationOfLiterals)
1920
# This is not our code, and formatting should stay the same for
2021
# better comparison with new versions of B::Deparse
2122
# <---- PATCH
@@ -28,25 +29,25 @@ no strict 'refs';
2829
my ($self, $op, $kids, $callback) = @_;
2930
my @kids = @$kids;
3031
for (my $i = 0; $i < @kids; $i++) {
31-
my $expr = "";
32-
if (is_state $kids[$i]) {
32+
my $expr = "";
33+
if (is_state $kids[$i]) {
3334
# Patch for:
3435
# Use of uninitialized value $expr in concatenation (.) or string at /usr/lib/perl5/5.26.1/B/Deparse.pm line 1794.
35-
$expr = $self->deparse($kids[$i++], 0) // ''; # prevent undef $expr
36-
if ($i > $#kids) {
37-
$callback->($expr, $i);
38-
last;
39-
}
40-
}
41-
if (is_for_loop($kids[$i])) {
42-
$callback->($expr . $self->for_loop($kids[$i], 0),
43-
$i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
44-
next;
45-
}
46-
my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2) // ''; # prevent undef $expr2
47-
$expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
48-
$expr .= $expr2;
49-
$callback->($expr, $i);
36+
$expr = $self->deparse($kids[$i++], 0) // ''; # prevent undef $expr
37+
if ($i > $#kids) {
38+
$callback->($expr, $i);
39+
last;
40+
}
41+
}
42+
if (is_for_loop($kids[$i])) {
43+
$callback->($expr . $self->for_loop($kids[$i], 0),
44+
$i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
45+
next;
46+
}
47+
my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2) // ''; # prevent undef $expr2
48+
$expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
49+
$expr .= $expr2;
50+
$callback->($expr, $i);
5051
}
5152

5253
};
@@ -60,7 +61,5 @@ elsif ($B::Deparse::VERSION) {
6061
diag
6162
"Using B::Deparse v$B::Deparse::VERSION. If you see 'uninitialized' warnings, update patch in t/lib/OpenQA/Test/PatchDeparse.pm";
6263
}
63-
64+
## use critic
6465
1;
65-
66-

‎lib/perlcritic/Perl/Critic/Policy/ArgumentInUseStrictWarnings.pm

+42
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
# Copyright SUSE LLC
2+
# SPDX-License-Identifier: GPL-2.0-or-later
3+
4+
package Perl::Critic::Policy::ArgumentInUseStrictWarnings;
5+
6+
use strict;
7+
use warnings;
8+
use experimental 'signatures';
9+
use base 'Perl::Critic::Policy';
10+
11+
use Perl::Critic::Utils qw( :severities :classification :ppi );
12+
13+
our $VERSION = '0.0.1';
14+
15+
sub default_severity { return $SEVERITY_HIGH }
16+
sub default_themes { return qw(openqa) }
17+
sub applies_to { return qw(PPI::Statement::Include) }
18+
19+
my $desc = q{use strict/warnings with arguments};
20+
my $expl = q{Remove argument from: %s.};
21+
22+
# check that use use strict and warnings don't have arguments.
23+
sub violates ($self, $elem, $document) {
24+
# skip if it's not a use
25+
return unless $elem->type() eq 'use';
26+
# skip if it's not a pragma
27+
return unless my $pragma = $elem->pragma();
28+
# skip if it's not warnings or strict
29+
return unless ($pragma eq 'warnings' || $pragma eq 'strict');
30+
31+
my @args = $elem->arguments();
32+
# skip if it doesn't have arguments
33+
return if scalar(@args) == 0;
34+
35+
# allow promoting warnings to FATAL
36+
return if scalar(grep { $_->content eq 'FATAL' } @args);
37+
38+
# Report the problem.
39+
return $self->violation($desc, sprintf($expl, $elem), $elem);
40+
}
41+
42+
1;

‎lib/perlcritic/Perl/Critic/Policy/HashKeyQuotes.pm

+34
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
# Copyright SUSE LLC
2+
# SPDX-License-Identifier: GPL-2.0-or-later
3+
4+
package Perl::Critic::Policy::HashKeyQuotes;
5+
6+
use strict;
7+
use warnings;
8+
use experimental 'signatures';
9+
use base 'Perl::Critic::Policy';
10+
11+
use Perl::Critic::Utils qw( :severities :classification :ppi );
12+
13+
our $VERSION = '0.0.1';
14+
15+
sub default_severity { return $SEVERITY_HIGH }
16+
sub default_themes { return qw(openqa) }
17+
sub applies_to { return qw(PPI::Token::Quote::Single PPI::Token::Quote::Double) }
18+
19+
# check that hashes are not overly using quotes
20+
# (os-autoinst coding style)
21+
sub violates ($self, $elem, $document) {
22+
#we only want the check hash keys
23+
return if !is_hash_key($elem);
24+
25+
my $c = $elem->content;
26+
# special characters
27+
return if $c =~ m/[- \/<>.=_:\\\$\|]/;
28+
29+
my $desc = q{Hash key with quotes};
30+
my $expl = q{Avoid useless quotes};
31+
return $self->violation($desc, $expl, $elem);
32+
}
33+
34+
1;

‎lib/perlcritic/Perl/Critic/Policy/RedundantStrictWarning.pm

+56
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
# Copyright SUSE LLC
2+
# SPDX-License-Identifier: GPL-2.0-or-later
3+
4+
package Perl::Critic::Policy::RedundantStrictWarning;
5+
6+
use strict;
7+
use warnings;
8+
use version 0.77;
9+
use experimental 'signatures';
10+
11+
use base 'Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict';
12+
use Perl::Critic::Utils qw{ $EMPTY };
13+
use Perl::Critic::Utils::Constants qw{ :equivalent_modules };
14+
15+
our $VERSION = '0.0.1';
16+
my $policy_title = q{Superfluoux use of strict/warning};
17+
my $policy_explanation = q{%s is equivalent to 'use strict; use warnings;'};
18+
19+
sub default_themes { return qw(openqa) }
20+
21+
sub supported_parameters {
22+
return (
23+
{
24+
name => 'equivalent_modules',
25+
description =>
26+
q<The additional modules to treat as equivalent to "strict" or "warnings".>,
27+
default_string => $EMPTY,
28+
behavior => 'string list',
29+
list_always_present_values => ['warnings', 'strict', @STRICT_EQUIVALENT_MODULES],
30+
},
31+
);
32+
}
33+
34+
# check that use strict/warnings is not present when equivalent modules are.
35+
sub violates ($self, $, $doc) {
36+
# Find all equivalents of use strict/warnings.
37+
my $use_stmts = $doc->find($self->_generate_is_use_strict());
38+
39+
# Bail if there's none.
40+
return unless $use_stmts;
41+
42+
# Bail out if there's only one. TestingAndDebugging::RequireUseStrict will report
43+
# that there's no use strict/warnings.
44+
return if scalar @{$use_stmts} == 1;
45+
46+
# If the 'use strict' or 'use warnings' statement is present as well as a
47+
# module already providing that behavior, -> it violates.
48+
return map { $self->_make_violation($_) } grep { !$_->pragma() } @{$use_stmts};
49+
}
50+
51+
sub _make_violation ($self, $statement) {
52+
return $self->violation($policy_title, sprintf($policy_explanation, $statement), $statement);
53+
}
54+
55+
1;
56+

‎tools/perlcritic

+20
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
#!/usr/bin/env perl
2+
# Copyright SUSE LLC
3+
# SPDX-License-Identifier: GPL-2.0-or-later
4+
#
5+
# perlcritic with auto-injection of custom perlcritic rules.
6+
use strict;
7+
use warnings;
8+
use experimental 'signatures';
9+
use FindBin '$Bin';
10+
11+
sub extra_include_paths (@extra_paths) {
12+
my @paths = map { ("$Bin/../$_", "$Bin/../external/os-autoinst-common/$_") } @extra_paths;
13+
14+
# Remove non existing paths
15+
return grep { -e $_ } @paths;
16+
}
17+
18+
$ENV{PERL5LIB} = join(':', (extra_include_paths('lib/perlcritic'), $ENV{PERL5LIB} // ''));
19+
20+
exec 'perlcritic', @ARGV;

‎tools/update-deps

+6-6
Original file line numberDiff line numberDiff line change
@@ -12,10 +12,10 @@ use Getopt::Long;
1212
use FindBin qw($Bin);
1313

1414
GetOptions(
15-
"help|h" => \my $help,
16-
"cpanfile" => \my $cpanfile,
17-
"specfile=s" => \my $specfile,
18-
"dockerfile=s" => \my $dockerfile,
15+
'help|h' => \my $help,
16+
cpanfile => \my $cpanfile,
17+
'specfile=s' => \my $specfile,
18+
'dockerfile=s' => \my $dockerfile,
1919
);
2020

2121
usage(0) if $help;
@@ -24,7 +24,7 @@ usage(1) unless ($cpanfile || $specfile || $dockerfile);
2424
my $proj_root = "$Bin/..";
2525

2626
my $scriptname = path(__FILE__)->to_rel($proj_root);
27-
my $dependencies_yaml_location = "dependencies.yaml";
27+
my $dependencies_yaml_location = 'dependencies.yaml';
2828
my $file = "$proj_root/$dependencies_yaml_location";
2929
my $cpanfile_location = "$proj_root/cpanfile";
3030

@@ -84,7 +84,7 @@ EOM
8484
}
8585

8686
sub update_spec {
87-
my $spec = path($specfile)->slurp if $specfile;
87+
my $spec = path($specfile)->slurp;
8888

8989
for my $target (@$spectargets) {
9090
my $name = $target . '_requires';

‎xt/01-make-update-deps.t

+1-1
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ use Test::Warnings;
77
use FindBin '$Bin';
88

99
if (not -e "$Bin/../.git") {
10-
pass("Skipping all tests, not in a git repository");
10+
pass('Skipping all tests, not in a git repository');
1111
done_testing;
1212
exit;
1313
}

0 commit comments

Comments
 (0)