diff --git a/.github/workflows/perl-critic.yml b/.github/workflows/perl-critic.yml new file mode 100644 index 0000000..754dd16 --- /dev/null +++ b/.github/workflows/perl-critic.yml @@ -0,0 +1,17 @@ +--- +name: 'Perl critic' + +on: + pull_request: + push: + branches: + - 'master' + + perl-critic-checks: + runs-on: ubuntu-latest + name: "Perlcritic" + container: + image: perldocker/perl-tester + steps: + - uses: actions/checkout@v4 + - run: ./tools/perlcritic --quiet . diff --git a/.perlcriticrc b/.perlcriticrc new file mode 100644 index 0000000..6610c16 --- /dev/null +++ b/.perlcriticrc @@ -0,0 +1,49 @@ +theme = community + openqa +severity = 4 +include = strict ValuesAndExpressions::ProhibitInterpolationOfLiterals + +verbose = ::warning file=%f,line=%l,col=%c,title=%m - severity %s::[%p] %e\n + +# == Perlcritic Policies +# -- Test::Most brings in strict & warnings +[TestingAndDebugging::RequireUseStrict] +equivalent_modules = Test::Most + +[TestingAndDebugging::RequireUseWarnings] +equivalent_modules = Test::Most + +# -- Avoid double quotes unless there's interpolation or a single quote. +[ValuesAndExpressions::ProhibitInterpolationOfLiterals] +allow_if_string_contains_single_quote = 1 +severity = 3 + +# -- Prohibit deep nesting +[ControlStructures::ProhibitDeepNests] +severity = 4 +add_themes = community +max_nests = 4 + +# == Community Policies +# -- Test::Most brings in strict & warnings +[Freenode::StrictWarnings] +extra_importers = Test::Most + +# -- Test::Most brings in strict & warnings +[Community::StrictWarnings] +extra_importers = Test::Most + +[Community::DiscouragedModules] +severity = 3 + +# Test modules have no package declaration +[Community::PackageMatchesFilename] +severity = 1 + +# == Custom Policies +# -- Useless quotes on hashes +[HashKeyQuotes] +severity = 5 + +# -- Superfluous use strict/warning. +[RedundantStrictWarning] +equivalent_modules = Test::Most \ No newline at end of file diff --git a/lib/OpenQA/Test/PatchDeparse.pm b/lib/OpenQA/Test/PatchDeparse.pm index 429c27f..5f6d22b 100644 --- a/lib/OpenQA/Test/PatchDeparse.pm +++ b/lib/OpenQA/Test/PatchDeparse.pm @@ -15,7 +15,8 @@ if ( ) { -#<<< do not let perltidy touch this +#<<< do not let perltidy nor perlcritic touch this +## no critic (TestingAndDebugging::ProhibitNoStrict ValuesAndExpressions::ProhibitInterpolationOfLiterals) # This is not our code, and formatting should stay the same for # better comparison with new versions of B::Deparse # <---- PATCH @@ -28,25 +29,25 @@ no strict 'refs'; my ($self, $op, $kids, $callback) = @_; my @kids = @$kids; for (my $i = 0; $i < @kids; $i++) { - my $expr = ""; - if (is_state $kids[$i]) { + my $expr = ""; + if (is_state $kids[$i]) { # Patch for: # Use of uninitialized value $expr in concatenation (.) or string at /usr/lib/perl5/5.26.1/B/Deparse.pm line 1794. - $expr = $self->deparse($kids[$i++], 0) // ''; # prevent undef $expr - if ($i > $#kids) { - $callback->($expr, $i); - last; - } - } - if (is_for_loop($kids[$i])) { - $callback->($expr . $self->for_loop($kids[$i], 0), - $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1); - next; - } - my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2) // ''; # prevent undef $expr2 - $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise - $expr .= $expr2; - $callback->($expr, $i); + $expr = $self->deparse($kids[$i++], 0) // ''; # prevent undef $expr + if ($i > $#kids) { + $callback->($expr, $i); + last; + } + } + if (is_for_loop($kids[$i])) { + $callback->($expr . $self->for_loop($kids[$i], 0), + $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1); + next; + } + my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2) // ''; # prevent undef $expr2 + $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise + $expr .= $expr2; + $callback->($expr, $i); } }; @@ -60,7 +61,5 @@ elsif ($B::Deparse::VERSION) { diag "Using B::Deparse v$B::Deparse::VERSION. If you see 'uninitialized' warnings, update patch in t/lib/OpenQA/Test/PatchDeparse.pm"; } - +## use critic 1; - - diff --git a/lib/perlcritic/Perl/Critic/Policy/ArgumentInUseStrictWarnings.pm b/lib/perlcritic/Perl/Critic/Policy/ArgumentInUseStrictWarnings.pm new file mode 100644 index 0000000..4c24edb --- /dev/null +++ b/lib/perlcritic/Perl/Critic/Policy/ArgumentInUseStrictWarnings.pm @@ -0,0 +1,42 @@ +# Copyright SUSE LLC +# SPDX-License-Identifier: GPL-2.0-or-later + +package Perl::Critic::Policy::ArgumentInUseStrictWarnings; + +use strict; +use warnings; +use experimental 'signatures'; +use base 'Perl::Critic::Policy'; + +use Perl::Critic::Utils qw( :severities :classification :ppi ); + +our $VERSION = '0.0.1'; + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw(openqa) } +sub applies_to { return qw(PPI::Statement::Include) } + +my $desc = q{use strict/warnings with arguments}; +my $expl = q{Remove argument from: %s.}; + +# check that use use strict and warnings don't have arguments. +sub violates ($self, $elem, $document) { + # skip if it's not a use + return unless $elem->type() eq 'use'; + # skip if it's not a pragma + return unless my $pragma = $elem->pragma(); + # skip if it's not warnings or strict + return unless ($pragma eq 'warnings' || $pragma eq 'strict'); + + my @args = $elem->arguments(); + # skip if it doesn't have arguments + return if scalar(@args) == 0; + + # allow promoting warnings to FATAL + return if scalar(grep { $_->content eq 'FATAL' } @args); + + # Report the problem. + return $self->violation($desc, sprintf($expl, $elem), $elem); +} + +1; diff --git a/lib/perlcritic/Perl/Critic/Policy/HashKeyQuotes.pm b/lib/perlcritic/Perl/Critic/Policy/HashKeyQuotes.pm new file mode 100644 index 0000000..d71f441 --- /dev/null +++ b/lib/perlcritic/Perl/Critic/Policy/HashKeyQuotes.pm @@ -0,0 +1,34 @@ +# Copyright SUSE LLC +# SPDX-License-Identifier: GPL-2.0-or-later + +package Perl::Critic::Policy::HashKeyQuotes; + +use strict; +use warnings; +use experimental 'signatures'; +use base 'Perl::Critic::Policy'; + +use Perl::Critic::Utils qw( :severities :classification :ppi ); + +our $VERSION = '0.0.1'; + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw(openqa) } +sub applies_to { return qw(PPI::Token::Quote::Single PPI::Token::Quote::Double) } + +# check that hashes are not overly using quotes +# (os-autoinst coding style) +sub violates ($self, $elem, $document) { + #we only want the check hash keys + return if !is_hash_key($elem); + + my $c = $elem->content; + # special characters + return if $c =~ m/[- \/<>.=_:\\\$\|]/; + + my $desc = q{Hash key with quotes}; + my $expl = q{Avoid useless quotes}; + return $self->violation($desc, $expl, $elem); +} + +1; diff --git a/lib/perlcritic/Perl/Critic/Policy/RedundantStrictWarning.pm b/lib/perlcritic/Perl/Critic/Policy/RedundantStrictWarning.pm new file mode 100644 index 0000000..1f6a3b1 --- /dev/null +++ b/lib/perlcritic/Perl/Critic/Policy/RedundantStrictWarning.pm @@ -0,0 +1,56 @@ +# Copyright SUSE LLC +# SPDX-License-Identifier: GPL-2.0-or-later + +package Perl::Critic::Policy::RedundantStrictWarning; + +use strict; +use warnings; +use version 0.77; +use experimental 'signatures'; + +use base 'Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict'; +use Perl::Critic::Utils qw{ $EMPTY }; +use Perl::Critic::Utils::Constants qw{ :equivalent_modules }; + +our $VERSION = '0.0.1'; +my $policy_title = q{Superfluoux use of strict/warning}; +my $policy_explanation = q{%s is equivalent to 'use strict; use warnings;'}; + +sub default_themes { return qw(openqa) } + +sub supported_parameters { + return ( + { + name => 'equivalent_modules', + description => + q, + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => ['warnings', 'strict', @STRICT_EQUIVALENT_MODULES], + }, + ); +} + +# check that use strict/warnings is not present when equivalent modules are. +sub violates ($self, $, $doc) { + # Find all equivalents of use strict/warnings. + my $use_stmts = $doc->find($self->_generate_is_use_strict()); + + # Bail if there's none. + return unless $use_stmts; + + # Bail out if there's only one. TestingAndDebugging::RequireUseStrict will report + # that there's no use strict/warnings. + return if scalar @{$use_stmts} == 1; + + # If the 'use strict' or 'use warnings' statement is present as well as a + # module already providing that behavior, -> it violates. + return map { $self->_make_violation($_) } grep { !$_->pragma() } @{$use_stmts}; +} + +sub _make_violation ($self, $statement) { + return $self->violation($policy_title, sprintf($policy_explanation, $statement), $statement); +} + +1; + diff --git a/tools/perlcritic b/tools/perlcritic new file mode 100755 index 0000000..80b85b4 --- /dev/null +++ b/tools/perlcritic @@ -0,0 +1,20 @@ +#!/usr/bin/env perl +# Copyright SUSE LLC +# SPDX-License-Identifier: GPL-2.0-or-later +# +# perlcritic with auto-injection of custom perlcritic rules. +use strict; +use warnings; +use experimental 'signatures'; +use FindBin '$Bin'; + +sub extra_include_paths (@extra_paths) { + my @paths = map { ("$Bin/../$_", "$Bin/../external/os-autoinst-common/$_") } @extra_paths; + + # Remove non existing paths + return grep { -e $_ } @paths; +} + +$ENV{PERL5LIB} = join(':', (extra_include_paths('lib/perlcritic'), $ENV{PERL5LIB} // '')); + +exec 'perlcritic', @ARGV; diff --git a/tools/update-deps b/tools/update-deps index 4d217d6..3b6bdb3 100755 --- a/tools/update-deps +++ b/tools/update-deps @@ -12,10 +12,10 @@ use Getopt::Long; use FindBin qw($Bin); GetOptions( - "help|h" => \my $help, - "cpanfile" => \my $cpanfile, - "specfile=s" => \my $specfile, - "dockerfile=s" => \my $dockerfile, + 'help|h' => \my $help, + cpanfile => \my $cpanfile, + 'specfile=s' => \my $specfile, + 'dockerfile=s' => \my $dockerfile, ); usage(0) if $help; @@ -24,7 +24,7 @@ usage(1) unless ($cpanfile || $specfile || $dockerfile); my $proj_root = "$Bin/.."; my $scriptname = path(__FILE__)->to_rel($proj_root); -my $dependencies_yaml_location = "dependencies.yaml"; +my $dependencies_yaml_location = 'dependencies.yaml'; my $file = "$proj_root/$dependencies_yaml_location"; my $cpanfile_location = "$proj_root/cpanfile"; @@ -84,7 +84,7 @@ EOM } sub update_spec { - my $spec = path($specfile)->slurp if $specfile; + my $spec = path($specfile)->slurp; for my $target (@$spectargets) { my $name = $target . '_requires'; diff --git a/xt/01-make-update-deps.t b/xt/01-make-update-deps.t index 2d40642..d6a5e7a 100755 --- a/xt/01-make-update-deps.t +++ b/xt/01-make-update-deps.t @@ -7,7 +7,7 @@ use Test::Warnings; use FindBin '$Bin'; if (not -e "$Bin/../.git") { - pass("Skipping all tests, not in a git repository"); + pass('Skipping all tests, not in a git repository'); done_testing; exit; }