diff --git a/bin/pg-critic.pl b/bin/pg-critic.pl new file mode 100755 index 000000000..2c4431d95 --- /dev/null +++ b/bin/pg-critic.pl @@ -0,0 +1,140 @@ +#!/usr/bin/env perl + +=head1 NAME + +pg-critic.pl - Command line interface to critque PG problem code. + +=head1 SYNOPSIS + + pg-critic.pl [options] file1 file2 ... + +Options: + + -f|--format Format of the output, either 'text' or 'json'. + 'text' is the default and will output a plain text + listing of the results. 'json' will output results in + JavaScript Object Notation. + -o|--output-file Filename to write output to. If not provided output will + be printed to STDOUT. + -n|--no-details Only show the filename and badness score and do not + include the details in the output for each file. + -s|--strict Disable "## no critic" annotations and force all + policies to be enforced. + -p|--pg-only Only include PG critic policy violations and ignore + general Perl critic policy violations (both for the + score and display). + -h|--help Show the help message. + +=head1 DESCRIPTION + +C is a PG problem source code analyzer. It is the executable +front-end to the L module, which attempts to identify usage +of old or deprecated PG features and code that does not conform to current +best-practices. + +=cut + +use Mojo::Base -signatures; + +use Mojo::File qw(curfile path); +use Mojo::JSON qw(encode_json); +use Getopt::Long; +use Pod::Usage; + +use lib curfile->dirname->dirname . '/lib'; + +use WeBWorK::PG::Critic qw(critiquePGFile); + +GetOptions( + 'f|format=s' => \my $format, + 'o|output-file=s' => \my $filename, + 'n|no-details' => \my $noDetails, + 's|strict' => \my $force, + 'p|pg-only' => \my $pgOnly, + 'h|help' => \my $show_help +); +pod2usage(2) if $show_help; + +$format //= 'text'; + +$format = lc($format); + +unless (@ARGV) { + say 'A list of pg problem files must be provided.'; + pod2usage(2); +} +unless ($format eq 'text' || $format eq 'json') { + say 'The output format must be "text" or "json"'; + pod2usage(2); +} + +sub scoreProblem (@violations) { + my $score = 0; + for (@violations) { + if ($_->policy =~ /^Perl::Critic::Policy::PG::/) { + $score += $_->explanation->{score} // 0; + } else { + # Add 5 points for any of the default Perl::Critic::Policy violations. + # These will not have a score in the explanation. + $score += 5; + } + } + return $score; +} + +my @results; + +for (@ARGV) { + my @violations = critiquePGFile($_, $force); + @violations = grep { $_->policy =~ /^Perl::Critic::Policy::PG::/ } @violations if $pgOnly; + + my (@pgCriticViolations, @perlCriticViolations); + if (!$noDetails) { + @pgCriticViolations = grep { $_->policy =~ /^Perl::Critic::Policy::PG::/ } @violations; + @perlCriticViolations = grep { $_->policy !~ /^Perl::Critic::Policy::PG::/ } @violations; + } + + push( + @results, + { + file => $_, + score => scoreProblem(@violations), + $noDetails + ? () + : ( + @pgCriticViolations ? (pgCriticViolations => \@pgCriticViolations) : (), + @perlCriticViolations ? (perlCriticViolations => \@perlCriticViolations) : () + ) + } + ); +} + +Perl::Critic::Violation::set_format('%m at line %l, column %c. (%p)'); + +my $outputMethod = $format eq 'json' ? \&encode_json : sub { + my $results = shift; + + return join( + "\n", + map { ( + "Filename: $_->{file}", + "Score: $_->{score}", + @{ $_->{pgCriticViolations} // [] } + ? ('PG critic violations:', map { "\t" . $_->to_string } @{ $_->{pgCriticViolations} }) + : (), + @{ $_->{perlCriticViolations} // [] } + ? ('Perl critic violations:', map { "\t" . $_->to_string } @{ $_->{perlCriticViolations} }) + : () + ) } @$results + ); +}; + +if ($filename) { + eval { path($filename)->spew($outputMethod->(\@results), 'UTF-8') }; + if ($@) { say "Unable to write results to $filename: $@"; } + else { say "Results written in $format format to $filename"; } +} else { + say $outputMethod->(\@results); +} + +1; diff --git a/cpanfile b/cpanfile index 12c7e39b7..00b469c47 100644 --- a/cpanfile +++ b/cpanfile @@ -24,6 +24,12 @@ on runtime => sub { # Needed for Rserve recommends 'IO::Handle'; + + # Needed for WeBWorK::PG::Tidy + recommends 'Perl::Tidy'; + + # Needed for WeBWorK::PG::PGProblemCritic + recommends 'Perl::Critic'; }; on test => sub { diff --git a/lib/Perl/Critic/Policy/PG/ProhibitBeginproblem.pm b/lib/Perl/Critic/Policy/PG/ProhibitBeginproblem.pm new file mode 100644 index 000000000..ee2e300b9 --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitBeginproblem.pm @@ -0,0 +1,36 @@ +package Perl::Critic::Policy::PG::ProhibitBeginproblem; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use WeBWorK::PG::Critic::Utils qw(getDeprecatedMacros); + +use constant DESCRIPTION => 'The beingproblem function is called'; +use constant EXPLANATION => 'The beingproblem function no longer does anything and should be removed.'; +use constant SCORE => 5; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::Word) } + +sub violates ($self, $element, $) { + return unless $element eq 'beginproblem' && is_function_call($element); + return $self->violation(DESCRIPTION, { score => SCORE, explanation => EXPLANATION }, $element); +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitBeginproblem - The C function is +deprecated, no longer does anything, and should be removed from all problems. + +=head1 DESCRIPTION + +The C function is deprecated, no longer does anything, and should +be removed from all problems. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitContextStrings.pm b/lib/Perl/Critic/Policy/PG/ProhibitContextStrings.pm new file mode 100644 index 000000000..309ee1a83 --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitContextStrings.pm @@ -0,0 +1,40 @@ +package Perl::Critic::Policy::PG::ProhibitContextStrings; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use WeBWorK::PG::Critic::Utils qw(getDeprecatedMacros); + +use constant DESCRIPTION => 'Context()->%s is called'; +use constant EXPLANATION => 'Context()->%s no longer necessary and should be removed.'; +use constant SCORE => 5; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::Word) } + +sub violates ($self, $element, $) { + return + unless ($element eq 'texStrings' || $element eq 'normalStrings') + && is_method_call($element) + && $element->parent =~ /^Context/; + return $self->violation(sprintf(DESCRIPTION, $element), + { score => SCORE, explanation => sprintf(EXPLANATION, $element) }, $element); +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::RequireContextStrings - C<< Context()->texStrings >> +and C<< Context->normalStrings >> calls are not necessary and should be removed. + +=head1 DESCRIPTION + +Calling C<< Context()->texStrings >> and C<< Context->normalStrings >> is no +longer necessary and should be removed from problems. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedCmp.pm b/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedCmp.pm new file mode 100644 index 000000000..4af90b468 --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedCmp.pm @@ -0,0 +1,85 @@ +package Perl::Critic::Policy::PG::ProhibitDeprecatedCmp; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use constant DESCRIPTION => 'The deprecated %s method is called'; +use constant EXPLANATION => 'Convert the answer into a MathObject and use the cmp method of the object.'; +use constant SCORE => 55; + +use constant CMP_METHODS => { + str_cmp => 1, + std_str_cmp => 1, + std_str_cmp_list => 1, + std_cs_str_cmp => 1, + std_cs_str_cmp_list => 1, + strict_str_cmp => 1, + strict_str_cmp_list => 1, + unordered_str_cmp => 1, + unordered_str_cmp_list => 1, + unordered_cs_str_cmp => 1, + unordered_cs_str_cmp_list => 1, + ordered_str_cmp => 1, + ordered_str_cmp_list => 1, + ordered_cs_str_cmp => 1, + ordered_cs_str_cmp_list => 1, + num_cmp => 1, + num_rel_cmp => 1, + std_num_cmp => 1, + std_num_cmp_list => 1, + std_num_cmp_abs => 1, + std_num_cmp_abs_list => 1, + frac_num_cmp => 1, + frac_num_cmp_list => 1, + frac_num_cmp_abs => 1, + frac_num_cmp_abs_list => 1, + arith_num_cmp => 1, + arith_num_cmp_list => 1, + arith_num_cmp_abs => 1, + arith_num_cmp_abs_list => 1, + strict_num_cmp => 1, + strict_num_cmp_list => 1, + strict_num_cmp_abs => 1, + strict_num_cmp_abs_list => 1, + std_num_str_cmp => 1, + fun_cmp => 1, + function_cmp => 1, + function_cmp_up_to_constant => 1, + function_cmp_abs => 1, + function_cmp_up_to_constant_abs => 1, + adaptive_function_cmp => 1, + multivar_function_cmp => 1, + cplx_cmp => 1, + multi_cmp => 1, + radio_cmp => 1, + checkbox_cmp => 1, +}; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::Word) } + +sub violates ($self, $element, $document) { + return unless CMP_METHODS->{$element} && is_function_call($element); + return $self->violation(sprintf(DESCRIPTION, $element), { score => SCORE, explanation => EXPLANATION }, $element); +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitDeprecatedCmp - Use C instead of +the deprecated C methods. + +=head1 DESCRIPTION + +Convert answers into a C and use the C method of the object +instead of using any of the deprecated C methods such as C from +the L macro, C from the +L macro, or C from the +L macro. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedMacros.pm b/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedMacros.pm new file mode 100644 index 000000000..27bbd2651 --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedMacros.pm @@ -0,0 +1,45 @@ +package Perl::Critic::Policy::PG::ProhibitDeprecatedMacros; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use WeBWorK::PG::Critic::Utils qw(getDeprecatedMacros); + +use constant DESCRIPTION => 'The deprecated macro %s is loaded'; +use constant EXPLANATION => 'Remove this macro and replace methods used from this macro with modern alternatives.'; +use constant SCORE => 10; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::Word) } + +sub violates ($self, $element, $) { + return unless $element eq 'loadMacros' && is_function_call($element); + my $deprecatedMacros = getDeprecatedMacros; + return unless $deprecatedMacros; + return map { + $self->violation( + sprintf(DESCRIPTION, $_->[0]->string), + { score => SCORE, explanation => EXPLANATION }, + $_->[0] + ) + } + grep { $deprecatedMacros->{ $_->[0]->string } } parse_arg_list($element); +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitDeprecatedMacros - Replace deprecated macro +usage with modern alternatives. + +=head1 DESCRIPTION + +All problems that use a deprecated macro (those in the C directory) +should be rewritten to use modern alternatives. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedMultipleChoice.pm b/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedMultipleChoice.pm new file mode 100644 index 000000000..bc3834446 --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitDeprecatedMultipleChoice.pm @@ -0,0 +1,55 @@ +package Perl::Critic::Policy::PG::ProhibitDeprecatedMultipleChoice; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use WeBWorK::PG::Critic::Utils qw(getDeprecatedMacros); + +use constant DESCRIPTION => 'The deprecated %s function is called'; +use constant EXPLANATION => 'The deprecated %s function should be replaced with a modern alternative.'; +use constant SCORE => 20; +use constant SAMPLE_PROBLEMS => [ + [ 'Multiple Choice with Checkbox' => 'Misc/MultipleChoiceCheckbox' ], + [ 'Multiple Choice with Popup' => 'Misc/MultipleChoicePopup' ], + [ 'Multiple Choice with Radio Buttons' => 'Misc/MultipleChoiceRadio' ] +]; + +# Note that new_match_list is not in this list because there is not a modern alternative yet. +# The qa method is also not listed because it is needed with new_match_list. +use constant MULTIPLE_CHOICE_METHODS => { + new_checkbox_multiple_choice => 1, + new_multiple_choice => 1, + new_pop_up_select_list => 1, + new_select_list => 1 +}; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::Word) } + +sub violates ($self, $element, $) { + return unless MULTIPLE_CHOICE_METHODS->{$element} && is_function_call($element); + return $self->violation(sprintf(DESCRIPTION, $element), + { score => SCORE, explanation => sprintf(EXPLANATION, $element), sampleProblems => SAMPLE_PROBLEMS }, + $element); +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitDeprecatedMultipleChoice - Replace usage of +L multiple choice methods with the appropriate MathObject +multiple choice +macro. + +=head1 DESCRIPTION + +Replace usage of L multiple choice methods with the +appropriate modern multiple choice macro. For example, consider using +L, L, or L. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitEnddocumentMatter.pm b/lib/Perl/Critic/Policy/PG/ProhibitEnddocumentMatter.pm new file mode 100644 index 000000000..0267989b3 --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitEnddocumentMatter.pm @@ -0,0 +1,41 @@ +package Perl::Critic::Policy::PG::ProhibitEnddocumentMatter; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use constant DESCRIPTION => 'There is content after the ENDDOCUMENT call'; +use constant EXPLANATION => 'Remove this content. The ENDDOCUMENT call should be at the end of the problem.'; +use constant SCORE => 5; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::Word) } + +sub default_maximum_violations_per_document ($) { return 1; } + +sub violates ($self, $element, $document) { + return $self->violation(DESCRIPTION, { score => SCORE, explanation => EXPLANATION }, $element) + if $element eq 'ENDDOCUMENT' + && is_function_call($element) + && ($document->{_doc}{untranslatedCode} // '') =~ /ENDDOCUMENT[^\n]*\n(.*)/s + && $1 =~ /\S/; + return; +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitEnddocumentMatter - There should not be any +content after the C call in a problem. + +=head1 DESCRIPTION + +The C call is intended to signify the end of the problem code. +Although all content after the C call is ignored, there should not +be any content (text or code) in this area. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitGraphMacros.pm b/lib/Perl/Critic/Policy/PG/ProhibitGraphMacros.pm new file mode 100644 index 000000000..437951b0d --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitGraphMacros.pm @@ -0,0 +1,42 @@ +package Perl::Critic::Policy::PG::ProhibitGraphMacros; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use WeBWorK::PG::Critic::Utils qw(getDeprecatedMacros); + +use constant DESCRIPTION => 'The init_graph function from PGgraphmacros.pl is called'; +use constant EXPLANATION => 'PGgraphmacros.pl generates poor quality graphics. Consider using a modern alternative.'; +use constant SCORE => 20; +use constant SAMPLE_PROBLEMS => [ + [ 'TikZ Graph Images' => 'ProblemTechniques/TikZImages' ], + [ 'Inserting Images in PGML' => 'ProblemTechniques/Images' ], + [ 'Function Plot' => 'Algebra/FunctionPlot' ] +]; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::Word) } + +sub violates ($self, $element, $) { + return unless $element eq 'init_graph' && is_function_call($element); + return $self->violation(DESCRIPTION, + { score => SCORE, explanation => EXPLANATION, sampleProblems => SAMPLE_PROBLEMS }, $element); +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitGraphMacros - L generates +poor quality graphics. Modern alternatives should be used instead. + +=head1 DESCRIPTION + +L generates poor quality graphics. Replace its usage with a +modern alternative such as L, L, or L. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitMultipleLoadMacrosCalls.pm b/lib/Perl/Critic/Policy/PG/ProhibitMultipleLoadMacrosCalls.pm new file mode 100644 index 000000000..6dd18ca2e --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitMultipleLoadMacrosCalls.pm @@ -0,0 +1,38 @@ +package Perl::Critic::Policy::PG::ProhibitMultipleLoadMacrosCalls; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use constant DESCRIPTION => 'loadMacros is called multiple times'; +use constant EXPLANATION => 'Consolidate multiple loadMacros calls into a single call.'; +use constant SCORE => 20; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Document) } + +sub violates ($self, $element, $document) { + my $tokens = $document->find('PPI::Token'); + return unless $tokens; + my @loadMacrosCalls = grep { $_ eq 'loadMacros' && is_function_call($_) } @$tokens; + shift @loadMacrosCalls; + return map { $self->violation(DESCRIPTION, { score => SCORE, explanation => EXPLANATION }, $_) } @loadMacrosCalls; +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitMultipleLoadMacrosCalls - The C +function should only be called once in each problem. + +=head1 DESCRIPTION + +The C function should only be called once in each problem. +Consolidate multiple C calls into a single call and make sure that +all macros that are loaded are actually used in the problem. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitOldText.pm b/lib/Perl/Critic/Policy/PG/ProhibitOldText.pm new file mode 100644 index 000000000..b46ccbe8e --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitOldText.pm @@ -0,0 +1,53 @@ +package Perl::Critic::Policy::PG::ProhibitOldText; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use constant DESCRIPTION => 'A BEGIN_%1$s/END_%1$s block is used for problem text'; +use constant EXPLANATION => 'Load the macro PGML.pl and replace the BEGIN_%1$s/END_%1$s ' + . 'block with a BEGIN_PGML%2$s/END_PGML%2$s block.'; +use constant SCORE => 20; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::HereDoc) } + +sub violates ($self, $element, $document) { + if ($element->terminator =~ /^END_(TEXT|SOLUTION|HINT)?$/ + && $element->parent + && $element->parent->parent + && $element->parent->parent->parent + && $element->parent->parent->parent->first_element eq 'EV3P' + && is_function_call($element->parent->parent->parent->first_element) + && $element->parent->parent->parent->parent + && $element->parent->parent->parent->parent->parent + && $element->parent->parent->parent->parent->parent->first_element =~ /^(STATEMENT|HINT|SOLUTION)$/ + && is_function_call($element->parent->parent->parent->parent->parent->first_element)) + { + my $oldType = $1 eq 'STATEMENT' ? 'TEXT' : $1; + return $self->violation( + sprintf(DESCRIPTION, $oldType), + { score => SCORE, explanation => sprintf(EXPLANATION, $oldType, $1 eq 'STATEMENT' ? '' : "_$1") }, + $element->parent->parent->parent->parent->parent + ); + } + return; +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitOldText - Replace old PG text usage with PGML. + +=head1 DESCRIPTION + +Load the C macro and replace all C/C, +C/C, and C/C blocks with +C/C, C/C, and +C/C blocks. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/ProhibitUnnecessarilySettingShowPartialCorrectAnswers.pm b/lib/Perl/Critic/Policy/PG/ProhibitUnnecessarilySettingShowPartialCorrectAnswers.pm new file mode 100644 index 000000000..2faac1d9f --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/ProhibitUnnecessarilySettingShowPartialCorrectAnswers.pm @@ -0,0 +1,42 @@ +package Perl::Critic::Policy::PG::ProhibitUnnecessarilySettingShowPartialCorrectAnswers; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use WeBWorK::PG::Critic::Utils qw(getDeprecatedMacros); + +use constant DESCRIPTION => '$showPartialCorrectAnswers is set to 1'; +use constant EXPLANATION => 'The value of $showPartialCorrectAnswers is 1 by default, ' + . 'so it should only ever be set to 0 to change the value.'; +use constant SCORE => 5; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::Operator) } + +sub violates ($self, $element, $) { + return unless is_assignment_operator($element); + my $left = $element->sprevious_sibling; + my $right = $element->snext_sibling; + return $self->violation(DESCRIPTION, { score => SCORE, explanation => EXPLANATION }, $left) + if $left && $left eq '$showPartialCorrectAnswers' && $element eq '=' && $right && $right eq '1'; + return; +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::ProhibitUnnecessarilySettingShowPartialCorrectAnswers +- There is no need to set C<$showPartialCorrectAnswers> to 1 since that is the +default value. + +=head1 DESCRIPTION + +The value of C<$showPartialCorrectAnswers> is 1 by default, so it should only +ever be set to 0 to change the value. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/RequireImageAltAttribute.pm b/lib/Perl/Critic/Policy/PG/RequireImageAltAttribute.pm new file mode 100644 index 000000000..7fbc02657 --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/RequireImageAltAttribute.pm @@ -0,0 +1,96 @@ +package Perl::Critic::Policy::PG::RequireImageAltAttribute; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use WeBWorK::PG::Critic::Utils qw(parsePGMLBlock parseTextBlock); + +use constant DESCRIPTION => 'An image is missing the alt attribute'; +use constant EXPLANATION => 'Add an alt attribute that describes the image content.'; +use constant SCORE => 10; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Token::HereDoc PPI::Token::Word) } + +sub hasAltTag ($self, $element) { + my @args = + map { $_->[0]->isa('PPI::Token::Quote') ? $_->[0]->string : $_->[0]->content } parse_arg_list($element); + shift @args; # Remove the image argument. + my %args = @args % 2 ? () : @args; + return $args{alt} || ($args{extra_html_tags} && $args{extra_html_tags} =~ /alt/); +} +use Mojo::Util qw(dumper); + +sub violates ($self, $element, $) { + my @violations; + if ($element->isa('PPI::Token::Word') && $element eq 'image' && is_function_call($element)) { + push(@violations, $self->violation(DESCRIPTION, { score => SCORE, explanation => EXPLANATION }, $element)) + unless $self->hasAltTag($element); + } elsif ( + $element->isa('PPI::Token::HereDoc') + && $element->terminator =~ /^END_(PGML|PGML_SOLUTION|PGML_HINT|TEXT|HINT|SOLUTION)?$/ + && $element->parent + && $element->parent->parent + && $element->parent->parent->parent + && ($element->parent->parent->parent->first_element eq 'PGML::Format2' + || $element->parent->parent->parent->first_element eq 'EV3P') + && is_function_call($element->parent->parent->parent->first_element) + && $element->parent->parent->parent->parent + && $element->parent->parent->parent->parent->parent + && $element->parent->parent->parent->parent->parent->first_element =~ /^(STATEMENT|HINT|SOLUTION)$/ + && is_function_call($element->parent->parent->parent->parent->parent->first_element) + ) + { + for my $command ( + @{ + ( + $element->terminator =~ /PGML/ + ? parsePGMLBlock($element->heredoc)->{commands} + : parseTextBlock($element->heredoc)->{commands} + ) // [] + } + ) + { + for (grep { $_ eq 'image' && is_function_call($_) } @{ $command->find('PPI::Token::Word') || [] }) { + next if $self->hasAltTag($_); + push( + @violations, + $self->violation( + DESCRIPTION + . ' inside the ' + . ($element->terminator =~ s/END/BEGIN/r) . '/' + . ($element->terminator) + . ' block', + { score => SCORE, explanation => EXPLANATION }, + $element->parent->parent->parent->parent->parent + ) + ); + } + } + } + + return @violations; +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::RequireImageAltAttribute - Images created with the +C method should have the C attribute set. + +=head1 DESCRIPTION + +The C attribute is crucial for accessibility, especially for visually +impaired users who rely on screen readers to understand the content of the +problem. So all images added to a problem should have the C attribute set. +Note that it can be set to the empty string to indicate that the image is not +essential to the meaning of the problem content. Generally it is better to use +the PGML syntax for images C<[!alternate text!]{$image}> rather than using the +C method. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/RequireMetadata.pm b/lib/Perl/Critic/Policy/PG/RequireMetadata.pm new file mode 100644 index 000000000..ab081f9df --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/RequireMetadata.pm @@ -0,0 +1,51 @@ +package Perl::Critic::Policy::PG::RequireMetadata; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use constant DESCRIPTION => 'The %s metadata tag is required'; +use constant EXPLANATION => 'Include the required metadata tags at the beginning of the problem file.'; +use constant SCORE => 5; +use constant REQUIRED_METADATA => [ 'DBsubject', 'DBchapter', 'DBsection', 'KEYWORDS' ]; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Document) } + +sub violates ($self, $element, $document) { + my $comments = $document->find('PPI::Token::Comment'); + my %foundMetadata; + if ($comments) { + for my $comment (@$comments) { + my ($metadataType) = grep { $comment =~ /#\s*$_\(/i } @{ REQUIRED_METADATA() }; + $foundMetadata{$metadataType} = 1 if $metadataType; + } + } + + my @violations; + for (@{ REQUIRED_METADATA() }) { + push(@violations, + $self->violation(sprintf(DESCRIPTION, $_), { score => SCORE, explanation => EXPLANATION }, $document)) + unless $foundMetadata{$_}; + } + return @violations; +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::RequireMetadata - All problems should have the +appropriate OPL metadata tags set. + +=head1 DESCRIPTION + +All problems should have the appropriate OPL metadata tags set. The required +metadata attributes should be set at the beginning of the problem file before +the C call. The metadata tags that are required for all problems are +C, C, C, and C. + +=cut diff --git a/lib/Perl/Critic/Policy/PG/RequireSolution.pm b/lib/Perl/Critic/Policy/PG/RequireSolution.pm new file mode 100644 index 000000000..eb14e1a64 --- /dev/null +++ b/lib/Perl/Critic/Policy/PG/RequireSolution.pm @@ -0,0 +1,61 @@ +package Perl::Critic::Policy::PG::RequireSolution; +use Mojo::Base 'Perl::Critic::Policy', -signatures; + +use Perl::Critic::Utils qw(:severities :classification :ppi); + +use constant DESCRIPTION => 'A solution is not included in this problem'; +use constant EXPLANATION => 'A solution should be included in all problems.'; +use constant SCORE => 25; + +sub supported_parameters ($) {return} +sub default_severity ($) { return $SEVERITY_HIGHEST } +sub default_themes ($) { return qw(pg) } +sub applies_to ($) { return qw(PPI::Document) } + +sub default_maximum_violations_per_document ($) { return 1; } + +sub violates ($self, $element, $document) { + my $solutionFound = 0; + if (my $heredocs = $document->find('PPI::Token::HereDoc')) { + for (@$heredocs) { + if ( + $_->terminator =~ /^END_(PGML_)?SOLUTION$/ + && $_->parent + && $_->parent->parent + && $_->parent->parent->parent + && ($_->parent->parent->parent->first_element eq 'PGML::Format2' + || $_->parent->parent->parent->first_element eq 'EV3P') + && is_function_call($_->parent->parent->parent->first_element) + && $_->parent->parent->parent->parent + && $_->parent->parent->parent->parent->parent + && $_->parent->parent->parent->parent->parent->first_element eq 'SOLUTION' + && is_function_call($_->parent->parent->parent->first_element) + ) + { + $solutionFound = 1; + last; + } + } + } + return $self->violation(DESCRIPTION, { score => SCORE, explanation => EXPLANATION }, $document) + unless $solutionFound; + return; +} + +1; + +__END__ + +=head1 NAME + +Perl::Critic::Policy::PG::RequireSolution - All problems should provide a +solution. + +=head1 DESCRIPTION + +A solution should be included in all problems. Note that a solution should +demonstrate all steps to solve a problem, and should certainly not just give the +answers to questions in the problem. This is one of the most challenging parts +of PG problem authoring, but the solution should not be omitted. + +=cut diff --git a/lib/WeBWorK/PG/Critic.pm b/lib/WeBWorK/PG/Critic.pm new file mode 100644 index 000000000..0a656d494 --- /dev/null +++ b/lib/WeBWorK/PG/Critic.pm @@ -0,0 +1,94 @@ + +=head1 NAME + +WeBWorK::PG::Critic - Critique PG problem source code for best-practices. + +=head1 DESCRIPTION + +Analyze a pg file for use of old and current methods. + +=head1 FUNCTIONS + +=head2 critiquePGCode + + my @violations = critiquePGCode($code, $force = 0); + +Parses and critiques the given PG problem source provided in C<$code>. An array +of violations that are found is returned. Note that the elements of this return +array are L objects. The C method can be +called for each element, and that will either return a string or a reference to +a hash. The string return type will occur for a violation of a default +L policy. The last return type will occur with a +C policy, and the hash will contain a C key and +an C key containing the actual explanation. Note that the greater +the score, the worse the violation is. In some cases the C return +hash will also contain the key C which will be a reference to an +array each of whose entries will be a reference to a two element array whose +first element is the title of a sample problem and whose second element is the +path for that sample problem where the sample problem demonstrates a way to fix +the policy violation. + +Note that C<## no critic> annotations can be used in the code to disable a +violation for a line or the entire file. See L<"BENDING THE +RULES"|https://metacpan.org/pod/Perl::Critic#BENDING-THE-RULES>. However, if +C<$force> is true, then C<## no critic> annotations are ignored, and all +policies are enforced regardless. + +=head2 critiquePGFile + + my @violations = critiquePGFile($file, $force); + +This just executes C on the contents of C<$file> and returns +the violations found. +=cut + +package WeBWorK::PG::Critic; +use Mojo::Base 'Exporter', -signatures; + +use Mojo::File qw(path); +use PPI; +use Perl::Critic; + +require WeBWorK::PG::Translator; + +our @EXPORT_OK = qw(critiquePGFile critiquePGCode); + +sub critiquePGCode ($code, $force = 0) { + my $critic = Perl::Critic->new( + -severity => 4, + -exclude => [ + 'Perl::Critic::Policy::Modules::ProhibitMultiplePackages', + 'Perl::Critic::Policy::Modules::RequireEndWithOne', + 'Perl::Critic::Policy::Modules::RequireExplicitPackage', + 'Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage', + 'Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms', + 'Perl::Critic::Policy::Subroutines::RequireArgUnpacking', + 'Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict', + 'Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings', + 'Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars', + + # Make sure that Community and Freenode policies are not used if installed on the system. + '.*::Community::.*', '.*::Freenode::.*' + ], + -force => $force + ); + + my $translatedCode = WeBWorK::PG::Translator::default_preprocess_code($code); + + my $document = PPI::Document->new(\$translatedCode); + + # Provide the untranslated code so that policies can access it. It will be in the _doc key of the $document that is + # passed as the third argument to the violates method. See Perl::Critic::Policy::PG::ProhibitEnddocumentMatter which + # uses this for example. + $document->{untranslatedCode} = $code; + + return $critic->critique($document); +} + +sub critiquePGFile ($file, $force = 0) { + my $code = eval { path($file)->slurp('UTF-8') }; + die qq{Unable to read contents of "$file": $@} if $@; + return critiquePGCode($code, $force); +} + +1; diff --git a/lib/WeBWorK/PG/Critic/Utils.pm b/lib/WeBWorK/PG/Critic/Utils.pm new file mode 100644 index 000000000..425233aea --- /dev/null +++ b/lib/WeBWorK/PG/Critic/Utils.pm @@ -0,0 +1,153 @@ + +=head1 NAME + +WeBWorK::PG::Critic::Utils - Utility methods for PG Critic policies. + +=head1 DESCRIPTION + +Utility methods for PG Critic policies. + +=head1 FUNCTIONS + +=head2 getDeprecatedMacros + + my @deprecatedMacros = getDeprecatedMacros(); + +Returns a list of deprecated macros. These are the macros found in the +C directory. + +=head2 parsePGMLBlock + + my $pgmlElements = parsePGMLBlock(@lines); + +Parses the given C<@lines> of code from a PGML block and returns a reference to +a hash containing details of the PGML blocks found. + +If any C<[@ ... @]> blocks are found in the PGML code, then the return hash will +contain the key C which will be a reference to an array of +L objects representing the Perl code within the C<[@ ... @]> +blocks found. + +If the PGML content or a block within fails to parse, then the return hash will +contain the key C with a reference to an array of errors that occurred. + +Also if there are any warnings that occur in the parsing, those will be in the +C key of the return hash. + +=head2 parseTextBlock + + my $textElements = parseTextBlock(@lines); + +Parses the given C<@lines> of code from a C/C, +C/C, or C/C block and +returns a reference to a hash containing details of the elements found. + +If any C<\{ ... \}> blocks are found in the code, then the return hash will +contain the key C which will be a reference to an array of +L objects representing the Perl code within the C<\{ ... \}> +blocks found. + +If a block within fails to parse, then the return hash will contain the key +C which is a reference to an array of errors that occurred. + +=cut + +package WeBWorK::PG::Critic::Utils; +use Mojo::Base 'Exporter', -signatures; + +use Mojo::File qw(curfile path); +use PPI; +use Perl::Critic::Utils qw(:classification :ppi); +use Scalar::Util qw(blessed); +use Mojo::Util qw(md5_sum encode); +use Env qw(PG_ROOT); + +use lib curfile->dirname->dirname->dirname->dirname->dirname->child('lib'); + +require Value; + +our @EXPORT_OK = qw(getDeprecatedMacros parsePGMLBlock parseTextBlock); + +$PG_ROOT = curfile->dirname->dirname->dirname->dirname->dirname; + +sub getDeprecatedMacros () { + state $deprecatedMacros; + return $deprecatedMacros if $deprecatedMacros; + return $deprecatedMacros = + { map { $_->basename => 1 } @{ path($PG_ROOT)->child('macros', 'deprecated')->list } }; +} + +# Mock methods used by PGML. +sub main::PG_restricted_eval ($code) { return $code; } +sub main::loadMacros(@macros) { return; } +sub main::Context() { return; } + +do "$PG_ROOT/macros/core/PGML.pl"; + +sub walkPGMLTree ($block, $results //= {}) { + for my $item (@{ $block->{stack} }) { + next unless blessed $item && $item->isa('PGML::Block'); + if ($item->{type} eq 'command') { + my $command = PPI::Document->new(\($item->{text})); + if ($command->errstr) { + push(@{ $results->{errors} }, $command->errstr); + } else { + push(@{ $results->{commands} }, $command); + } + } + walkPGMLTree($item, $results); + } + return $results; +} + +# For now, only command blocks are returned. Add other PGML elements as needed. +sub parsePGMLBlock (@lines) { + state %processedBlocks; + + my $source = join('', @lines); + + # Cache the results of parsing particular PGML blocks so that if multiple policies + # use the same PGML block the parsing does not need to be done again. + my $sourceHash = md5_sum(encode('UTF-8', $source)); + return $processedBlocks{$sourceHash} if defined $processedBlocks{$sourceHash}; + + PGML::ClearWarnings(); + my $parser = eval { PGML::Parse->new($source =~ s/\\\\/\\/gr) }; + return { errors => [$@], warnings => \@PGML::warnings } if $@; + + return $processedBlocks{$sourceHash} = + WeBWorK::PG::Critic::Utils::walkPGMLTree($parser->{root}, { warnings => \@PGML::warnings }); +} + +# For now, only contents of \{ .. \} blocks are returned. Add other text elements as needed. +sub parseTextBlock (@lines) { + state %processedBlocks; + + my $source = join('', @lines); + + # Cache the results of parsing particular text blocks so that if multiple policies + # use the same text block the parsing does not need to be done again. + my $sourceHash = md5_sum(encode('UTF-8', $source)); + return $processedBlocks{$sourceHash} if defined $processedBlocks{$sourceHash}; + + my $results = {}; + + while ($source ne '') { + if ($source =~ /\Q\\{\E/s) { + $source =~ s/^(.*?)\Q\\{\E//s; + $source =~ s/^(.*?)\Q\\}\E//s; + my $command = PPI::Document->new(\($1)); + if ($command->errstr) { + push(@{ $results->{errors} }, $command->errstr); + } else { + push(@{ $results->{commands} }, $command); + } + } else { + last; + } + + } + + return $processedBlocks{$sourceHash} = $results; +} +1;