Merge pull request #364 from Troglodyne-Internet-Widgets/package-names

Fix two bugs that critic found, and enable the policies with five violations or fewer

.perlcriticrc

@@ -37,23 +37,23 @@ color     = 1
 allow-unsafe = 1
 # Usability
 [Modules::RequirePerlVersion]
-#[Documentation::RequirePod]
+[Documentation::RequirePod]
 # Security
 [ValuesAndExpressions::PreventSQLInjection]
 # Drop this one at 5.041 and later.  It also applies to POD, where the only
 # thing it tends to catch is a contributor's name in the section Dist::Zilla
 # generates, and spelling somebody's name wrong is not a code standard.
-#[CodeLayout::RequireASCII]
+[CodeLayout::RequireASCII]
 [RegularExpressions::RequireDefault]
 strict = 1
-#[RegularExpressions::PreventUselessMetacharacterEscapes]
+[RegularExpressions::PreventUselessMetacharacterEscapes]
 # PEBCAK catches
 [BuiltinFunctions::ProhibitDeleteOnArrays]
 [Subroutines::ProhibitAmbiguousFunctionCalls]
 [ValuesAndExpressions::ProhibitSingleArgArraySlice]
 [ValuesAndExpressions::ProhibitDefinedBeforeLength]
 [Variables::ProhibitUselessVarClearing]
-#[Subroutines::ProhibitTailRecursion]
+[Subroutines::ProhibitTailRecursion]
 [Bangs::ProhibitUselessRegexModifiers]
 [Bangs::ProhibitCommentedOutCode]
 [Tics::ProhibitUseBase]
@@ -62,7 +62,7 @@ strict = 1
 [ValuesAndExpressions::UnexpandedSpecialLiteral]
 [CodeLayout::ProhibitIfIfSameLine]
 [ValuesAndExpressions::ConstantBeforeLt]
-#[ValuesAndExpressions::ProhibitDuplicateHashKeys]
+[ValuesAndExpressions::ProhibitDuplicateHashKeys]
 # any access checks are necessarily a TOCTOU waiting to happen
 #[ValuesAndExpressions::ProhibitFiletest_f]
 [ValuesAndExpressions::ProhibitFiletest_rwxRWX]
@@ -71,25 +71,25 @@ strict = 1
 warn_level = 40
 info_level = 30
 [Variables::ProhibitUselessInitialization]
-#[PreferredModules]
+[PreferredModules]
 #config = .preferred_modules.ini
 [logicLAB::RequireSheBang]
 formats = #!/usr/bin/env perl
 # Performance
-#[logicLAB::ProhibitShellDispatch]
+[logicLAB::ProhibitShellDispatch]
 [ProhibitPipeOpen]
 #[Performance::ProhibitRegexForSimpleSubstring]
-#[RegularExpressions::ProhibitRegexToStripAffix]
+[RegularExpressions::ProhibitRegexToStripAffix]
 [RegularExpressions::ProhibitRegexToChomp]
 [BuiltinFunctions::ProhibitChainingSameListSub]
 [RegularExpressions::ProhibitRegexForStringEquality]
 [Subroutines::ProhibitUnderscorePrivateSubs]
 #[Subroutines::ProhibitSingleUseLexicalSubs]
-#[ValuesAndExpressions::ProhibitLiteralArithmetic]
+[ValuesAndExpressions::ProhibitLiteralArithmetic]
 [BuiltinFunctions::ProhibitIndirectBooleanGrep]
 # What ProhibitMutatingListFunctions reports, which this replaces, and a block
 # that changes $_ through a sub that it calls.
-#[ControlStructures::ProhibitMutatingListFunctionsStricter]
+[ControlStructures::ProhibitMutatingListFunctionsStricter]
 # An if, elsif, else or unless whose block holds no statement, a comment
 # being none.  Loops are left alone, because a loop condition can do the work.
 [ControlStructures::ProhibitEmptyConditionalBlocks]
@@ -100,7 +100,7 @@ exclude_functions = print
 [ProhibitUseLib]
 #[ProhibitUsageSubs]
 [RequireQwForLiteralLists]
-#[ProhibitNoWarningsRedefine]
+[ProhibitNoWarningsRedefine]
 [RequireFatalWarnings]
 [ProhibitUnusedImports]
 # Modules imported for a side effect rather than for a symbol, which the policy
@@ -171,14 +171,14 @@ allow = re Exporter
 [BuiltinFunctions::ProhibitUniversalCan]
 [BuiltinFunctions::ProhibitUniversalIsa]
 [BuiltinFunctions::ProhibitVoidGrep]
-#[BuiltinFunctions::ProhibitVoidMap]
+[BuiltinFunctions::ProhibitVoidMap]
 [BuiltinFunctions::RequireBlockGrep]
 [BuiltinFunctions::RequireBlockMap]
 [BuiltinFunctions::RequireGlobFunction]
 [BuiltinFunctions::RequireSimpleSortBlock]
 [ClassHierarchies::ProhibitAutoloading]
