Przeglądaj źródła

Enable RequireArgUnpacking, unpacking arguments in signatures

The policy reported 28 subs that read @_ or its elements directly.  Two
are the main() of the scripts, and the rest are fakes and helpers in
the tests.  Each one takes a signature now, in the same way as the rest
of the tree, so the name of each argument is in the line that declares
it.

The fakes of Sys::Virt::Domain and of the tPSGI server end their
signatures in @.  The code under test calls the real methods, which take
optional arguments, and a fake that died on an extra argument would
test the fake.  A fake that does not read its invocant takes $ in its
place, because ProhibitUnusedVarsStricter reports an unused $self.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
troglodyne-bot 1 tydzień temu
rodzic
commit
b0bf6c82c2

+ 1 - 1
.perlcriticrc

@@ -246,7 +246,7 @@ allow = read write delete index shutdown
 [Subroutines::ProhibitReturnSort]
 [Subroutines::ProhibitReturnSort]
 [Subroutines::ProhibitSubroutinePrototypes]
 [Subroutines::ProhibitSubroutinePrototypes]
 [Subroutines::ProtectPrivateSubs]
 [Subroutines::ProtectPrivateSubs]
-#[Subroutines::RequireArgUnpacking]
+[Subroutines::RequireArgUnpacking]
 [Subroutines::RequireFinalReturn]
 [Subroutines::RequireFinalReturn]
 # tCMS: a sub that forks ends its child with POSIX::_exit, which never returns.
 # tCMS: a sub that forks ends its child with POSIX::_exit, which never returns.
 terminal_funcs = POSIX::_exit
 terminal_funcs = POSIX::_exit

+ 2 - 2
bin/tcms-useradd

@@ -115,10 +115,10 @@ my sub default_user_post {
     };
     };
 }
 }
 
 
