From e87db89a1b545ced3beb0bcd80dda173ec7c1084 Mon Sep 17 00:00:00 2001 From: Marius Gavrilescu Date: Fri, 26 Dec 2014 10:22:23 +0200 Subject: [PATCH] Add perlcritic test and make code compliant --- lib/HTML/Element/Library.pm | 110 ++++++++++++++++++------------------ t/perlcritic.t | 11 ++++ t/perlcriticrc | 32 +++++++++++ 3 files changed, 98 insertions(+), 55 deletions(-) create mode 100644 t/perlcritic.t create mode 100644 t/perlcriticrc diff --git a/lib/HTML/Element/Library.pm b/lib/HTML/Element/Library.pm index 8ad8341..5336eef 100644 --- a/lib/HTML/Element/Library.pm +++ b/lib/HTML/Element/Library.pm @@ -26,7 +26,7 @@ sub HTML::Element::fillinform { my $new_html = HTML::FillInForm->fill(\$html, $hashref); if ($return_tree) { - my $tree = HTML::TreeBuilder->new_from_content($new_html); + $tree = HTML::TreeBuilder->new_from_content($new_html); $tree = $guts ? $tree->guts : $tree ; } else { $new_html; @@ -86,7 +86,7 @@ sub HTML::Element::newchild { } $lol; } -sub HTML::Element::crunch { +sub HTML::Element::crunch { ## no critic (RequireArgUnpacking) my $container = shift; my %p = validate(@_, { @@ -97,14 +97,14 @@ sub HTML::Element::crunch { my @look_down = @{$p{look_down}} ; my @elem = $container->look_down(@look_down) ; - my $left; + my $detached; for my $elem (@elem) { - $elem->detach if $left++ >= $p{leave}; + $elem->detach if $detached++ >= $p{leave}; } } -sub HTML::Element::hash_map { +sub HTML::Element::hash_map { ## no critic (RequireArgUnpacking) my $container = shift; my %p = validate(@_, { @@ -118,7 +118,7 @@ sub HTML::Element::hash_map { warn 'hash' . Dumper($p{hash}) if $p{debug} ; #warn 'at_under' . Dumper(\@_) if $p{debug} ; - my @same_as = $container->look_down( $p{to_attr} => qr/.+/ ) ; + my @same_as = $container->look_down( $p{to_attr} => qr/.+/s ) ; warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug} ; @@ -138,17 +138,18 @@ sub HTML::Element::hashmap { $excluding ||= [] ; - $container->hash_map(hash => $hashref, - to_attr => $attr_name, - excluding => $excluding, - debug => $debug); + $container->hash_map( + hash => $hashref, + to_attr => $attr_name, + excluding => $excluding, + debug => $debug); } sub HTML::Element::passover { my ($tree, @to_preserve) = @_; - warn "ARGS: my ($tree, @to_preserve)" if $DEBUG; + warn "ARGS: my ($tree, @to_preserve)" if $DEBUG; warn $tree->as_HTML(undef, ' ') if $DEBUG; my $exodus = $tree->look_down(id => $to_preserve[0]); @@ -206,7 +207,7 @@ sub HTML::Element::position { my @pos; while ($p) { my $a = $p->addr; - unshift(@pos, $a) if defined $a; + unshift @pos, $a if defined $a; $p = $p->parent; } @pos; @@ -245,7 +246,7 @@ sub HTML::Element::iter { $p->replace_with(@item); } -sub HTML::Element::iter2 { +sub HTML::Element::iter2 { ## no critic (RequireArgUnpacking) my $tree = shift; #warn "INPUT TO TABLE2: ", Dumper \@_; @@ -257,16 +258,16 @@ sub HTML::Element::iter2 { wrapper_proc => { default => undef }, item_ld => { default => sub { - my $tree = shift; + my $tr = shift; [ - $tree->look_down('_tag' => 'dt'), - $tree->look_down('_tag' => 'dd') + $tr->look_down('_tag' => 'dt'), + $tr->look_down('_tag' => 'dd') ]; }}, item_data => { default => sub { my ($wrapper_data) = @_; - shift(@{$wrapper_data}) ; + shift @{$wrapper_data}; }}, item_proc => { default => sub { @@ -284,13 +285,13 @@ sub HTML::Element::iter2 { } ); - warn "wrapper_data: " . Dumper $p{wrapper_data} if $p{debug} ; + warn 'wrapper_data: ' . Dumper $p{wrapper_data} if $p{debug} ; my $container = ref_or_ld($tree, $p{wrapper_ld}); - warn "container: " . $container if $p{debug} ; - warn "wrapper_(preproc): " . $container->as_HTML if $p{debug} ; + warn 'container: ' . $container if $p{debug} ; + warn 'wrapper_(preproc): ' . $container->as_HTML if $p{debug} ; $p{wrapper_proc}->($container) if defined $p{wrapper_proc} ; - warn "wrapper_(postproc): " . $container->as_HTML if $p{debug} ; + warn 'wrapper_(postproc): ' . $container->as_HTML if $p{debug} ; my $_item_elems = $p{item_ld}->($container); @@ -300,13 +301,13 @@ sub HTML::Element::iter2 { my $item_data = $p{item_data}->($p{wrapper_data}); last unless defined $item_data; - warn Dumper("item_data", $item_data); + warn Dumper('item_data', $item_data); my $item_elems = [ map { $_->clone } @{$_item_elems} ] ; if ($p{debug}) { for (@{$item_elems}) { - warn "ITEM_ELEMS ", $_->as_HTML; + warn 'ITEM_ELEMS ', $_->as_HTML; } } @@ -314,14 +315,14 @@ sub HTML::Element::iter2 { if ($p{debug}) { for (@{$new_item_elems}) { - warn "NEWITEM_ELEMS ", $_->as_HTML; + warn 'NEWITEM_ELEMS ', $_->as_HTML; } } push @item_elem, @{$new_item_elems} ; } - warn "pushing " . @item_elem . " elems " if $p{debug} ; + warn 'pushing ' . @item_elem . ' elems' if $p{debug} ; $p{splice}->($container, @item_elem); } @@ -350,7 +351,7 @@ sub HTML::Element::dual_iter { $parent->splice_content(0, 2, @item); } -sub HTML::Element::set_child_content { +sub HTML::Element::set_child_content { ## no critic (RequireArgUnpacking) my $tree = shift; my $content = pop; my @look_down = @_; @@ -368,10 +369,10 @@ sub HTML::Element::set_child_content { sub HTML::Element::highlander { my ($tree, $local_root_id, $aref, @arg) = @_; - ref $aref eq 'ARRAY' or confess "must supply array reference"; + ref $aref eq 'ARRAY' or confess 'must supply array reference'; my @aref = @$aref; - @aref % 2 == 0 or confess "supplied array ref must have an even number of entries"; + @aref % 2 == 0 or confess 'supplied array ref must have an even number of entries'; warn __PACKAGE__ if $DEBUG; @@ -391,7 +392,7 @@ sub HTML::Element::highlander { # warn $node; warn "survivor: $survivor" if $DEBUG; - warn "tree: " . $tree->as_HTML if $DEBUG; + warn 'tree: ' . $tree->as_HTML if $DEBUG; $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML; @@ -399,12 +400,12 @@ sub HTML::Element::highlander { $survivor_node = $survivor_node->clone; $survivor_node_parent->replace_content($survivor_node); - warn "new tree: " . $tree->as_HTML if $DEBUG; + warn 'new tree: ' . $tree->as_HTML if $DEBUG; $survivor_node; } -sub HTML::Element::highlander2 { +sub HTML::Element::highlander2 { ## no critic (RequireArgUnpacking) my $tree = shift; my %p = validate(@_, { @@ -417,7 +418,7 @@ sub HTML::Element::highlander2 { }); my @cond = @{$p{cond}}; - @cond % 2 == 0 or confess "supplied array ref must have an even number of entries"; + @cond % 2 == 0 or confess 'supplied array ref must have an even number of entries'; warn __PACKAGE__ if $p{debug}; @@ -443,8 +444,8 @@ sub HTML::Element::highlander2 { my @ld = (ref $survivor eq 'ARRAY') ? @$survivor : (id => $survivor); - warn "survivor: ", $survivor if $p{debug}; - warn "survivor_ld: ", Dumper \@ld if $p{debug}; + warn 'survivor: ', $survivor if $p{debug}; + warn 'survivor_ld: ', Dumper \@ld if $p{debug}; my $survivor_node = $tree->look_down(@ld); @@ -457,9 +458,9 @@ sub HTML::Element::highlander2 { # **************** NEW FUNCTIONALITY ******************* # apply transforms on survivor node - warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug}; + warn 'SURV::pre_trans ' . $survivor_node->as_HTML if $p{debug}; $then->($survivor_node, @cond_arg); - warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug}; + warn 'SURV::post_trans ' . $survivor_node->as_HTML if $p{debug}; # **************** NEW FUNCTIONALITY ******************* $survivor_node; @@ -480,11 +481,10 @@ sub HTML::Element::overwrite_attr { sub HTML::Element::mute_elem { my ($tree, $mute_attr, $closures, $post_hook) = @_; - warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;"; - my @mute_node = $tree->look_down($mute_attr => qr/.*/) ; + my @mute_node = $tree->look_down($mute_attr => qr/.*/s) ; for my $mute_node (@mute_node) { - my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr); + my ($local_attr,$mute_key) = split /\s+/s, $mute_node->attr($mute_attr); my $local_attr_value_current = $mute_node->attr($local_attr); my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current); $post_hook->( @@ -519,7 +519,7 @@ sub HTML::Element::table { $tr; } @table_gi_tr; - warn "found " . @iter_node . " iter nodes " if $DEBUG; + warn 'found ' . @iter_node . ' iter nodes ' if $DEBUG; my $iter_node = List::Rotation::Cycle->new(@iter_node); # warn $iter_node; @@ -563,7 +563,7 @@ sub ref_or_ld { } } -sub HTML::Element::table2 { +sub HTML::Element::table2 { ## no critic (RequireArgUnpacking) my $tree = shift; my %p = validate( @@ -575,7 +575,7 @@ sub HTML::Element::table2 { tr_data => { default => sub { my ($self, $data) = @_; - shift(@{$data}) ; + shift @{$data}; }}, tr_base_id => { default => undef }, tr_proc => { default => sub {} }, @@ -584,21 +584,21 @@ sub HTML::Element::table2 { } ); - warn "INPUT TO TABLE2: ", Dumper \@_ if $p{debug}; - warn "table_data: " . Dumper $p{table_data} if $p{debug} ; + warn 'INPUT TO TABLE2: ', Dumper \@_ if $p{debug}; + warn 'table_data: ' . Dumper $p{table_data} if $p{debug} ; my $table = {}; # Get the table element $table->{table_node} = ref_or_ld( $tree, $p{table_ld} ) ; - $table->{table_node} or confess "table tag not found via " . Dumper($p{table_ld}) ; + $table->{table_node} or confess 'table tag not found via ' . Dumper($p{table_ld}) ; - warn "table: " . $table->{table_node}->as_HTML if $p{debug}; + warn 'table: ' . $table->{table_node}->as_HTML if $p{debug}; # Get the prototype tr element(s) my @proto_tr = ref_or_ld( $table->{table_node}, $p{tr_ld} ) ; - warn "found " . @proto_tr . " iter nodes " if $p{debug}; + warn 'found ' . @proto_tr . ' iter nodes' if $p{debug}; return unless @proto_tr; @@ -608,7 +608,7 @@ sub HTML::Element::table2 { my $proto_tr = List::Rotation::Cycle->new(@proto_tr); my $tr_parent = $proto_tr[0]->parent; - warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug}; + warn 'parent element of trs: ' . $tr_parent->as_HTML if $p{debug}; my $row_count; @@ -616,16 +616,16 @@ sub HTML::Element::table2 { while(1) { my $row = $p{tr_data}->($table, $p{table_data}, $row_count); - warn "data row: " . Dumper $row if $p{debug}; + warn 'data row: ' . Dumper $row if $p{debug}; last unless defined $row; # wont work: my $new_iter_node = $table->{iter_node}->clone; my $new_tr_node = $proto_tr->next->clone; - warn "new_tr_node: $new_tr_node" if $p{debug}; + warn "new_tr_node: $new_tr_node" if $p{debug}; $p{tr_proc}->($tree, $new_tr_node, $row, $p{tr_base_id}, ++$row_count) if defined $p{tr_proc}; - warn "data row redux: " . Dumper $row if $p{debug}; + warn 'data row redux: ' . Dumper $row if $p{debug}; $p{td_proc}->($new_tr_node, $row); push @table_rows, $new_tr_node; @@ -640,10 +640,10 @@ sub HTML::Element::unroll_select { my ($s, %select) = @_; my $select = {}; - warn "Select Hash: " . Dumper(\%select) if $select{debug}; + warn 'Select Hash: ' . Dumper(\%select) if $select{debug}; my $select_node = $s->look_down(id => $select{select_label}); - warn "Select Node: " . $select_node if $select{debug}; + warn "Select Node: $select_node" if $select{debug}; unless ($select{append}) { for my $option ($select_node->look_down('_tag' => 'option')) { @@ -652,12 +652,12 @@ sub HTML::Element::unroll_select { } my $option = HTML::Element->new('option'); - warn "Option Node: " . $option if $select{debug}; + warn "Option Node: $option" if $select{debug}; $option->detach; while (my $row = $select{data_iter}->($select{data})) { - warn "Data Row:" . Dumper($row) if $select{debug}; + warn 'Data Row: ' . Dumper($row) if $select{debug}; my $o = $option->clone; $o->attr('value', $select{option_value}->($row)); $o->attr('SELECTED', 1) if (exists $select{option_selected} and $select{option_selected}->($row)); diff --git a/t/perlcritic.t b/t/perlcritic.t new file mode 100644 index 0000000..3045b51 --- /dev/null +++ b/t/perlcritic.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl +use v5.14; +use warnings; + +use Test::More; + +BEGIN { plan skip_all => '$ENV{RELEASE_TESTING} is false' unless $ENV{RELEASE_TESTING} } + +use Test::Perl::Critic -profile => 't/perlcriticrc'; + +all_critic_ok diff --git a/t/perlcriticrc b/t/perlcriticrc new file mode 100644 index 0000000..b2e222c --- /dev/null +++ b/t/perlcriticrc @@ -0,0 +1,32 @@ +severity = 1 + +[-BuiltinFunctions::ProhibitComplexMappings] +[-CodeLayout::RequireTidyCode] +[-ControlStructures::ProhibitPostfixControls] +[-ControlStructures::ProhibitUnlessBlocks] +[-Documentation::PodSpelling] +[-Documentation::RequirePodLinksIncludeText] +[-ErrorHandling::RequireCarping] +[-InputOutput::RequireBracedFileHandleWithPrint] +[-References::ProhibitDoubleSigils] +[-RegularExpressions::ProhibitEnumeratedClasses] +[-RegularExpressions::RequireLineBoundaryMatching] +[-Subroutines::RequireFinalReturn] +[-ValuesAndExpressions::ProhibitConstantPragma] +[-ValuesAndExpressions::ProhibitEmptyQuotes] +[-ValuesAndExpressions::ProhibitMagicNumbers] +[-ValuesAndExpressions::ProhibitNoisyQuotes] +[-Variables::ProhibitLocalVars] +[-Variables::ProhibitPackageVars] +[-Variables::ProhibitPunctuationVars] + +[RegularExpressions::RequireExtendedFormatting] +minimum_regex_length_to_complain_about = 20 + +[Documentation::RequirePodSections] +lib_sections = NAME | SYNOPSIS | DESCRIPTION | AUTHOR | COPYRIGHT AND LICENSE +script_sections = NAME | SYNOPSIS | DESCRIPTION | AUTHOR | COPYRIGHT AND LICENSE + +[Subroutines::RequireArgUnpacking] +short_subroutine_statements = 5 +allow_subscripts = 1 -- 2.39.2