TT#38005 fix/resolve various perlcritic errors

this is to fix the TAP tests of the sipwise QA chain

fixed (or ignored):
- ControlStructures::ProhibitMutatingListFunctions
- Documentation::RequirePodSections
- InputOutput::RequireEncodingWithUTF8Layer
- Subroutines::ProhibitSubroutinePrototypes
- BuiltinFunctions::ProhibitStringySplit
- TestingAndDebugging::ProhibitNoStrict
- TestingAndDebugging::ProhibitProlongedStrictureOverride
- InputOutput::ProhibitTwoArgOpen
- CodeLayout::ProhibitQuotedWordLists

Change-Id: I7dce4ce123bad40de2d9b51ba5b1a141e20c3783

Build.PL

@@ -22,14 +22,16 @@ __END__
 
 =encoding UTF-8
 
-=head1 NGCP-Panel
-
-A completely overhauled provisioning interface for the NGCP system.
-
 =head1 NAME
 
 Build.PL - NGCP-Panel build system including test fixtures
 
+=head1 DESCRIPTION
+
+NGCP-Panel
+
+A completely overhauled provisioning interface for the NGCP system.
+
 =head1 SYNOPSIS
 
     perl ./Build
@@ -92,3 +94,10 @@ In case your language did not exist already:
 
     msginit --input=lib/NGCP/Panel/I18N/messages.pot --output=lib/NGCP/Panel/I18N/$LANG.po --locale=$LANG
 
+=head1 AUTHOR
+
+Sipwise Development Team <support@sipwise.com>.
+
+=head1 LICENSE
+
+GPL-3+, Sipwise GmbH, Austria.

lib/NGCP/Panel/Controller/API/BillingFeesItem.pm

@@ -45,9 +45,8 @@ sub GET :Allow {
         # TODO: we don't need reseller stuff here!
         my $response = HTTP::Response->new(HTTP_OK, undef, HTTP::Headers->new(
             (map { # XXX Data::HAL must be able to generate links with multiple relations
-                s|rel="(http://purl.org/sipwise/ngcp-api/#rel-resellers)"|rel="item $1"|;
+                s|rel="(http://purl.org/sipwise/ngcp-api/#rel-resellers)"|rel="item $1"|r =~
-                s/rel=self/rel="item self"/;
+                s/rel=self/rel="item self"/r;
-                $_
             } $hal->http_headers),
         ), $hal->as_json);
         $c->response->headers($response->headers);

lib/NGCP/Panel/Controller/API/EmailTemplatesItem.pm

@@ -44,9 +44,8 @@ sub GET :Allow {
 
         my $response = HTTP::Response->new(HTTP_OK, undef, HTTP::Headers->new(
             (map { # XXX Data::HAL must be able to generate links with multiple relations
-                s|rel="(http://purl.org/sipwise/ngcp-api/#rel-resellers)"|rel="item $1"|;
+                s|rel="(http://purl.org/sipwise/ngcp-api/#rel-resellers)"|rel="item $1"|r =~
-                s/rel=self/rel="item self"/;
+                s/rel=self/rel="item self"/r;
-                $_
             } $hal->http_headers),
         ), $hal->as_json);
         $c->response->headers($response->headers);

lib/NGCP/Panel/Controller/CallRouting.pm

@@ -250,10 +250,9 @@ sub callroutingverify :Chained('/') :PathPart('callroutingverify') :Args(0) {
                 }
             }
         }
