Sfoglia il codice sorgente

Set the regex defaults with use re '/aasx', not flags on each regex

Every regex carried its own /x and /s, to satisfy RequireExtendedFormatting
and RequireDotMatchAnything.  Perl::Critic honors the defaults that use re
sets, so one line per file says the same thing, and a new regex cannot
leave the flags out.  The router patterns are matched under
no re '/aasx'.  The test of that still fails when that line is removed.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
troglodyne-bot 6 giorni fa
parent
commit
007ca974f2
13 ha cambiato i file con 56 aggiunte e 56 eliminazioni
  1. 1 1
      .perlcriticrc
  2. 5 5
      .tests-covering-map.pl
  3. 1 1
      bin/tpsgi
  4. 1 1
      bin/tpsgi-config
  5. 2 2
      call.pl
  6. 2 2
      lib/Plack/Handler/TPSGI.pm
  7. 20 20
      lib/TPSGI.pm
  8. 1 1
      lib/TPSGI/Server.pm
  9. 3 3
      lib/TPSGI/Startup.pm
  10. 2 2
      t/TPSGI-Server.t
  11. 14 14
      t/TPSGI.t
  12. 3 3
      t/loggers.t
  13. 1 1
      t/watch.t

+ 1 - 1
.perlcriticrc

@@ -102,7 +102,7 @@ exclude_functions = print
 [RequireFatalWarnings]
 [ProhibitUnusedImports]
 # Modules imported for a side effect rather than for a symbol, which the policy
-# cannot see.  `re` is here because every file says `use re '/aa'`.  Add your
+# cannot see.  `re` is here because every file says `use re '/aasx'`.  Add your
 # own: IO::Prompter installs prompt() from a custom import rather than @EXPORT,
 # and anything loaded by name from a string is invisible the same way.
 # Test2::Plugin::NoWarnings fails a test that warns, and imports nothing.

+ 5 - 5
.tests-covering-map.pl

@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 =head1 NAME
 
@@ -65,12 +65,12 @@ return sub {
     my ($path) = @_;
 
     return q{} if $NO_TESTS{$path};
-    return q{} if $path =~ m{\A(?:git-hooks|[.]github|xt)/}sx;
-    return q{} if $path =~ m{[.]md\z}sx;
-    return q{} if $path =~ m{[.]pod\z}sx && $path !~ m{\Alib/}sx;
+    return q{} if $path =~ m{\A(?:git-hooks|[.]github|xt)/};
+    return q{} if $path =~ m{[.]md\z};
+    return q{} if $path =~ m{[.]pod\z} && $path !~ m{\Alib/};
 
     # The service's shell script and unit template, which no test runs.
-    return q{} if $path =~ m{\Aservice/}sx;
+    return q{} if $path =~ m{\Aservice/};
 
     return;
 };

+ 1 - 1
bin/tpsgi

@@ -5,7 +5,7 @@
 
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use FindBin::libs;
 use File::Basename qw{dirname};

+ 1 - 1
bin/tpsgi-config

@@ -7,7 +7,7 @@ package TPSGI::ConfigTool;
 
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use FindBin::libs;
 use Getopt::Long qw{GetOptionsFromArray};

+ 2 - 2
call.pl

@@ -3,7 +3,7 @@
 
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use Data::Dumper;
 use FindBin::libs;
@@ -71,7 +71,7 @@ our $app = sub {
 
         # Redact the stack trace past line 1, it usually has things which should not be shown
         $self->{cur_query}->{message} = $@;
-        $self->{cur_query}->{message} =~ s/\n.*//gxs if $self->{cur_query}->{message};
+        $self->{cur_query}->{message} =~ s/\n.*//g if $self->{cur_query}->{message};
         return $self->error( $self->{cur_query} );
     };
 };

+ 2 - 2
lib/Plack/Handler/TPSGI.pm

@@ -4,7 +4,7 @@ package Plack::Handler::TPSGI;
 
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use parent qw{Plack::Handler::Starman};
 
