use strict; use warnings; use PPI; use PPI::Dumper; use Perl::Critic; use Test::Deep::NoTest; use Data::Dump; my $debug = 0; # 0..2 my $perl_critic_severity = 'gentle'; # 'gentle' 'stern' 'harsh' 'cruel' 'brutal' # assignemnt print <<'EOP'; Assignement: -Create an array named @letters with 5 elements and fill it with first 5 letters of the English alphabet -Remove the first element using a list operator and assign it to a scalar variable -Remove the last element using a list operator and assign it to a scalar variable -Join these two removed elements with a '-' (using single quotes) sign and assign the result to a scalar named $result NB: All variables have to be lexically scoped NB: each above steps must be accomplished in one statement EOP # solution code my $solution_code = <<'EOC'; use strict; use warnings; my @letters = ('a'..'e'); my $first = shift @letters; my $last = pop @letters; my $result = join '-', $first, $last; EOC # student attempts my $work_01 = < anonymous hash (tests will be executed in a sorted order) # name => # run => send the code to a sub returning 0|1 plus messages # select_child_of => given a PPI class search each element of such class # to see if they contain all required elements. # returns 0|1 plus messages # class => the class of elements to analyze (all elements of such class will be tested) # tests => anonymous array: check children of the current element to be of the appropriate class # and to hold the desired content (string or regex can be used) # evaluate_to => optional but only possible if select_child_of was used: the DPOM fragment # extracted by select_child_of will be check to hold a precise value (at runtime: see below) # hint => # docs => 001 => { name => 'code compiles', run => \&test_compile, # select_child_of ... # evaluate_to ... hint => "comment the line causing crash with a # in front of it", docs => ['perldoc perlintro', 'https://perldoc.perl.org/perlintro.html#Basic-syntax-overview'], }, 002 => { name => 'strictures', # run => ... select_child_of => { class => 'PPI::Statement::Include', tests => [ #['PPI::Token::Word', 'use'], ['PPI::Token::Word', qr/^use$/], ['PPI::Token::Word', 'strict'] ], }, # evaluate_to ... hint => "search perlintro for safety net", docs => ['https://perldoc.perl.org/perlintro.html#Safety-net'], }, 003 => { name => 'warnings', # run => ... select_child_of => { class => 'PPI::Statement::Include', tests => [ ['PPI::Token::Word', 'use'], #['PPI::Token::Word', qr/^use$/], ['PPI::Token::Word', 'warnings'] ], }, # evaluate_to ... hint => "search perlintro for safety net", docs => ['https://perldoc.perl.org/perlintro.html#Safety-net'], }, 004 => { name => 'array creation', select_child_of => { class => 'PPI::Statement::Variable', tests => [ ['PPI::Token::Word', 'my'], ['PPI::Token::Symbol', '@letters'], ['PPI::Token::Operator', '='], ], }, evaluate_to => [ ('a'..'e') ], hint => "search perlintro basic variable types", docs => ['https://perldoc.perl.org/perlintro.html#Perl-variable-types'], }, 005 => { name => 'first element of the array', select_child_of => { class => 'PPI::Statement::Variable', tests => [ ['PPI::Token::Word', 'my'], ['PPI::Token::Symbol', qr/\$[\S]/], ['PPI::Token::Operator', '='], ['PPI::Token::Word', 'shift'], ['PPI::Token::Symbol', '@letters'], ], }, evaluate_to => \'a', hint => "search functions related to real arrays", docs => ['https://perldoc.perl.org/5.32.0/perlfunc.html#Perl-Functions-by-Category'], }, 006 => { name => 'last element of the array', select_child_of => { class => 'PPI::Statement::Variable', tests => [ ['PPI::Token::Word', 'my'], ['PPI::Token::Symbol', qr/\$[\S]/], ['PPI::Token::Operator', '='], ['PPI::Token::Word', 'pop'], ['PPI::Token::Symbol', '@letters'], ], }, evaluate_to => \'e', hint => "search functions related to real arrays", docs => ['https://perldoc.perl.org/5.32.0/perlfunc.html#Perl-Functions-by-Category'], }, 007 => { name => 'final result', select_child_of => { class => 'PPI::Statement::Variable', tests => [ ['PPI::Token::Word', 'my'], ['PPI::Token::Symbol', '$result'], ['PPI::Token::Operator', '='], ['PPI::Token::Word', 'join'], ['PPI::Token::Quote::Single', "'-'"], ['PPI::Token::Operator', ','], ['PPI::Token::Symbol', qr/^\$[\S]/], ['PPI::Token::Operator', ','], ['PPI::Token::Symbol', qr/^\$[\S]/], ], }, evaluate_to => \'a-e', hint => "search functions related to strings", docs => ['https://perldoc.perl.org/5.32.0/perlfunc.html#Perl-Functions-by-Category'], }, ); # student's attempts examination foreach my $code ( $work_01, $work_02, $work_03, $work_04, $work_05, $solution_code){ $code = PPI::Document->new( \$code ); print "\n# START of provided code:\n",$code=~s/^/| /gmr,"# END of provided code\n# TESTS:\n"; PPI::Dumper->new($code)->print if $debug > 1; my $passed_tests; foreach my $test (sort keys %tests){ print "DEBUG: starting test $test - $tests{ $test }{ name }\n" if $debug; # if run defined my $run_result; my $run_msg; if ( exists $tests{ $test }{ run } ){ ($run_result, $run_msg) = $tests{ $test }{ run }->( $code ); if ( $run_result ){ print "OK test [$tests{ $test }{ name }]\n"; $passed_tests++; # next test next; } else{ $run_msg =~ s/\n//; print "FAILED test [$tests{ $test }{ name }] because: $run_msg\n"; if ( $tests{ $test }{ hint } ){ print "HINT: $tests{ $test }{ hint }\n"; } if ( $tests{ $test }{ docs } ){ print map {"DOCS: $_\n"} @{$tests{ $test }{ docs }} ; } last; } } # select_child_of defined my $candidate_pdom; my $select_child_of_msg; if ( exists $tests{ $test }{ select_child_of } ){ ($candidate_pdom, $select_child_of_msg) = select_child_of( pdom => $code, wanted_class => $tests{ $test }{ select_child_of }{ class }, tests => $tests{ $test }{ select_child_of }{ tests } ); } # also evaluation is required if( $candidate_pdom and exists $tests{ $test }{ evaluate_to }){ my ($evauleted_pdom, $eval_msg) = evaluate_to ( $candidate_pdom, $tests{ $test }{ evaluate_to } ); if($evauleted_pdom){ print "OK test [$tests{ $test }{ name }]\n"; $passed_tests++; # jump to next test next; } else{ print "FAILED test [$tests{ $test }{ name }] because: $eval_msg\n"; if ( $tests{ $test }{ hint } ){ print "HINT: $tests{ $test }{ hint }\n"; } if ( $tests{ $test }{ docs } ){ print map {"DOCS: $_\n"} @{$tests{ $test }{ docs }} ; } } } elsif( $candidate_pdom ){ print "OK test [$tests{ $test }{ name }]\n"; $passed_tests++ ; # jump to next test next; } else{ print "FAILED test [$tests{ $test }{ name }] because: $select_child_of_msg\n"; if ( $tests{ $test }{ hint } ){ print "HINT: $tests{ $test }{ hint }\n"; } if ( $tests{ $test }{ docs } ){ print map {"DOCS: $_\n"} @{$tests{ $test }{ docs }} ; } # if one test breaks end the testing loop last; } } # all tests passed if ( $passed_tests == scalar keys %tests ){ print "\nALL tests passed\n"; my $critic = Perl::Critic->new( -severity => $perl_critic_severity ); my @violations = $critic->critique($code); if ( @violations ){ print "Perl::Critic violations (with severity: $perl_critic_severity):\n"; print @violations; } else{ print "No Perl::Critic violations using severity level: $perl_critic_severity\n"; } } print "\n\n"; } ################################ # TESTS ################################ sub evaluate_to{ my $pdom = shift; # passed by reference my $expected_value = shift; ############################### # VERY DIRTY TRICK - START ############################### # only last element is returned in string evaluation # so the below code cuts the parent where the current # pdom is found. so the current statement will be the # last one of the whole code (parent) and its value # returned by the string evaluation # (probably I'll need to redirect STDOUT in this scope) # # NB this will fail for multiline statements! my $pdom_parent = $pdom->parent; my @lines_od_code = split/\n/,$pdom_parent->content; if ( $debug > 1 ){ print "ORIGINAL CODE:\n"; dd @lines_od_code; print "FOUND current PDOM element at line: ", $pdom->line_number, "\n"; print "CUTTING code at line: ", $pdom->line_number, "\n"; dd @lines_od_code[0..$pdom->line_number-1] } $pdom = PPI::Document->new( \join"\n",@lines_od_code[0..$pdom->line_number-1] ); ############################### # VERY DIRTY TRICK - END ############################### { local $@; my $got; # we expect a scalar ref if ( ref $expected_value eq 'SCALAR' ){ $got = \eval $pdom ; } # we expect an array ref elsif ( ref $expected_value eq 'ARRAY' ){ $got = [ eval $pdom ]; } # we expect a hash ref elsif ( ref $expected_value eq 'HASH' ){ $got = { eval $pdom }; } # we expect a regexp ref elsif ( ref $expected_value eq 'Regexp' ){ $got = eval $pdom; $got = qr/$got/; } # Not a reference else{ $got = eval $pdom; } # check to be the same type if ( ref $expected_value ne ref $got ){ return (0, "got and expected values are not of the same type") } else{ print "DEBUG: OK both got and expected are of the same type: ", ref $got,"\n" if $debug; } if ( eq_deeply( $got, $expected_value ) ){ if ( $debug > 1 ){ print "DEBUG: OK both got and expected hold same content: "; dd $got; } return ($pdom, "expected value found for the expression [$pdom]"); } else{ if ( $debug ){ print "GOT: ",ref $got,"\n"; dd $got; print "EXPECTED: ",ref $expected_value,"\n"; dd $expected_value; #print "PARENT: "; PPI::Dumper->new( $pdom->parent )->print; } return (0, "wrong value of the expression [$pdom]") } } } sub select_child_of{ my %opt = @_; my $pdom_fragments = $opt{ pdom }->find( $opt{ wanted_class } ); return (0, "no element found of the correct type") unless $pdom_fragments; foreach my $pdom_candidate ( @$pdom_fragments ){ print "DEBUG: checking fragment: [$pdom_candidate]\n" if $debug; my $expected_ok; foreach my $test ( @{$opt{ tests }} ){ my ($class, $content) = @$test; print "DEBUG: testing for class [$class] and content [$content]\n" if $debug; if ( $pdom_candidate->find( sub { $_[1]->isa($class) and ( ref $content eq 'Regexp' ? ( $_[1]->content =~ /$content/ ) : ( $_[1]->content eq $content ) ) } ) ){ $expected_ok++; #print "DEBUG FOUND: [",ref $_[1],"] [",$_[1]->content,"]\n"; print "DEBUG: OK..\n" if $debug; if ( $expected_ok == scalar @{$opt{ tests }} ){ print "DEBUG: found a good candidate: [$pdom_candidate]\n" if $debug; return ( $pdom_candidate, "found expected code in: [$pdom_candidate]" ) } } else{ print "DEBUG: FAIL skipping to next fragment of code\n" if $debug; last; } } } #FAILED return (0,"element not found") } sub test_compile{ my $code = shift; { local $@; eval $code; if ( $@ ){ # print "\$@ = $@"; return (0, $@, "Comment the line with a # in front of it", "perlintro" ); } else { # $code instead of 1?????? return (1, "code compiles correctly"); } } }