-#[ClassHierarchies::ProhibitExplicitISA]
-#[ClassHierarchies::ProhibitOneArgBless]
+[ClassHierarchies::ProhibitExplicitISA]
+[ClassHierarchies::ProhibitOneArgBless]
 [CodeLayout::ProhibitHardTabs]
 [CodeLayout::ProhibitTrailingWhitespace]
 [CodeLayout::RequireConsistentNewlines]
@@ -215,14 +215,14 @@ allow = re Exporter
 #[Miscellanea::ProhibitUselessNoCritic]
 [Modules::ProhibitAutomaticExportation]
 #[Modules::ProhibitConditionalUseStatements]
-#[Modules::RequireBarewordIncludes]
-#[Modules::RequireFilenameMatchesPackage]
+[Modules::RequireBarewordIncludes]
+[Modules::RequireFilenameMatchesPackage]
 [Modules::RequireNoMatchVarsWithUseEnglish]
 #[NamingConventions::Capitalization]
 [RegularExpressions::ProhibitCaptureWithoutTest]
 #[RegularExpressions::ProhibitComplexRegexes]
 #[RegularExpressions::ProhibitEnumeratedClasses]
-#[RegularExpressions::ProhibitFixedStringMatches]
+[RegularExpressions::ProhibitFixedStringMatches]
 [RegularExpressions::ProhibitSingleCharAlternation]
 [RegularExpressions::ProhibitUnusedCapture]
 [RegularExpressions::RequireBracesForMultiline]
@@ -232,7 +232,7 @@ allow = re Exporter
 #[Subroutines::ProhibitBuiltinHomonyms]
 [Subroutines::ProhibitManyArgs]
 [Subroutines::ProhibitNestedSubs]
-#[Subroutines::ProhibitReturnSort]
+[Subroutines::ProhibitReturnSort]
 [Subroutines::ProhibitSubroutinePrototypes]
 [Subroutines::ProtectPrivateSubs]
 #[Subroutines::RequireArgUnpacking]
@@ -245,7 +245,7 @@ terminal_funcs = POSIX::_exit
 [ValuesAndExpressions::ProhibitComplexVersion]
 [ValuesAndExpressions::ProhibitEscapedCharacters]
 [ValuesAndExpressions::ProhibitLongChainsOfMethodCalls]
-#[ValuesAndExpressions::ProhibitMismatchedOperators]
+[ValuesAndExpressions::ProhibitMismatchedOperators]
 [ValuesAndExpressions::ProhibitMixedBooleanOperators]
 [ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters]
 [ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator]
@@ -257,11 +257,11 @@ terminal_funcs = POSIX::_exit
 [Variables::ProhibitConditionalDeclarations]
 # Variables::ProhibitEvilVariables is not listed: it declines to load until it
 # is given variables to prohibit, and nobody has named any.
-#[Variables::ProhibitLocalVars]
+[Variables::ProhibitLocalVars]
 [Variables::ProhibitMatchVars]
 # Drop this one at 5.041 and later, with RequireASCII above.
 [Variables::ProhibitPerl4PackageNames]
-#[Variables::ProhibitReusedNames]
+[Variables::ProhibitReusedNames]
 # Stricter than the core ProhibitUnusedVariables, which reports only a bare
 # `my $x;` and misses a variable that is assigned and never read.
 [Variables::ProhibitUnusedVarsStricter]

Makefile.PL

@@ -133,11 +133,9 @@ WriteMakefile(
         'WWW::SitemapIndex::XML'              => '0',
         'CSS::Minifier::XS'                   => '0',
         'JavaScript::Minifier::XS'            => '0',
-        'Digest::SHA'                         => '0',
         'Path::Tiny'                          => '0',
         'Log::Dispatch'                       => '0',
         'Log::Dispatch::FileRotate'           => '0',
-        'Digest::SHA'                         => '0',
         'URI'                                 => '0',
         'FindBin::libs'                       => '0',
         'Carp::Always'                        => '0',
@@ -148,11 +146,25 @@ WriteMakefile(
         'Log::Dispatch::DBI'                  => '0',
         'Log::Syslog::Fast'                   => '0',
         'Module::Runtime'                     => '0',
-        'Email::MIME'                         => '0',
-        'Email::Sender::Simple'               => '0',
         'Net::IP'                             => '0',
         'File::LibMagic'                      => '0',
         'Linux::Perl::inotify'                => '0',
     },
     test => { TESTS => 't/*.t' }
 );
+
+__END__
+
+=head1 NAME
+
+Makefile.PL - what tCMS needs installed
+
+=head1 DESCRIPTION
+
+PREREQ_PM lists what tCMS needs at run time.  The develop prerequisites list
+what the git hooks and .perlcriticrc need as well.
+
+    cpanm --installdeps .                  # to run tCMS
+    cpanm --installdeps --with-develop .   # to work on it
+
+=cut

bin/tcms-vault-key