@@ -27,7 +27,7 @@ sub run {
 
     my %nsa;
     foreach my $key ( keys %$self ) {
-        ( my $name = $key ) =~ s/^net_server_//xs or next;
+        ( my $name = $key ) =~ s/^net_server_// or next;
         $nsa{$name} = $self->{$key};
     }
     $self->{net_server_args} = \%nsa if %nsa;

+ 20 - 20
lib/TPSGI.pm

@@ -4,7 +4,7 @@ package TPSGI;
 
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use Carp::Always;
 
@@ -259,7 +259,7 @@ sub new {
         die "No such routing module $route" unless -e "$options{tpsgi_dir}/$route";
 
         # The router needs to exist and have nonzero numbers of routes.
-        my ($package) = basename($route) =~ m/(\S+)[.]pm$/xs;
+        my ($package) = basename($route) =~ m/(\S+)[.]pm$/;
 
         # It also should be a top-level namespace, not somewhere deep down. KISS.
         my $libdir = dirname("$options{tpsgi_dir}/$route");
@@ -415,7 +415,7 @@ sub serve {    ## no critic (ProhibitManyArgs) -- routers call it with these, in
 
         # Copy to the statics if it's not already there
         my $static_path = $path;
-        $static_path =~ s{^/*www/}{}xs;
+        $static_path =~ s{^/*www/}{};
         $static_path = "$self->{tpsgi_dir}/www/static/$static_path";
 
         my $target_dir = dirname($static_path);
@@ -648,7 +648,7 @@ sub app {
 
         # Redact the stack trace past line 1, it usually has things which should not be shown
         $cur_query->{message} = $err;
-        $cur_query->{message} =~ s/\n.*//gxs if $cur_query->{message} && !$debug;
+        $cur_query->{message} =~ s/\n.*//g if $cur_query->{message} && !$debug;
 
         return $self->error($cur_query);
     };
@@ -690,7 +690,7 @@ sub cannot_start {
 
     my $detail = '';
     if ($debug) {
-        ( my $escaped = $error ) =~ s/([&<>"])/'&#' . ord($1) . ';'/gexs;
+        ( my $escaped = $error ) =~ s/([&<>"])/'&#' . ord($1) . ';'/ge;
         $detail = "<pre>$escaped</pre>";
     }
 
@@ -706,7 +706,7 @@ my %etags;
 # spaces, and /s would change what a dot matches.
 my sub match_route {
     my ( $path, $pattern ) = @_;
-    no re '/aa';
+    no re '/aasx';
     return $path =~ m/^$pattern$/;    ## no critic (RequireDefault RequireExtendedFormatting RequireDotMatchAnything)
 }
 
@@ -738,7 +738,7 @@ sub respond {
     my $path   = $env->{PATH_INFO}             || '/';
 
     # de-pooplicate the path
-    $path =~ s{//}{/}gxs;
+    $path =~ s{//}{/}g;
 
     my $port   = $env->{HTTP_X_FORWARDED_PORT} // $env->{HTTP_PORT};
     my $pport  = defined $port ? ":$port" : "";
@@ -792,8 +792,8 @@ sub respond {
 
     # Figure out if we want compression or not
     my $alist = $env->{HTTP_ACCEPT_ENCODING} || '';
-    $alist =~ s/\s//gxs;
-    my @accept_encodings = split( /,/xs, $alist );
+    $alist =~ s/\s//g;
+    my @accept_encodings = split( /,/, $alist );
     my $deflate          = grep { 'gzip' eq $_ } @accept_encodings;
 
     # Set the IP of the request so we can fail2ban
@@ -846,7 +846,7 @@ sub respond {
         foreach my $index ( @{ $self->indices } ) {
             next if $file_actual;
             my $dirindex = $self->mangle_filename("www$path/$index");
-            $dirindex =~ s{//}{/}gxs;
+            $dirindex =~ s{//}{/}g;
             $file_actual = $dirindex if -e $dirindex && !-d _;
         }
     }
@@ -892,10 +892,10 @@ sub parse_ranges {
 
     my @ranges;
     if ($range) {
-        $range =~ s{bytes=}{}gxs;
+        $range =~ s{bytes=}{}g;
         push(
             @ranges,
-            map { [ split( /-/xs, $_ ) ]; } split( /,/xs, $range )
+            map { [ split( /-/, $_ ) ]; } split( /,/, $range )
         );
     }
     return @ranges;
@@ -916,7 +916,7 @@ sub appears_executable {
     # Definitely not executable if it does not exist!
     return 0 unless $subj;
     return 0 unless -x $subj;    ## no critic (ProhibitFiletest_rwxRWX) -- whether to run it, not whether we may
-    my ($extension) = $subj =~ m/[.](\S+)$/xs;
+    my ($extension) = $subj =~ m/[.](\S+)$/;
     return 1 if !$extension;
     return 1 if List::Util::any { $extension eq $_ } @executable_extensions;
     return 0;
@@ -1432,7 +1432,7 @@ sub save_render {
     return unless $path && $extension;
 
     # If this is an index, let's make it so
-    if ( $path =~ m{/$}xs ) {
+    if ( $path =~ m{/$} ) {
         $path = $path . 'index';
     }
 
@@ -1440,7 +1440,7 @@ sub save_render {
     $extension = $fixup{$extension} if exists $fixup{$extension};
 
     my $path_fixed = $path;
-    $path_fixed =~ s/[.]\Q$extension\E$//xs;
+    $path_fixed =~ s/[.]\Q$extension\E$//;
     $path_fixed = "$path_fixed.$extension";
 
     my $path2file = "$self->{tpsgi_dir}/www/static/" . dirname($path_fixed);
@@ -1475,7 +1475,7 @@ sub invalidate_render {
     $extension = $fixup{$extension} if exists $fixup{$extension};
 
     my $path_fixed = $path;
-    $path_fixed =~ s/[.]\Q$extension\E$//xs;
+    $path_fixed =~ s/[.]\Q$extension\E$//;
     $path_fixed = "$path_fixed.$extension";
 
     my $file = "$self->{tpsgi_dir}/www/static/$path_fixed";
@@ -1497,7 +1497,7 @@ sub invalidate_renders {
         {
             wanted => sub {
                 my $object = $_;
-                invalidate_file( $self, $object ) if ( !-d $object && $object =~ m/[.]\Q$extension\E$/xs );
+                invalidate_file( $self, $object ) if ( !-d $object && $object =~ m/[.]\Q$extension\E$/ );
             },
             no_chdir => 1,
             bydepth  => 1,
@@ -1589,7 +1589,7 @@ sub add_watch {
     };
     if ( !defined $wd ) {
         my $why = $@;
-        $why =~ s/\n.*//sx if $why;
+        $why =~ s/\n.*// if $why;
         $self->WARN("Could not watch $path for changes: $why");
         return undef;
     }
@@ -1634,11 +1634,11 @@ sub handle_changes {
         # A watch descriptor we know nothing about belongs to a worker which registered
         # watches we didn't.  All we can sensibly do with those is the old behavior.
         if ( !$watch ) {
-            $had_changes++ if $change->{path} =~ m/[.]pm$/xs;
+            $had_changes++ if $change->{path} =~ m/[.]pm$/;
             next;
         }
 
-        $had_changes++ if $watch->{restart} && $change->{path} =~ m/[.]pm$/xs;
+        $had_changes++ if $watch->{restart} && $change->{path} =~ m/[.]pm$/;
 
         foreach my $cb ( @{ $watch->{callbacks} } ) {
             local $@;

+ 1 - 1
lib/TPSGI/Server.pm

@@ -4,7 +4,7 @@ package TPSGI::Server;
 
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use parent qw{Starman::Server};
 

+ 3 - 3
lib/TPSGI/Startup.pm

@@ -8,7 +8,7 @@ package TPSGI::Startup;
 
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use Cwd;
 use File::Basename qw{dirname};
@@ -109,7 +109,7 @@ sub watch_for_changes {
         {
             wanted => sub {
                 my $object = $_;
-                push( @to_watch, $object ) if ( !-d $object && $object =~ m/[.]pm$/xs );
+                push( @to_watch, $object ) if ( !-d $object && $object =~ m/[.]pm$/ );
             },
             no_chdir => 1,
             bydepth  => 1,
@@ -323,7 +323,7 @@ sub pending_changes {
     foreach my $event ( $inotify->read() ) {
         my $watch   = $watches{ $event->{wd} };
         my $watched = $watch ? $watch->{path} : '';
-        $watched =~ s{/+$}{}xs;
+        $watched =~ s{/+$}{};
 
         # Directory watches tell us the entry which changed, file watches don't.
         my $path = $watched;

+ 2 - 2
t/TPSGI-Server.t

@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use Test2::V0;
 use Test2::Plugin::NoWarnings;
@@ -81,7 +81,7 @@ subtest 'every connection is answered while the parent is HUPed' => sub {
                 print {$c} "GET / HTTP/1.0\r\n\r\n";
                 my $got = do { local $/; <$c> }
                   // '';
-                $bad++ unless $got =~ m{^HTTP/1[.]\d[ ]200}xs;
+                $bad++ unless $got =~ m{^HTTP/1[.]\d[ ]200};
             }
             exit( $bad > 255 ? 255 : $bad );
         }

+ 14 - 14
t/TPSGI.t

@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use Test2::V0;
 use Test2::Plugin::NoWarnings;
@@ -62,7 +62,7 @@ subtest 'cannot_start, when building the log is what failed' => sub {
         'a logger that will not load does not turn the 500 into an exception'
     ) or note $@;
     is( $res->[0], 500, 'it still answers 500' );
-    like( $$written, qr/Could[ ]not[ ]load[ ]Bogus\.pm/xs, 'and psgi.errors still gets the reason' );
+    like( $$written, qr/Could[ ]not[ ]load[ ]Bogus\.pm/, 'and psgi.errors still gets the reason' );
 };
 
 subtest 'cannot_start' => sub {
@@ -71,9 +71,9 @@ subtest 'cannot_start' => sub {
 
     my $res = TPSGI::cannot_start( "Could not load Bogus.pm!\nCan't locate Bogus/Dep.pm in \@INC\n", $env, %options );
     is( $res->[0], 500, 'answers 500' );
-    like( $$written, qr/Can't[ ]locate[ ]Bogus\/Dep\.pm/xs, 'psgi.errors gets the whole reason' );
-    my $reason = qr/Could[ ]not[ ]load[ ]Bogus[.]pm!/xs;
-    like( \@Test::Logger::Capture::lines, bag { item qr/Could[ ]not[ ]start:[ ]$reason\nCan't[ ]locate/xs; etc() }, 'and so does the log' );
+    like( $$written, qr/Can't[ ]locate[ ]Bogus\/Dep\.pm/, 'psgi.errors gets the whole reason' );
+    my $reason = qr/Could[ ]not[ ]load[ ]Bogus[.]pm!/;
+    like( \@Test::Logger::Capture::lines, bag { item qr/Could[ ]not[ ]start:[ ]$reason\nCan't[ ]locate/; etc() }, 'and so does the log' );
 
     ok( lives { TPSGI::cannot_start( "no env\n", undef, %options ) }, 'a missing env is not a second failure' ) or note $@;
 };
@@ -95,14 +95,14 @@ subtest 'cannot_start answers with a page' => sub {
     my $res  = TPSGI::cannot_start( $error, ( fake_env() )[0], %options );
     my %head = @{ $res->[1] };
     is( $head{'Content-type'}, 'text/html', 'in HTML' );
-    like( $res->[2][0], qr/<h1>Internal[ ]Server[ ]Error<\/h1>/xs, 'saying what happened' );
-    unlike( $res->[2][0], qr/Bogus/xs, 'and, without TPSGI_DEBUG, not why' );
+    like( $res->[2][0], qr/<h1>Internal[ ]Server[ ]Error<\/h1>/, 'saying what happened' );
+    unlike( $res->[2][0], qr/Bogus/, 'and, without TPSGI_DEBUG, not why' );
 
     local $TPSGI::debug = 1;
     $res = TPSGI::cannot_start( $error, ( fake_env() )[0], %options );
     my $escaped = q{Can't locate &#60;Bogus/Dep.pm&#62; in @INC &#38; &#34;elsewhere&#34;};
-    like( $res->[2][0], qr/\Q$escaped\E/xs, 'with TPSGI_DEBUG, the error, escaped' );
-    unlike( $res->[2][0], qr/<Bogus/xs, 'none of it read as markup' );
+    like( $res->[2][0], qr/\Q$escaped\E/, 'with TPSGI_DEBUG, the error, escaped' );
+    unlike( $res->[2][0], qr/<Bogus/, 'none of it read as markup' );
 };
 
 subtest 'app, when the request dies' => sub {
@@ -116,8 +116,8 @@ subtest 'app, when the request dies' => sub {
     my $res   = $tpsgi->app($env);
 
     is( $res->[0], 500, 'answers 500' );
-    like( $$written,                      qr/Can't[ ]locate[ ]Bogus\/Dep\.pm/xs,                                         'psgi.errors gets the reason' );
-    like( \@Test::Logger::Capture::lines, bag { item qr/Request[ ]failed:[ ]Can't[ ]locate[ ]Bogus\/Dep\.pm/xs; etc() }, 'and so does the log, not just that a 500 happened' );
+    like( $$written,                      qr/Can't[ ]locate[ ]Bogus\/Dep\.pm/,                                         'psgi.errors gets the reason' );
+    like( \@Test::Logger::Capture::lines, bag { item qr/Request[ ]failed:[ ]Can't[ ]locate[ ]Bogus\/Dep\.pm/; etc() }, 'and so does the log, not just that a 500 happened' );
 };
 
 subtest 'serve_ranges' => sub {
@@ -130,14 +130,14 @@ subtest 'serve_ranges' => sub {
 
     open( my $fh, '<', $file ) or die "Cannot read $file: $!";
     my $res = $tpsgi->serve_ranges( $fh, [ [ 0, 4 ] ], %args );
-    is( ref $res,                                                 'CODE', 'a range inside the file is streamed' );
-    is( [ grep { /GET[ ]416/xs } @Test::Logger::Capture::lines ], [],     'and not logged as a 416' );
+    is( ref $res,                                               'CODE', 'a range inside the file is streamed' );
+    is( [ grep { /GET[ ]416/ } @Test::Logger::Capture::lines ], [],     'and not logged as a 416' );
     close($fh) or die "Cannot close: $!";
 
     open( $fh, '<', $file ) or die "Cannot read $file: $!";
     $res = $tpsgi->serve_ranges( $fh, [ [ 0, 4 ], [ 20, 25 ] ], %args );
     is( $res->[0], 416, 'a range past the end is refused' );
-    like( \@Test::Logger::Capture::lines, bag { item qr/GET[ ]416[ ]\/ten-bytes/xs; etc() }, 'and logged as a 416' );
+    like( \@Test::Logger::Capture::lines, bag { item qr/GET[ ]416[ ]\/ten-bytes/; etc() }, 'and logged as a 416' );
     close($fh) or die "Cannot close: $!";
 };
 

+ 3 - 3
t/loggers.t

@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use Test2::V0;
 use Test2::Plugin::NoWarnings;
@@ -65,10 +65,10 @@ ok( lives { $tpsgi->log }, 'a logger class that nothing loaded is loaded by name
 no warnings 'once';
 is( $Test::Logger::Capture::given{log_dir},   $dir,   'it is handed the log directory' );
 is( $Test::Logger::Capture::given{min_level}, 'info', 'and the level' );
-like( \@Test::Logger::Capture::lines, [qr/Opening[ ]Log/xs], 'and it receives the lines that the file gets' );
+like( \@Test::Logger::Capture::lines, [qr/Opening[ ]Log/], 'and it receives the lines that the file gets' );
 
 # The name becomes a path to load, so only a module name is one.
 my $refusing = bless( { %$tpsgi, loggers => ['../../etc/passwd'] }, 'TPSGI' );
-like( dies { $refusing->build_log }, qr/not[ ]a[ ]module[ ]name/xs, 'a logger that is not a module name is refused' );
+like( dies { $refusing->build_log }, qr/not[ ]a[ ]module[ ]name/, 'a logger that is not a module name is refused' );
 
 done_testing();

+ 1 - 1
t/watch.t

@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use 5.040;
 use warnings FATAL => 'all';
-use re '/aa';
+use re '/aasx';
 
 use Test2::V0;