-sub main {
+sub main (@args) {
     my %options;
     my %options;
     Getopt::Long::GetOptionsFromArray(
     Getopt::Long::GetOptionsFromArray(
-        \@_,
+        \@args,
         'user=s'          => \$options{user},
         'user=s'          => \$options{user},
         'display_name=s'  => \$options{display_name},
         'display_name=s'  => \$options{display_name},
         'help|?'          => \$options{help},
         'help|?'          => \$options{help},

+ 2 - 2
bin/tcmslogin

@@ -83,10 +83,10 @@ my sub read_password ($prompt) {
     return $password ? "$password" : undef;
     return $password ? "$password" : undef;
 }
 }
 
 
-sub main {
+sub main (@args) {
     my %options;
     my %options;
     Getopt::Long::GetOptionsFromArray(
     Getopt::Long::GetOptionsFromArray(
-        \@_,
+        \@args,
         'user=s'     => \$options{user},
         'user=s'     => \$options{user},
         'password:s' => \$options{password},
         'password:s' => \$options{password},
         'token=s'    => \$options{token},
         'token=s'    => \$options{token},

+ 1 - 1
t/Trog-DataModule-schema.t

@@ -78,7 +78,7 @@ sub set_components {
     return;
     return;
 }
 }
 
 
-sub sidecar { return JSON::MaybeXS::encode_json( { type => 'object', @_ } ) }
+sub sidecar (@fields) { return JSON::MaybeXS::encode_json( { type => 'object', @fields } ) }
 
 
 subtest 'the base schema applies with no sidecar at all' => sub {
 subtest 'the base schema applies with no sidecar at all' => sub {
     set_sidecars();
     set_sidecars();

+ 2 - 2
t/Trog-DataSource-ProvisionedVirt.t

@@ -107,9 +107,9 @@ $virt->redefine( is_self => sub { return $_[0] eq 'thisserver.example.com' ? 1 :
 
 
 write_config( trog_provisioner => "$ROOT/trog-provisioner" );
 write_config( trog_provisioner => "$ROOT/trog-provisioner" );
 
 
-sub reprovision {
+sub reprovision (@args) {
     @SPAWNED = ();
     @SPAWNED = ();
-    return Trog::DataSource::ProvisionedVirt::reprovision( passphrase => 'hunter2', user => 'admin', @_ );
+    return Trog::DataSource::ProvisionedVirt::reprovision( passphrase => 'hunter2', user => 'admin', @args );
 }
 }
 
 
 require Trog::Auth;
 require Trog::Auth;

+ 9 - 9
t/Trog-DataSource-Virt.t

@@ -27,17 +27,17 @@ our @CALLS;
 {
 {
 
 
     package FakeDomain;
     package FakeDomain;
-    sub new             { my ( $c, %a ) = @_; return bless {%a}, $c }
-    sub get_name        { return $_[0]{name} }
-    sub get_uuid_string { return $_[0]{uuid} }
-    sub is_active       { return $_[0]{active} }
-    sub get_info        { return { state => $_[0]{state}, memory => 1024, nrVirtCpu => 2 } }
+    sub new { my ( $c, %a ) = @_; return bless {%a}, $c }
+    sub get_name        ( $self, @ ) { return $self->{name} }
+    sub get_uuid_string ( $self, @ ) { return $self->{uuid} }
+    sub is_active       ( $self, @ ) { return $self->{active} }
+    sub get_info        ( $self, @ ) { return { state => $self->{state}, memory => 1024, nrVirtCpu => 2 } }
 
 
     # The operations we must never actually perform: record and return.
     # The operations we must never actually perform: record and return.
-    sub create          { push @main::CALLS, [ 'create',          $_[0]{name} ]; return 1 }
-    sub shutdown        { push @main::CALLS, [ 'shutdown',        $_[0]{name} ]; return 1 }
-    sub destroy         { push @main::CALLS, [ 'destroy',         $_[0]{name} ]; return 1 }
-    sub create_snapshot { push @main::CALLS, [ 'create_snapshot', $_[0]{name} ]; return 1 }
+    sub create          ( $self, @ ) { push @main::CALLS, [ 'create',          $self->{name} ]; return 1 }
+    sub shutdown        ( $self, @ ) { push @main::CALLS, [ 'shutdown',        $self->{name} ]; return 1 }
+    sub destroy         ( $self, @ ) { push @main::CALLS, [ 'destroy',         $self->{name} ]; return 1 }
+    sub create_snapshot ( $self, @ ) { push @main::CALLS, [ 'create_snapshot', $self->{name} ]; return 1 }
 
 
     # Reading a console is not a mutation, so this one really runs.
     # Reading a console is not a mutation, so this one really runs.
     sub screenshot { return 'image/png' }
     sub screenshot { return 'image/png' }

+ 19 - 19
t/Trog-Routes-HTML-series-lifecycle.t

@@ -200,17 +200,17 @@ require Trog::Routes::JSON;
     sub EMERG { return 1 }
     sub EMERG { return 1 }
     sub FATAL { return 1 }
     sub FATAL { return 1 }
 
 
-    sub see_also           { return [ 303, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
-    sub redirect           { return [ 302, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
-    sub redirect_permanent { return [ 301, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
-
-    sub reply      { return [ $_[1], [ 'Content-type' => 'text/html' ], [ defined $_[2] ? $_[2] : '' ] ] }
-    sub ok         { return $_[0]->reply( 200, $_[2] ) }
-    sub notfound   { return $_[0]->reply( 404, $_[2] // 'Not Found' ) }
-    sub forbidden  { return $_[0]->reply( 403, $_[2] // 'Forbidden' ) }
-    sub badrequest { return $_[0]->reply( 400, $_[2] // 'Bad Request' ) }
-    sub error      { return $_[0]->reply( 500, $_[2] // 'Error' ) }
-    sub serve      { return [ 200, [], [''] ] }
+    sub see_also           ( $, $to, @ ) { return [ 303, [ 'Location' => $to, 'Content-Length' => 0 ], [''] ] }
+    sub redirect           ( $, $to, @ ) { return [ 302, [ 'Location' => $to, 'Content-Length' => 0 ], [''] ] }
+    sub redirect_permanent ( $, $to, @ ) { return [ 301, [ 'Location' => $to, 'Content-Length' => 0 ], [''] ] }
+
+    sub reply      ( $, $code, $body = undef, @ ) { return [ $code, [ 'Content-type' => 'text/html' ], [ $body // '' ] ] }
+    sub ok         ( $self, $, $body = undef, @ ) { return $self->reply( 200, $body ) }
+    sub notfound   ( $self, $, $body = undef, @ ) { return $self->reply( 404, $body // 'Not Found' ) }
+    sub forbidden  ( $self, $, $body = undef, @ ) { return $self->reply( 403, $body // 'Forbidden' ) }
+    sub badrequest ( $self, $, $body = undef, @ ) { return $self->reply( 400, $body // 'Bad Request' ) }
+    sub error      ( $self, $, $body = undef, @ ) { return $self->reply( 500, $body // 'Error' ) }
+    sub serve { return [ 200, [], [''] ] }
 
 
     # These two must be inert.
     # These two must be inert.
     #
     #
@@ -229,7 +229,7 @@ require Trog::Routes::JSON;
     }
     }
 
 
     # The real one is `kill 'HUP', getppid`.  Under prove, that is prove.
     # The real one is `kill 'HUP', getppid`.  Under prove, that is prove.
-    sub signal_restart_parent { $_[0]{restarts}++; return 1 }
+    sub signal_restart_parent ( $self, @ ) { $self->{restarts}++; return 1 }
 
 
     # Recorded rather than inert: a datasource that watches something is
     # Recorded rather than inert: a datasource that watches something is
     # supposed to register here, and the lifecycle test is where we find out
     # supposed to register here, and the lifecycle test is where we find out
@@ -240,9 +240,9 @@ require Trog::Routes::JSON;
         return 1;
         return 1;
     }
     }
 
 
-    sub invalidate_renders { push @{ $_[0]{invalidated} }, $_[1];              return 1 }
-    sub invalidate_render  { push @{ $_[0]{invalidated} }, [ @_[ 1 .. $#_ ] ]; return 1 }
-    sub save_render        { $_[0]{renders}{"$_[1]:$_[2]"} = $_[3]; return 1 }
+    sub invalidate_renders ( $self, $what, @ ) { push @{ $self->{invalidated} }, $what;   return 1 }
+    sub invalidate_render  ( $self, @what )    { push @{ $self->{invalidated} }, [@what]; return 1 }
+    sub save_render        ( $self, $route, $type, $content, @ ) { $self->{renders}{"$route:$type"} = $content; return 1 }
 }
 }
 
 
 our $TPSGI = Test::TPSGI->new();
 our $TPSGI = Test::TPSGI->new();
@@ -282,8 +282,8 @@ my sub query {
     return \%q;
     return \%q;
 }
 }
 
 
-my sub anon  { return query( user => undef,       user_acls => [],        @_ ) }
-my sub admin { return query( user => $ADMIN_USER, user_acls => ['admin'], @_ ) }
+my sub anon  (@args) { return query( user => undef,       user_acls => [],        @args ) }
+my sub admin (@args) { return query( user => $ADMIN_USER, user_acls => ['admin'], @args ) }
 
 
 # Returns ($code, $body, $error).  Never dies, so one bad post type cannot take
 # Returns ($code, $body, $error).  Never dies, so one bad post type cannot take
 # the rest of the file with it -- which matters because a failed render inside
 # the rest of the file with it -- which matters because a failed render inside
@@ -331,8 +331,8 @@ my sub topbar_titles {
 }
 }
 
 
 # post_title.tx emits exactly one of these per displayed post.
 # post_title.tx emits exactly one of these per displayed post.
-my sub post_count {
-    my $n = () = $_[0] =~ m{<h3[ ]class='blogtitles'>}g;
+my sub post_count ($body) {
+    my $n = () = $body =~ m{<h3[ ]class='blogtitles'>}g;
     return $n;
     return $n;
 }
 }