@@ -81,7 +81,7 @@ if ( $help || !$file ) {
 
 # Printed and exited rather than died: Carp::Always is in the dependency chain,
 # and refusing to clobber a key is not a crash.
-if ( -e $Trog::Vault::key_file ) {    ## no critic (ProhibitFiletest_e) -- refusing to overwrite the one thing that cannot be regenerated
+if ( -e $Trog::Vault::key_file ) {    # Refusing to overwrite the one thing that cannot be regenerated
     print STDERR "There is already a key at $Trog::Vault::key_file.  Move it out of the way if you really mean to replace it, and read what that costs first: perldoc bin/tcms-vault-key\n";
     exit 2;
 }

lib/Trog/Auth.pm

@@ -531,16 +531,16 @@ sub process_change_request ($token) {
     my $secret       = $rows->[0]{secret};
     my $contactemail = $rows->[0]{contact_email};
 
-    state %dispatch = (
-        reset_pass => sub {
-            my ( $user, $pass ) = @_;
+    # my, not state: each closure reads this request's $display and $contactemail.
+    my %dispatch = (
+        reset_pass => sub ( $name, $pass ) {
 
             #XXX The fact that this is an INSERT OR REPLACE means all the entries in change_request for this user will get cascade wiped.  Which is good, as the secrets aren't salted.
             # This is also why we have to snag the user's ACLs or they will be wiped.
-            my @acls = acls4user($user);
-            useradd( $user, $display, $pass, \@acls, $contactemail );
-            killsession($user);
-            return "Password set to $pass for $user";
+            my @acls = acls4user($name);
+            useradd( $name, $display, $pass, \@acls, $contactemail );
+            killsession($name);
+            return "Password set to $pass for $name";
         },
     );
     my $res = $dispatch{$type}->( $user, $secret );

lib/Trog/Component.pm

@@ -77,7 +77,7 @@ my sub _component ( $name, $args ) {
     my $module = load($name);
 
     die "Component '$name' recursed more than $MAX_DEPTH deep\n" if $depth >= $MAX_DEPTH;
-    local $depth = $depth + 1;
+    local $Trog::Component::depth = $depth + 1;
 
     $args = {} unless ref $args eq 'HASH';
 

lib/Trog/Data.pm

@@ -4,6 +4,8 @@ use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';
 
+use Module::Runtime();
+
 use Trog::Log qw{:all};
 
 #It's just a factory
@@ -25,9 +27,7 @@ sub new ( $, $config ) {
     return $datamodule if $datamodule;
 
     my $module = "Trog::Data::" . model($config);
-    my $req    = $module;
-    $req =~ s/::/\//g;
-    require "$req.pm";
+    Module::Runtime::require_module($module);
     $datamodule = $module->new($config);
     return $datamodule;
 }

lib/Trog/Data/FlatFile.pm

@@ -41,7 +41,8 @@ my sub _index {
     opendir( my $dh, $datastore ) or confess;
     my @index = grep { -f } map { "$datastore/$_" } readdir $dh;    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
     closedir $dh;
-    return sort { $b cmp $a } @index;
+    my @sorted = sort { $b cmp $a } @index;
+    return @sorted;
 }
 
 sub read ( $self, $query = {} ) {

lib/Trog/DataModule.pm

@@ -453,7 +453,7 @@ my sub sidecar_generation {
 # explicitly undef form.
 my sub type_of ($form) {
     $form = '' if !defined $form || ref $form;
-    my ($type) = $form =~ m/^([A-Za-z0-9_-]+)\.tx$/;
+    my ($type) = $form =~ m/^([A-Za-z0-9_-]+)\.tx$/;    ## no critic (RegularExpressions::ProhibitRegexToStripAffix) -- the class is the check: anything else is no type
     return $type // '';
 }
 
@@ -463,26 +463,29 @@ our %relation_schema = ( type => 'string' );
 # string-or-hashref dance every upload field would otherwise need.  Uploads are
 # a hashref on the way in from the browser and the href string they became on
 # the way back out of the datastore.
-my sub expand_pseudo_types ($node) {
-    return unless Ref::Util::is_hashref($node);
-
+my sub expand_pseudo_types ($root) {
     my %pseudo = (
         upload   => \%upload_schema,
         relation => \%relation_schema,
     );
 
-    my $type = $node->{type} // '';
-    if ( $pseudo{$type} ) {
-        delete $node->{type};
-        %$node = ( %$node, %{ $pseudo{$type} } );
-        return;
-    }
+    my @todo = ($root);
+    for ( my $i = 0; $i < scalar(@todo); $i++ ) {
+        my $node = $todo[$i];
+        next unless Ref::Util::is_hashref($node);
+
+        my $type = $node->{type} // '';
+        if ( $pseudo{$type} ) {
+            delete $node->{type};
+            %$node = ( %$node, %{ $pseudo{$type} } );
+            next;
+        }
 
-    __SUB__->($_) foreach values( %{ $node->{properties} // {} } );
-    __SUB__->( $node->{items} ) if $node->{items};
-    foreach my $key (qw{oneOf anyOf allOf}) {
-        next unless Ref::Util::is_arrayref( $node->{$key} );
-        __SUB__->($_) foreach @{ $node->{$key} };
+        push( @todo, values( %{ $node->{properties} // {} } ) );
+        push( @todo, $node->{items} ) if $node->{items};
+        foreach my $key (qw{oneOf anyOf allOf}) {
+            push( @todo, @{ $node->{$key} } ) if Ref::Util::is_arrayref( $node->{$key} );
+        }
     }
     return;
 }

lib/Trog/DataSource.pm

@@ -164,7 +164,8 @@ the same created, so what this really does for that page is sort it by name.
 =cut
 
 sub order ( $, @posts ) {
-    return sort { ( $b->{created} // 0 ) <=> ( $a->{created} // 0 ) || ( $a->{title} // '' ) cmp ( $b->{title} // '' ) || ( $a->{id} // '' ) cmp ( $b->{id} // '' ) } @posts;
+    my @sorted = sort { ( $b->{created} // 0 ) <=> ( $a->{created} // 0 ) || ( $a->{title} // '' ) cmp ( $b->{title} // '' ) || ( $a->{id} // '' ) cmp ( $b->{id} // '' ) } @posts;
+    return @sorted;
 }
 
 =head2 lang() = STRING

lib/Trog/DataSource/DirIndex.pm

@@ -322,7 +322,8 @@ whatever happened to be touched least recently.
 =cut
 
 sub order ( $, @posts ) {
-    return sort { ( $b->{is_dir} // 0 ) <=> ( $a->{is_dir} // 0 ) || lc( $a->{name} // '' ) cmp lc( $b->{name} // '' ) || ( $a->{name} // '' ) cmp ( $b->{name} // '' ) } @posts;
+    my @sorted = sort { ( $b->{is_dir} // 0 ) <=> ( $a->{is_dir} // 0 ) || lc( $a->{name} // '' ) cmp lc( $b->{name} // '' ) || ( $a->{name} // '' ) cmp ( $b->{name} // '' ) } @posts;
+    return @sorted;
 }
 
 =head2 lang() = STRING

lib/Trog/DataSource/ProvisionedVirt.pm

@@ -335,7 +335,7 @@ route that called it.
 
 =cut
 
-our $log_max_bytes = 1024 * 1024;
+our $log_max_bytes = 1_048_576;    # 1 MiB
 
 sub log_for ($domain) {
     my $safe = safe_domain($domain);

lib/Trog/DataSource/Virt.pm

@@ -4,6 +4,7 @@ use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';
 
+use List::Util();
 use File::Path();
 use Sys::Hostname::FQDN();
 use Sys::Virt();
@@ -386,7 +387,7 @@ sub act ( $action, $conn_uri, $domain_name, $user ) {
     # actually stops it happening.  /guest/act is a POST anybody holding the
     # admin acl can craft by hand, and if it went through there would be
     # nothing left running to report the mistake.
-    if ( is_self($safe) && ( $action // '' ) =~ m/^(?:poweroff|destroy)$/ ) {
+    if ( is_self($safe) && List::Util::any { $_ eq ( $action // '' ) } qw{poweroff destroy} ) {
         WARN("Refused guest action '$action' on '$safe': that is this server");
         return ( 0, "'$safe' is this server -- refusing to $action it" );
     }

lib/Trog/Log.pm

@@ -80,13 +80,11 @@ Returns 1.
 =cut
 
 sub log_init {
-    my ( $LOGNAME, $LEVEL, $loggers ) = @_;
+    my ( $LOGNAME, $level, $loggers ) = @_;
 
-    die "Cannot initialize logs without log name and log level" unless $LOGNAME && $LEVEL;
-
-    $LOGNAME //= 'logs/tcms.log';
-    $LEVEL   //= 'info';
+    die "Cannot initialize logs without log name and log level" unless $LOGNAME && $level;
 
+    $LEVEL  = $level;
     $LOGDIR = dirname($LOGNAME);
 
     # By default only log requests & warnings.
@@ -96,7 +94,7 @@ sub log_init {
         filename  => $LOGNAME,
         min_level => $LEVEL,
         'mode'    => 'append',
-        size      => 10 * 1024 * 1024,
+        size      => 10_485_760,    # 10 MiB
         max       => 6,
     );
 

lib/Trog/Routes/HTML.pm

@@ -869,7 +869,7 @@ my sub get_data_models {
         my $dir = "$incdir/Trog/Data";
         next unless -d $dir;
         opendir( my $dh, $dir ) || die "Can't opendir $dir: $!";
-        my @dmods = map { s/\.pm$//g; $_ } grep { /\.pm$/ && -f "$dir/$_" } readdir($dh);    ## no critic (ProhibitFiletest_f) -- building a menu of module names
+        my @dmods = map { s/\.pm$//r } grep { /\.pm$/ && -f "$dir/$_" } readdir($dh);    ## no critic (ProhibitFiletest_f) -- building a menu of module names
         closedir $dh;
         return \@dmods;
     }
@@ -894,7 +894,7 @@ my %config_choices = (
 # is the only reason this does not just ask for the one key.  A key holding
 # commas comes back as an arrayref too, hence the join.
 my sub config_value ( $configured, $name ) {
-    return undef unless exists $configured->{$name};    ## no critic (ProhibitExplicitReturnUndef) -- 'never configured' has to be distinguishable from ''
+    return undef unless exists $configured->{$name};    # 'never configured' has to be distinguishable from ''
 
     my $value = $configured->{$name};
     return '' unless defined $value;
@@ -1746,11 +1746,11 @@ sub posts ( $query, $direct = 0 ) {
 
     #OK, so if we have a user as the ID we found, go grab the rest of their posts
     if ( $query->{id} && @posts && List::Util::any { $_ eq 'about' } @{ $posts[0]->{tags} } ) {
-        my $user = shift(@posts);
-        my $id   = delete $query->{id};
+        my $user       = shift(@posts);
+        my $profile_id = delete $query->{id};
         $query->{author} = $user->{user};
         @posts           = post_helper( $query, $tags, $query->{user_acls} );
-        @posts           = grep { $_->{id} ne $id } @posts;
+        @posts           = grep { $_->{id} ne $profile_id } @posts;
         unshift @posts, $user;
     }
 
@@ -1920,24 +1920,28 @@ Drop the fields a post type marks private, for a reader who isn't an editor.
 Done to the data on its way to the template rather than with a guard inside the
 template: a type can be rendered by more than one template, templates get
 edited by people who did not write the type, and a value that was never handed
-over cannot be printed by mistake.  Recurses, because a post's relations are
-posts too and carry their own private fields.
+over cannot be printed by mistake.  It walks into the post's relations too,
+because they are posts and carry their own private fields.
 
 =cut
 
 sub redact_private ( $post, $seen = {} ) {
-    return unless Ref::Util::is_hashref($post);
+    my @todo = ($post);
+    for ( my $i = 0; $i < scalar(@todo); $i++ ) {
+        my $node = $todo[$i];
+        next unless Ref::Util::is_hashref($node);
 
-    # Relations can point back at what pulled them in.
-    return if $seen->{$post}++;
+        # Relations can point back at what pulled them in.
+        next if $seen->{$node}++;
 
-    if ( $post->{form} ) {
-        delete $post->{$_} foreach @{ Trog::DataModule::private_fields_for( $post->{form} ) };
-    }
+        if ( $node->{form} ) {
+            delete $node->{$_} foreach @{ Trog::DataModule::private_fields_for( $node->{form} ) };
+        }
 
-    foreach my $value ( values(%$post) ) {
-        if    ( Ref::Util::is_hashref($value) )  { redact_private( $value, $seen ) }
-        elsif ( Ref::Util::is_arrayref($value) ) { redact_private( $_,     $seen ) foreach @$value }
+        foreach my $value ( values(%$node) ) {
+            if    ( Ref::Util::is_hashref($value) )  { push( @todo, $value ) }
+            elsif ( Ref::Util::is_arrayref($value) ) { push( @todo, @$value ) }
+        }
     }
     return;
 }
@@ -3494,7 +3498,7 @@ sub finish_render ( $template, $vars, %headers ) {
     # Theme-ize the paths
     $vars->{stylesheets}  = [ @{ build_themed_styles( $vars->{stylesheets} ) } ];
     $vars->{print_styles} = [ @{ build_themed_styles( $vars->{print_styles} ) } ];
-    $vars->{scripts}      = [ map { s/^www\///; $_ } @{ build_themed_scripts( $vars->{scripts} ) } ];
+    $vars->{scripts}      = [ map { s/^www\///r } @{ build_themed_scripts( $vars->{scripts} ) } ];
 
     # Add in avatars.css, it's special
     push( @{ $vars->{stylesheets} }, "/styles/avatars.css" );

lib/Trog/Routes/TXT.pm

@@ -1,16 +1,10 @@
-package Trog::Routes::JSON;
+package Trog::Routes::TXT;
 
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';
 
-use Trog::Config();
-
-my $conf = Trog::Config::get();
-
-# TODO de-duplicate this, it's shared in html
-my $theme_dir = '';
-$theme_dir = "themes/" . $conf->param('general.theme') if $conf->param('general.theme') && -d "www/themes/" . $conf->param('general.theme');
+use Trog::Renderer;
 
 our %routes = (
     '/text/zone' => {
@@ -41,10 +35,6 @@ This module is not wired up to anything.  TCMS.pm builds its routing table out
 of Trog::Routes::HTML and Trog::Routes::JSON only, so nothing here is reachable
 and /text/zone will 404.
 
-Worse, the package statement in this file says Trog::Routes::JSON rather than
-Trog::Routes::TXT, so loading it would quietly replace the JSON routing table
-with this one.  Fix that before wiring it in.
-
 =head1 VARIABLES
 
 =over 4

lib/Trog/Themes.pm

@@ -35,7 +35,7 @@ sub routes {
     # get_dir() is relative to the tCMS root, which require only searches from '.'.
     local @INC = ( '.', @INC );
     local $@;
-    eval { require "$rdir/routes.pm"; 1; } or do {
+    eval { require "$rdir/routes.pm"; 1; } or do {    ## no critic (Modules::RequireBarewordIncludes) -- a theme ships a file, not a module
         die "Could not load Theme routing package: $@";
     };
 

t/Trog-Auth-change-request.t

@@ -0,0 +1,39 @@
+#!/usr/bin/env perl
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use FindBin::libs;
+
+use Test::More;
+use Cwd();
+use File::Copy();
+use File::Path();
+use File::Temp();
+
+# Auth keeps its database at config/auth.db under the cwd, so it gets a sandbox.
+my $repo = Cwd::getcwd();
+my $root = File::Temp::tempdir( CLEANUP => 1 );
+File::Path::make_path( "$root/config", "$root/schema" );
+File::Copy::copy( "$repo/schema/auth.schema", "$root/schema/auth.schema" ) or die $!;
+chdir($root)                                                               or die "chdir $root: $!";
+END { chdir($repo) if $repo }
+
+require_ok('Trog::Auth') or BAIL_OUT("Can't find SUT");
+
+my $dbh = Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' );
+sub contact_of ($user) { return $dbh->selectrow_hashref( 'SELECT display_name, contact_email FROM user WHERE name = ?', undef, $user ) }
+
+subtest 'process_change_request: each reset keeps its own user' => sub {
+    Trog::Auth::useradd( qw{alice Alice old}, [], 'alice@test.test' );
+    Trog::Auth::useradd( qw{bob Bob old},     [], 'bob@test.test' );
+    Trog::Auth::add_change_request( user => $_, token => "t-$_", type => 'reset_pass', secret => 'new' ) for qw{alice bob};
+
+    like( Trog::Auth::process_change_request('t-alice'), qr/for[ ]alice/, 'the first reset is done' );
+    like( Trog::Auth::process_change_request('t-bob'),   qr/for[ ]bob/,   'and the second' );
+
+    is_deeply( contact_of('alice'), { display_name => 'Alice', contact_email => 'alice@test.test' }, 'the first user is as they were' );
+    is_deeply( contact_of('bob'),   { display_name => 'Bob',   contact_email => 'bob@test.test' },   'and the second keeps their own name and address, not the first one\'s' );
+};
+
+done_testing();

t/Trog-Auth-libravatar.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';
@@ -9,7 +10,7 @@ use FindBin::libs;
 
 # Stub modules absent from the test environment before loading Trog::Auth
 BEGIN {
-    # Logging stubs — Log::Dispatch family not installed in test env
+    # Logging stubs -- Log::Dispatch family not installed in test env
     $INC{'Log/Dispatch.pm'}            = 1;
     $INC{'Log/Dispatch/DBI.pm'}        = 1;
     $INC{'Log/Dispatch/Screen.pm'}     = 1;
@@ -26,7 +27,7 @@ BEGIN {
 
 require_ok('Trog::Auth') or BAIL_OUT("Can't load Trog::Auth");
 
-subtest 'users_with_emails — no rows returned' => sub {
+subtest 'users_with_emails -- no rows returned' => sub {
     my $sqlite_mock = Test::MockModule->new('Trog::SQLite');
     $sqlite_mock->redefine(
         'dbh',
@@ -42,7 +43,7 @@ subtest 'users_with_emails — no rows returned' => sub {
     is( scalar @$result, 0,       'empty arrayref when no rows' );
 };
 
-subtest 'users_with_emails — returns populated list' => sub {
+subtest 'users_with_emails -- returns populated list' => sub {
     my $fake_rows = [
         { name => 'alice', contact_email => 'alice@example.com' },
         { name => 'bob',   contact_email => 'bob@example.com' },

t/Trog-Component-page.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/Trog-Component.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';
@@ -88,7 +89,7 @@ subtest 'loading' => sub {
 };
 
 subtest 'render' => sub {
-    local @ARGS_SEEN = ();
+    local @main::ARGS_SEEN = ();
 
     my $out = Trog::Component::component('TestFixture');
     is( "$out", '<b>fixture</b>', "component output comes back" );

t/Trog-Config.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/Trog-Data-FlatFile-read.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/Trog-Data.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/Trog-DataModule-schema.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/Trog-DataSource-DirIndex.t

@@ -245,7 +245,8 @@ subtest 'it asks to be told when the directory changes' => sub {
     # stack another copy of the same callback on every single view.
     Trog::DataSource::DirIndex::posts( \%series, { tpsgi => $tpsgi } );
     Trog::DataSource::DirIndex::posts( \%series, { tpsgi => $tpsgi } );
-    is( scalar( keys %{ { map { $_->{key} => 1 } @watches } } ), 1, 'and it is the same key every time' );
+    my %keys = map { $_->{key} => 1 } @watches;
+    is( scalar( keys %keys ), 1, 'and it is the same key every time' );
 
     # The callback uses the tPSGI it is handed, not the one from the request
     # that registered it: watches are shared between workers, and whichever

t/Trog-DataSource-ProvisionedVirt.t

@@ -64,6 +64,10 @@ END {
     chdir($OLDCWD) if $OLDCWD;
 }
 
+# Trog::Config memoises, which is what a running server wants and a test
+# emphatically does not.
+my $config_mock;
+
 sub write_config {
     my (%section) = @_;
     open( my $fh, '>', "$ROOT/config/default.cfg" ) or die $!;
@@ -71,13 +75,11 @@ sub write_config {
     print {$fh} "    $_=$section{$_}\n" foreach sort keys %section;
     close $fh;
 
-    # Trog::Config memoises, which is what a running server wants and a test
-    # emphatically does not.
-    no warnings qw{once redefine};
     require Config::Simple;
     my $conf = Config::Simple->new("$ROOT/config/default.cfg");
     local $@;
-    *Trog::Config::get = sub { return $conf };
+    $config_mock //= Test::MockModule->new('Trog::Config');
+    $config_mock->redefine( get => sub { return $conf } );
     return;
 }
 
@@ -472,9 +474,9 @@ subtest 'the listing says what is going on' => sub {
     File::Path::make_path("$ROOT/logs/reprovision");
 
     my $status = "$ROOT/logs/reprovision/guest.example.com.status";
-    open( my $log, '>', "$ROOT/logs/reprovision/guest.example.com.log" ) or die $!;
-    print {$log} "some output\n";
-    close $log;
+    open( my $out, '>', "$ROOT/logs/reprovision/guest.example.com.log" ) or die $!;
+    print {$out} "some output\n";
+    close $out;
 
     $virt->redefine( posts => sub { return ( { title => 'guest.example.com', domain => 'guest.example.com', is_self => 0 } ) } );
 

t/Trog-DataSource-Virt.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/Trog-Log-DBI.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/Trog-Log-Syslog.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';
@@ -45,7 +46,7 @@ subtest 'each level keeps its severity' => sub {
     my %severity = ( info => 6, notice => 5, warning => 4, error => 3, critical => 2, alert => 1, emergency => 0 );
     foreach my $level ( sort keys %severity ) {
         $log->log( level => $level, message => "at $level" );
-        my $priority = 3 * 8 + $severity{$level};
+        my $priority = 24 + $severity{$level};    # the daemon facility, 3, times 8
         like( received(), qr/^<$priority>\N*:[ ]at[ ]$level$/, "$level is severity $severity{$level}" );
     }
 };

t/Trog-Log.t

@@ -0,0 +1,26 @@
+#!/usr/bin/env perl
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use Test::More;
+use Test::NoWarnings;
+use File::Temp qw{tempdir};
+
+use FindBin::libs;
+
+require_ok('Trog::Log') or BAIL_OUT("Can't find SUT");
+
+my $dir = tempdir( CLEANUP => 1 );
+
+subtest 'is_debug says which level log_init was given' => sub {
+    Trog::Log::log_init( "$dir/tcms.log", 'debug' );
+    ok( Trog::Log::is_debug(), 'debug is debug' );
+
+    Trog::Log::log_init( "$dir/tcms.log", 'info' );
+    ok( !Trog::Log::is_debug(), 'and info is not' );
+};
+
+Test::NoWarnings::had_no_warnings();
+
+done_testing();

t/Trog-Routes-HTML-config.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/Trog-Routes-HTML-series-lifecycle-sqlite.t

@@ -13,7 +13,7 @@ use re '/aasx';
 use warnings FATAL => 'all';
 
 use Test::More;
-use File::Temp ();
+use IPC::Run3();
 use FindBin;
 
 my $suite = "$FindBin::Bin/Trog-Routes-HTML-series-lifecycle.t";
@@ -21,18 +21,13 @@ ok( -f $suite, 'the lifecycle suite is there to run' ) or BAIL_OUT("Can't find $
 
 # Captured rather than inherited: the child speaks TAP too, and two test streams
 # down one pipe is not a test result, it is a parse error.
-my ( $fh, $log ) = File::Temp::tempfile( 'lifecycle-sqlite-XXXXXX', TMPDIR => 1, UNLINK => 1 );
-close $fh;
-
-my $rc = do {
+my $output = q{};
+my $rc     = do {
     local $ENV{TCMS_TEST_DATA_MODEL} = 'SQLite';
-    system(qq{$^X "-I$FindBin::Bin/../lib" "$suite" > "$log" 2>&1});
+    IPC::Run3::run3( [ $^X, "-I$FindBin::Bin/../lib", $suite ], \undef, \$output, \$output );
+    $?;
 };
 
-is( $rc, 0, 'the whole lifecycle passes on the SQLite data model' ) or do {
-    open( my $out, '<', $log ) or return;
-    diag($_) while ( $_ = <$out> );
-    close $out;
-};
+is( $rc, 0, 'the whole lifecycle passes on the SQLite data model' ) or diag($output);
 
 done_testing();

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

@@ -19,16 +19,17 @@ use FindBin;
 use FindBin::libs;
 
 use Test::More;
-use Cwd           ();
-use Encode        ();
-use File::Copy    ();
-use File::Find    ();
-use File::Path    ();
-use File::Temp    ();
-use Time::HiRes   ();
-use URI::Escape   ();
-use JSON::MaybeXS ();
-use File::Slurper ();
+use Cwd                 ();
+use Encode              ();
+use File::Copy          ();
+use File::Find          ();
+use File::Path          ();
+use File::Temp          ();
+use Time::HiRes         ();
+use URI::Escape         ();
+use JSON::MaybeXS       ();
+use File::Slurper       ();
+use File::Slurper::Temp ();
 
 our ( $REPO, $ROOT, $OLDCWD );
 our %REPO_BEFORE;
@@ -116,7 +117,7 @@ BEGIN {
     # finished when the app cannot tell which one it is talking to.
     my $stock = File::Slurper::read_text("$REPO/config/default.cfg");
     $stock =~ s/^(\s*data_model=)\N*$/$1$MODEL/m or die "could not set the data model in default.cfg";
-    File::Slurper::write_text( "$ROOT/config/default.cfg", $stock );
+    File::Slurper::Temp::write_text( "$ROOT/config/default.cfg", $stock );
 
     # Hardcoded paths in Auth.pm, TagIndex.pm, the data models and Log.pm -- not negotiable.
     File::Copy::copy( "$REPO/schema/$_", "$ROOT/schema/$_" ) or die $! for qw{auth.schema flatfile.schema sqlite.schema log.schema};
@@ -183,7 +184,7 @@ require Trog::Routes::JSON;
             restarts      => 0,
             tpsgi_dir     => Cwd::getcwd(),
             log_dir       => 'logs',
-            gid           => $),
+            gid           => "$)",
             verbose       => 0,
             %args,
         }, $class;
@@ -490,7 +491,7 @@ subtest 'the post wizard invents a new post type' => sub {
     # type opt out of collecting them, which is how a hypervisor post ended up
     # stored with no visibility and an undef in its tags.
     foreach my $required ( 'visibility.tx', 'acls.tx' ) {
-        like( $generated, qr/\Q: include "$required";\E/, "$required is included whether or not it was asked for" );
+        like( $generated, qr/:[ ]include[ ]"\Q$required\E";/, "$required is included whether or not it was asked for" );
     }
     like( $generated, qr/name="title"/, 'and so is the title input' );
 
@@ -1218,8 +1219,8 @@ subtest 'invoice' => sub {
         to            => '/specinvoice',
     );
 
-    my $sent  = time() - 10 * 86400;
-    my $child = do { local $NOW = $sent; save_post( 'invoice child', %invoice ) }
+    my $sent  = time() - 864_000;                                                         # ten days
+    my $child = do { local $main::NOW = $sent; save_post( 'invoice child', %invoice ) }
       or return;
     is( $child->{created}, $sent, 'the first save is stamped with the clock the test set' );
 
@@ -1240,7 +1241,7 @@ subtest 'invoice' => sub {
     like( $body, qr/Widget[ ]assembly/, 'line items rendered' );
     like( $body, qr/Total:[ ]\$500/,    'total summed from the line item prices' );
 
-    my $due = $child->{modified} + 30 * 86400;
+    my $due = $child->{modified} + 2_592_000;    # thirty days
     like( $body, qr{Due:[ ]<span[ ]class="unixtimestamp">\Q$due\E</span>}, 'due date counts from the latest edit, not the first save' );
 };
 

t/Trog-SQLite-TagIndex.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';
@@ -31,7 +32,7 @@ package Fake::Data {
 
 # One that gets as far as the index, then falls over before the routes.
 package Broken::Data {
-    our @ISA = ('Fake::Data');
+    use parent -norequire, 'Fake::Data';
     sub get { die "the data model fell over\n" }
 }
 

t/Trog-Themes-themed-templates.t

@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
 use 5.040;
 use re '/aasx';
 use warnings FATAL => 'all';

t/bin-migrate.t

@@ -14,6 +14,7 @@ use FindBin::libs;
 
 use Test::More;
 use Test::MockModule qw{strict};
+use IPC::Run3();
 
 our ( $REPO, $ROOT, $OLDCWD );
 
@@ -55,7 +56,8 @@ my $sqlite = Trog::Data::SQLite->new($config);
 # The script is the thing under test, so run it the way an operator would.
 sub migrate {
     my (@args) = @_;
-    my $out = qx{$^X "-I$REPO/lib" "$REPO/bin/migrate.pl" @args 2>&1};
+    my $out = q{};
+    IPC::Run3::run3( [ $^X, "-I$REPO/lib", "$REPO/bin/migrate.pl", @args ], \undef, \$out, \$out );
     return ( $?, $out );
 }