-        my $match = map { local $_ = $_;
+        my $match = map { my $val = s/\*/.*/gr;
-                          $_ =~ s/\*/.*/g;
+                          $val =~ s/\?/.?/g;
-                          $_ =~ s/\?/.?/g;
+                          $data->{caller_in} =~ /^$val$/;
-                          $data->{caller_in} =~ /^$_$/;
                         } @{$usr_prefs{allowed_clis}};
         if ($match) {
             push @log, sprintf

lib/NGCP/Panel/Form/Sound/LoadDefault.pm

@@ -33,7 +33,7 @@ sub build_langs {
         ->not(File::Find::Rule->new->name(qr/^\.\.?$/))
         ->in('/var/lib/ngcp-soundsets/system');
 
-    @options = map { $_ =~ s/^.+\///; { label => $_, value => $_ } } @dirs;
+    @options = map { my $val = s/^.+\///r; { label => $val, value => $val } } @dirs;
         
     return \@options;
 }

lib/NGCP/Panel/Role/API/Conversations.pm

@@ -804,7 +804,7 @@ sub process_hal_resource {
         })->first->mailboxuser->provisioning_voip_subscriber->voip_subscriber->id;
         # type is last item of path like /var/spool/asterisk/voicemail/default/uuid/INBOX
         my $filename = NGCP::Panel::Utils::Subscriber::get_voicemail_filename($c,$item_mock_obj);
-        my @p = split '/', $item_mock_obj->dir;
+        my @p = split /\//, $item_mock_obj->dir;
         $resource->{folder} = pop @p;
         $resource->{direction} = 'in';
         $resource->{filename} = $filename;

lib/NGCP/Panel/Role/API/PhonebookEntries.pm

@@ -15,11 +15,16 @@ sub _item_rs {
     my ($self, $c) = @_;
     my($owner,$type,$parameter,$value) = $self->check_owner_params($c);
     return unless $owner;
-    my $method = 'get_'.$type.'_phonebook_rs';
     my ($list_rs,$item_rs);
-    {
+
-        no strict 'refs';
+    if ($type eq 'reseller') {
-        ($list_rs,$item_rs) = &$method($c, $value, $type);
+        ($list_rs,$item_rs) = get_reseller_phonebook_rs($c, $value, $type);
+    } elsif ($type eq 'contract') {
+        ($list_rs,$item_rs) = get_contract_phonebook_rs($c, $value, $type);
+    } elsif ($type eq 'subscriber') {
+        ($list_rs,$item_rs) = get_subscriber_phonebook_rs($c, $value, $type);
+    } else {
+        die 'This shouln\'t happen';
     }
     return $list_rs;
 }

lib/NGCP/Panel/Role/API/Voicemails.pm

@@ -83,7 +83,7 @@ sub resource_from_item {
     $resource{subscriber_id} = int($item->mailboxuser->provisioning_voip_subscriber->voip_subscriber->id);
 
     # type is last item of path like /var/spool/asterisk/voicemail/default/uuid/INBOX
-    my @p = split '/', $item->dir;
+    my @p = split /\//, $item->dir;
     $resource{folder} = pop @p;
 
     return \%resource;

lib/NGCP/Panel/Utils/Device.pm

@@ -149,7 +149,7 @@ sub process_connectable_models{
                 push @$connectable_models_ids, $name_or_id;
             }
         }
-        my @columns = ('device_id' , 'extension_id');
+        my @columns = qw(device_id extension_id);
         if('extension' eq $devmod->type){
         #extension can be connected to other extensions? If I remember right - yes.
             @columns = reverse @columns;

lib/NGCP/Panel/Utils/Generic.pm

@@ -121,12 +121,14 @@ sub hash2obj {
     }
     $classname = __PACKAGE__ . '::' . $classname unless $classname =~ /::/;
     bless($obj,$classname);
-    no strict "refs";
+    no strict "refs";  ## no critic (ProhibitNoStrict)
     return $obj if scalar %{$classname . '::'};
+    use strict "refs";
     #print "registering class $classname\n";
     $accessors //= {};
     foreach my $accessor (keys %$accessors) {
         #print "registering accessor $classname::$accessor\n";
+        no strict "refs";  ## no critic (ProhibitNoStrict)
         *{$classname . '::' . $accessor} = sub {
             my $self = shift;
             return &{$accessors->{$accessor}}($self,@_);

lib/NGCP/Panel/Utils/InvoiceTemplate.pm

@@ -23,7 +23,7 @@ sub svg_pdf {
         push @pagefiles, $pagefile;
 
         open($fh, ">", $pagefile);
-        binmode($fh, ":utf8");
+        binmode($fh, ":encoding(UTF-8)");
         print $fh $page;
         close $fh;
 

lib/NGCP/Panel/Utils/Message.pm

@@ -36,7 +36,7 @@ sub get_log_params {
         my $caller = (caller 2)[3];
         $caller !~ /::/ and $caller = (caller 3)[3];
         if ($caller) {
-            my @caller = split('::', $caller);
+            my @caller = split(/::/, $caller);
             $#caller >= 3 and $called = join('::', @caller[-3...-1]);
         }
     }

lib/NGCP/Panel/Utils/Utf8.pm

@@ -10,6 +10,8 @@ use charnames ':full';
 
 our $VERSION = "1.01";
 
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
+
 # A Regexp string to match valid UTF8 bytes
 # this info comes from page 78 of "The Unicode Standard 4.0"
 # published by the Unicode Consortium

sandbox/banlist.pl

@@ -6,7 +6,7 @@ use XML::Mini::Document;
 use Data::Printer;
 
 my $f = 'banlist.xml';
-my $data = do { local $/ = undef; open my $fh, $f or die $!; <$fh> };
+my $data = do { local $/ = undef; open (my $fh, '<', $f) or die $!; <$fh> };
 my $xmlDoc = XML::Mini::Document->new();
 $xmlDoc->parse($data);
 my $xmlHash = $xmlDoc->toHash();

sandbox/billing_mapping_effective_date.t

@@ -462,7 +462,7 @@ sub test_contracts {
         my $old_contract_id = undef;
         my $contract = undef;
         while (my $row = <$fh>) {
-            my @cleaned = map { $_ =~ s/\\N//g; $_ =~ s/[\r\n]//gi; $_; } split(/,/,$row);
+            my @cleaned = map { s/\\N//gr =~ s/[\r\n]//gir; } split(/,/,$row);
             my ($now,$contract_id,$contract_create,$bm_actual_id,$id,$start_date,$end_date,
                 $profile_id,$profile_name,$network_id,$network_name,$product_id,$product_class) = @cleaned;
             #print join("\t",@cleaned) . "\n";

sandbox/hash2obj.pl

@@ -73,8 +73,10 @@ sub hash2obj {
   }
   $classname = __PACKAGE__ . '::' . $classname unless $classname =~ /::/;
   bless($obj,$classname);
-  no strict "refs"; # for below and to register new methods in package
+  # for below and to register new methods in package
+  no strict "refs";  ## no critic (ProhibitNoStrict)
   return $obj if scalar %{$classname . '::'};
+  use strict "refs";
   print "registering class $classname\n";
   $accessors //= {};
   my %accessors = ( (map { $_ => undef; } keys %$obj), %$accessors); # create accessors for fields too
@@ -82,6 +84,7 @@ sub hash2obj {
     print "registering accessor $classname::$accessor\n";
     # see http://search.cpan.org/~gsar/perl-5.6.1/pod/perltootc.pod
     # accessor can be a coderef ...
+    no strict "refs";  ## no critic (ProhibitNoStrict)
     *{$classname . '::' . $accessor} = sub {
       my $self = shift;
       &{$accessors{$accessor}}($self,shift) if scalar @_; #setter
@@ -93,6 +96,7 @@ sub hash2obj {
       $self->{$accessors{$accessor}} = shift if scalar @_; #setter
       return $self->{$accessors{$accessor}}; #getter
     } if '' eq ref $accessors{$accessor};
+    use strict "refs";
   }
   return $obj;
 }

share/tools/api_dump.pl

@@ -96,19 +96,18 @@ sub main {
 
     if (BALANCEINTERVALS_MODE eq $mode) {
 
-        my @cols = (
+        my @cols = qw/
-            'subscriber_id',
+            subscriber_id
-            'subscriber_status',
+            subscriber_status
-            'primary_number',
+            primary_number
-            'contract_id',
+            contract_id
-            'contract_status',
+            contract_status
-            #'has_actual_balance_interval',
+            interval_start
-            'interval_start',
+            interval_stop
-            'interval_stop',
+            cash_balance
-            'cash_balance',
+            notopup_discard_expiry
-            'notopup_discard_expiry',
+            package_id
-            'package_id',
+        /;
-        );
 
         my $rowcount = 0;
         my ($fh,$filename) = prepare_file($mode,$output_filename,\@cols);
@@ -161,28 +160,26 @@ sub main {
 
     } elsif (TOPUPLOG_MODE eq $mode) {
 
-        my @cols = (
+        my @cols = qw/
-            'username',
+            username
-            'timestamp',
+            timestamp
-            'request_token',
+            request_token
-            #'subscriber_id',
+            contract_id
-            #'primary_number',
+            outcome
-            'contract_id',
+            message
-            'outcome',
+            type
-            'message',
+            voucher_id
-            'type',
+            voucher_code
-            'voucher_id',
+            amount
-            'voucher_code',
+            cash_balance_before
-            'amount',
+            cash_balance_after
-            'cash_balance_before',
+            lock_level_before
-            'cash_balance_after',
+            lock_level_after
-            'lock_level_before',
+            package_before
-            'lock_level_after',
+            package_after
-            'package_before',
+            profile_before
-            'package_after',
+            profile_after
-            'profile_before',
+        /;
-            'profile_after',
-        );
 
         my $rowcount = 0;
         my ($fh,$filename) = prepare_file($mode,$output_filename,\@cols);

t/api-rest/api-all.t

@@ -143,7 +143,7 @@ sub get_opt{#get $opt
         "test-groups"     ,
     ) or pod2usage(2);
     my @opt_keys = keys %$opt_in;
-    @{$opt}{ map{my $k=$_;$k=~s/\-/_/;$k;} @opt_keys } = map {my $v = $opt_in->{$_}; $v={ map {$_=>1;} split(/[^[:alnum:]]+/,$v ) }; $v;} @opt_keys ;
+    @{$opt}{ map{ s/\-/_/; } @opt_keys } = map {my $v = $opt_in->{$_}; $v={ map {$_=>1;} split(/[^[:alnum:]]+/,$v ) }; $v;} @opt_keys ;
     print Dumper $opt;
     pod2usage(1) if $opt->{help};
     pod2usage(1) unless( 1
@@ -203,7 +203,7 @@ sub init_config{#init config
             ->mindepth(1)
             ->maxdepth(1)
             ->name('api-*.t');
-        %test_exists = map {$_=~s/\Q$dir\/\E//;$_ => 1} $rule->in($dir);
+        %test_exists = map { s/\Q$dir\/\E//r => 1} $rule->in($dir);
     }
     $config->{tests_exists} = \%test_exists;
     $config->{tests_exclude} = \%test_exclude;

t/lib/Test/FakeData.pm

@@ -591,7 +591,7 @@ sub set_data_from_script{
     }
     #dirty hack, part 2
     if(grep {/^load_data_only$/} @ARGV){
-        no strict "vars";
+        no strict "vars";  ## no critic (ProhibitNoStrict)
         $data_out = $data_in;
         die;
     }

t/lib/Test/HTTPRequestAsCurl.pm

@@ -14,7 +14,7 @@ sub as_curl {
     my ($request, %params) = @_;
 
     my $content = $request->content;
-    my @data    = split '&', $content;
+    my @data    = split /&/, $content;
     my $method  = $request->method;
     my $uri     = $request->uri;
     my $headers = $request->headers;