Add perlcritic test and make code compliant

diff --git a/lib/HTML/Element/Library.pm b/lib/HTML/Element/Library.pm
index 8ad83419d7235a9659f4bf602720d8c4e87db2ca..5336eefe4650c91746da1864d49d3e6970b3637a 100644 (file)
--- 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 (file)
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 (file)
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