Merge pull request #376 from Troglodyne-Internet-Widgets/single-use-lexical-subs

Enable ProhibitSingleUseLexicalSubs, inlining the short subs used once

.perlcriticrc

@@ -84,7 +84,7 @@ formats = #!/usr/bin/env perl
 [BuiltinFunctions::ProhibitChainingSameListSub]
 [RegularExpressions::ProhibitRegexForStringEquality]
 [Subroutines::ProhibitUnderscorePrivateSubs]
-#[Subroutines::ProhibitSingleUseLexicalSubs]
+[Subroutines::ProhibitSingleUseLexicalSubs]
 [ValuesAndExpressions::ProhibitLiteralArithmetic]
 [BuiltinFunctions::ProhibitIndirectBooleanGrep]
 # What ProhibitMutatingListFunctions reports, which this replaces, and a block

bin/favicon_mongler.pl

@@ -50,7 +50,7 @@ extension.  The real container is assembled with Imager afterwards.
 # and 1.x errors out on -e rather than quietly accepting it.  Ask the binary
 # which era it belongs to instead of guessing -- this script has already been
 # flipped between the two by hand twice (e23b678, then back in 5f0cdca).
-my sub export_flag ($bin) {
+my sub export_flag ($bin) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 14 lines, which would overcomplicate the setup at file scope
 
     # Shelling out, on purpose and on the record.  system() cannot hand back
     # what the child printed, and reaching for a pipe open instead would only

bin/tcms-useradd

@@ -77,15 +77,6 @@ Display this output.
 
 =cut
 
-# The logger is set up per-request by the server; a CLI run has to do it itself,
-# or the first thing Trog::Auth logs blows up on an undefined $log.
-my sub init_logs {
-    my ($who) = @_;
-    Trog::Log::log_init( 'logs/tcms.log', 'info' );
-    $Trog::Log::user = $who // 'nobody';
-    return;
-}
-
 # Read a password off the terminal without echoing it, so it stays out of the
 # shell history and off the screen.  Falls back to a plain read when we aren't
 # on a TTY, which is what makes `echo hunter2 | tcms-useradd ...` work.  Returns
@@ -97,7 +88,7 @@ my sub read_password ($prompt) {
 
 # What a brand new user's profile post looks like before we merge anything over
 # the top of it.  Mirrors what setup() builds for the very first user.
-my sub default_user_post {
+my sub default_user_post {    ## no critic (ProhibitSingleUseLexicalSubs) -- 14 lines, which would overcomplicate main()
     return {
         data       => 'Default user',
         preview    => '/img/avatar/humm.gif',
@@ -154,7 +145,9 @@ sub main (@args) {
     $options{acl} = [ $options{acl} ] if $options{acl} && ref $options{acl} ne 'ARRAY';
     $options{acl} = ['admin'] unless @{ $options{acl} };
 
-    init_logs( $options{user} );
+    # Log to the file the server writes, as the user this run adds or edits.
+    Trog::Log::log_init( 'logs/tcms.log', 'info' );
+    $Trog::Log::user = $options{user} // 'nobody';
 
     # Find the user's existing post, if they have one.
     my $conf = Trog::Config::get();

bin/tcmslogin

@@ -66,20 +66,6 @@ Display this output.
 
 =cut
 
-# The logger is set up per-request by the server; a CLI run has to do it itself,
-# or the first thing Trog::Auth logs blows up on an undefined $log.
-my sub init_logs {
-    my ($who) = @_;
-    Trog::Log::log_init( 'logs/tcms.log', 'info' );
-    $Trog::Log::user = $who // 'nobody';
-    return;
-}
-
-my sub read_password ($prompt) {
-    my $password = IO::Prompter::prompt( $prompt, -echo => q{}, -in => *STDIN, -out => *STDERR );
-    return $password ? "$password" : undef;
-}
-
 sub main (@args) {
     my %options;
     Getopt::Long::GetOptionsFromArray(
@@ -97,11 +83,15 @@ sub main (@args) {
         return 2;
     }
 
-    init_logs( $options{user} );
+    # Log to the file the server writes, as the user who is logging in.
+    Trog::Log::log_init( 'logs/tcms.log', 'info' );
+    $Trog::Log::user = $options{user};
 
     # Omitted entirely or passed with no value both mean "ask me".
-    $options{password} = read_password("Password for '$options{user}': ")
-      unless $options{password};
+    if ( !$options{password} ) {
+        my $typed = IO::Prompter::prompt( "Password for '$options{user}': ", -echo => q{}, -in => *STDIN, -out => *STDERR );
+        $options{password} = $typed ? "$typed" : undef;
+    }
     unless ( $options{password} ) {
         print {*STDERR} "No password provided.\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
         return 2;

lib/TCMS.pm

@@ -120,7 +120,7 @@ sub build_routes {
         my $callback = delete $v->{callback};
 
         #XXX For now we will discard the tPSGI object.  We might want it later.
-        my $cb_wrap = sub {
+        my $cb_wrap = sub {    ## no critic (ProhibitSingleUseLexicalSubs) -- 71 lines, which would overcomplicate build_routes()
             my ( $tpsgi, $query ) = @_;
 
             confess "Cannot determine directory for logs!" unless $tpsgi->{log_dir};

lib/Trog/Component.pm

@@ -50,7 +50,7 @@ our $error;
 # Resolved at call time rather than compile time, so that components are free to
 # use Trog::Renderer without cycling back through us.  require() memoizes in
 # %INC; %loaded only saves us the repeat eval and string munging.
-my sub load ($name) {
+my sub load ($name) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 22 lines, which would overcomplicate _component()
     state %loaded;
 
     die "Component name must be given\n"   unless $name;
@@ -73,7 +73,7 @@ my sub load ($name) {
     return $module;
 }
 
-my sub _component ( $name, $args ) {
+my sub _component ( $name, $args ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 25 lines, which would overcomplicate component()
     my $module = load($name);
 
     die "Component '$name' recursed more than $MAX_DEPTH deep\n" if $depth >= $MAX_DEPTH;

lib/Trog/Data/SQLite.pm

@@ -80,18 +80,6 @@ my sub pinned ($query) {
     return defined $query->{version} && $query->{version} ne '';
 }
 
-# One version of one post per row, so "the current post" is a join against
-# post_versions, which the schema's triggers keep pointing at the newest row for
-# each uuid.  f is the oldest version, which is where dedup_versions() takes
-# the post's own birthday and original author from.
-my sub from_clause {
-    return q{
-        FROM posts p
-        JOIN post_versions v ON v.uuid = p.uuid
-        JOIN posts f ON f.id = v.first_id
-    };
-}
-
 # A post is only visible to a caller holding one of its tags, since visibility
 # and acls are both stored as tags.  admin skips it, as it does in filter().
 # False when the caller can see nothing at all, so there is nothing to query.
@@ -127,7 +115,7 @@ or two character search matches most of the site anyway.
 
 =cut
 
-my sub like_clause ($term) {
+my sub like_clause ($term) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 12 lines, which would overcomplicate where()
 
     if ( length($term) < 3 ) {
         my $escaped = $term;
@@ -142,7 +130,7 @@ my sub like_clause ($term) {
 
 # filter(), clause for clause.  Read the two side by side when changing either.
 # Returns nothing when no post can match, and then there is no query to run.
-my sub where ($query) {
+my sub where ($query) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 77 lines, which would overcomplicate build_query()
     my ( @where, @bind );
 
     # Which versions are in play.  Everything else filters within that.
@@ -220,16 +208,26 @@ my sub where ($query) {
     return ( \@where, \@bind );
 }
 
-my sub build_query ($query) {
+my sub build_query ($query) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 41 lines, which would overcomplicate read()
     my $select = q{SELECT p.post_data, p.uuid, p.version, v.version_max, v.first_created, f.author AS first_author};
 
     my ( $where, $bind ) = where($query) or return;
 
+    # One version of one post per row, so "the current post" is a join against
+    # post_versions, which the schema's triggers keep pointing at the newest
+    # row for each uuid.  f is the oldest version, which is where
+    # dedup_versions() takes the post's own birthday and original author from.
+    my $from = q{
+        FROM posts p
+        JOIN post_versions v ON v.uuid = p.uuid
+        JOIN posts f ON f.id = v.first_id
+    };
+
     # A raw read with no filters has no clauses at all, and "WHERE" on its own
     # is a syntax error rather than "everything".
     push( @$where, '1 = 1' ) unless @$where;
 
-    my $sql = "$select " . from_clause() . " WHERE " . join( ' AND ', @$where );
+    my $sql = "$select $from WHERE " . join( ' AND ', @$where );
 
     # Newest first, by the same date the caller gets back as created -- the
     # post's birthday.  The flat file model returned posts in readdir order,
@@ -299,7 +297,7 @@ sub read ( $, $query = {} ) {
     return \@posts;
 }
 
-my sub insert ( $dbh, $data ) {
+my sub insert ( $dbh, $data ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 21 lines, which would overcomplicate write()
     my $insert = $dbh->prepare('INSERT INTO posts (post_data) VALUES (?)');
 
     foreach my $post (@$data) {

lib/Trog/DataModule.pm

@@ -183,12 +183,6 @@ sub fixup ( $, @filtered ) {
     return @filtered;
 }
 
-my sub filter_param ( $query, $param, @filtered ) {
-    @filtered = grep { ( $_->{$param} || '' ) eq $query->{$param} } @filtered;
-    @filtered = dedup_versions( $query->{version}, @filtered );
-    return @filtered;
-}
-
 # Visibility and acls are both stored as tags, so a caller sees a post when it
 # holds one of them.  admin sees everything.
 my sub filter_acls ( $query, @filtered ) {
@@ -222,7 +216,7 @@ sub filter ( $, $query, @filtered ) {
     # if the caller may see it.
     foreach my $key (qw{id title aclname}) {
         next unless $query->{$key};
-        return filter_acls( $query, filter_param( $query, $key, @filtered ) );
+        return filter_acls( $query, dedup_versions( $query->{version}, grep { ( $_->{$key} || '' ) eq $query->{$key} } @filtered ) );
     }
 
     @filtered = dedup_versions( undef, @filtered );
@@ -464,7 +458,7 @@ 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 ($root) {
+my sub expand_pseudo_types ($root) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 26 lines, which would overcomplicate read_sidecar()
     my %pseudo = (
         upload   => \%upload_schema,
         relation => \%relation_schema,
@@ -580,7 +574,7 @@ sub include_schema_for ( $include = '' ) {
     return $cache{$generation}{$name};
 }
 
-my sub includes_of ($type) {
+my sub includes_of ($type) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 17 lines, which would overcomplicate includes_for()
     my $path     = Trog::Themes::themed_file_in_dir( 'forms', "$type.tx", 'text/html', 1 );
     my $template = $path ? eval { File::Slurper::read_text($path) } : undef;
 

lib/Trog/DataSource/DirIndex.pm

@@ -107,7 +107,7 @@ my sub within ( $path, $within ) {
 # Everything this is allowed to look at, or nothing.  Returns the absolute path
 # and the path relative to the tCMS root, since the first is what we read and
 # the second is what we log and watch.
-my sub resolve ($directory) {
+my sub resolve ($directory) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 46 lines, which would overcomplicate posts()
     return undef unless $directory;
 
     # Before abs_path, which would happily resolve one for us.
@@ -154,7 +154,7 @@ my sub resolve ($directory) {
     return { absolute => $absolute, relative => $relative ne q{} ? "$root/$relative" : $root };
 }
 
-my sub human_size ($bytes) {
+my sub human_size ($bytes) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 12 lines, which would overcomplicate post_for()
     return '' unless defined $bytes;
     return "$bytes B" if $bytes < 1024;
 
@@ -167,7 +167,7 @@ my sub human_size ($bytes) {
     return "$bytes B";
 }
 
-my sub post_for ( $name, $dir, $series ) {
+my sub post_for ( $name, $dir, $series ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 76 lines, which would overcomplicate posts()
     my $absolute = "$dir->{absolute}/$name";
 
     # Resolved, so a symlink pointing out of the tree is left out rather than

lib/Trog/DataSource/ProvisionedVirt.pm

@@ -104,7 +104,7 @@ my sub _recipe_path ( $config, $domain ) {
     return -f $path ? $path : undef;    ## no critic (ProhibitFiletest_f) -- is there a recipe for this guest
 }
 
-my sub with_recipe ( $post, $config ) {
+my sub with_recipe ( $post, $config ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 49 lines, which would overcomplicate posts()
     return $post if $post->{unreachable};
 
     my $domain = $post->{domain} // '';
@@ -353,22 +353,6 @@ sub log_for ($domain) {
       : $text;
 }
 
-# File away what they typed, so the next run is a code.
-#
-# Said rather than refused when it does not work: they asked for a reprovision
-# and gave us what it needs, and failing to keep a copy is not a reason to not do
-# the thing they asked for.
-my sub _remember ( $user, $credentials ) {
-    my %vault_name = ( keepass => $secret_name, sudo => $sudo_name );
-
-    foreach my $name ( sort keys %$credentials ) {
-        my ( $ok, $why ) = Trog::Vault::set( $user, $vault_name{$name}, $credentials->{$name} );
-        WARN("Could not remember the provisioner's $name for $user: $why") unless $ok;
-    }
-
-    return;
-}
-
 =head2 credentials(%args) = ($credentials, $why)
 
 What to hand the provisioner, out of whatever the form sent: a hashref of the
@@ -389,7 +373,7 @@ The reason, when there is one, is what the person reads -- so it has to tell
 
 =cut
 
-my sub credentials (%args) {
+my sub credentials (%args) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 58 lines, which would overcomplicate reprovision()
     my $user = $args{user} // '';
 
     my %credentials;
@@ -432,24 +416,22 @@ my sub credentials (%args) {
     my $sudo = $typed{sudo} // ( $user ? Trog::Vault::get( $user, $sudo_name ) : undef );
     $credentials{sudo} = $sudo if $sudo;
 
-    _remember( $user, \%typed ) if $args{remember} && $user && %typed;
+    # File away what they typed, so the next run is a code.
+    #
+    # Said rather than refused when it does not work: they asked for a
+    # reprovision and gave us what it needs, and failing to keep a copy is not a
+    # reason to not do the thing they asked for.
+    if ( $args{remember} && $user && %typed ) {
+        my %vault_name = ( keepass => $secret_name, sudo => $sudo_name );
+        foreach my $name ( sort keys %typed ) {
+            my ( $ok, $why ) = Trog::Vault::set( $user, $vault_name{$name}, $typed{$name} );
+            WARN("Could not remember the provisioner's $name for $user: $why") unless $ok;
+        }
+    }
 
     return ( \%credentials, '' );
 }
 
-# One 'name: value' per line is the format, so a value with a newline in it is
-# two lines -- and the second one could name a credential nobody asked us to
-# send.  Refused rather than escaped or trimmed: no password anybody meant to
-# type has a newline in the middle of it, and quietly changing what somebody
-# typed into their own password field is worse than saying no.
-my sub sendable ($credentials) {
-    foreach my $name ( sort keys %$credentials ) {
-        next unless $credentials->{$name} =~ m/[\r\n]/;
-        return "the $name has a line break in it, which is not something this can send";
-    }
-    return '';
-}
-
 =head2 reprovision(%args) = ($ok, $message)
 
 Run bin/provision for one guest, which generates its configuration from its
@@ -520,8 +502,14 @@ sub reprovision (%args) {
     my ( $credentials, $why ) = credentials(%args);
     return ( 0, $why ) unless $credentials;
 
-    my $unsendable = sendable($credentials);
-    return ( 0, $unsendable ) if $unsendable;
+    # One 'name: value' per line is the format, so a value with a newline in it
+    # is two lines -- and the second one could name a credential nobody asked us
+    # to send.  Refused rather than escaped or trimmed: no password anybody meant
+    # to type has a newline in the middle of it, and quietly changing what
+    # somebody typed into their own password field is worse than saying no.
+    foreach my $name ( sort keys %$credentials ) {
+        return ( 0, "the $name has a line break in it, which is not something this can send" ) if $credentials->{$name} =~ m/[\r\n]/;
+    }
 
     # One at a time.  Two provisions of one machine racing each other is not
     # something anybody should be able to start by double clicking.

lib/Trog/DataSource/Virt.pm

@@ -105,15 +105,11 @@ my @states = (
     'shutting down', 'shut off', 'crashed', 'suspended',
 );
 
-my sub state_name ($state) {
-    return $states[$state] // 'unknown';
-}
-
 # What this machine calls itself.  Not a state var so that a test can pretend
 # to be a different host without having to lie to Sys::Hostname.
 our $hostname;
 
-my sub hostname {
+my sub hostname {    ## no critic (ProhibitSingleUseLexicalSubs) -- 14 lines, which would overcomplicate is_self()
     return $hostname if defined $hostname;
 
     local $@;
@@ -281,7 +277,7 @@ sub post_for ( $domain, $hypervisor, $series, $form ) {
         data  => '',
 
         domain           => $name,
-        state            => state_name( $info->{state} ),
+        state            => $states[ $info->{state} ] // 'unknown',
         is_active        => $domain->is_active() ? 1 : 0,
         is_self          => is_self($name),
         memory           => $info->{memory},

lib/Trog/Renderer/css.pm

@@ -8,10 +8,6 @@ use parent qw{Trog::Renderer::Base};
 
 use CSS::Minifier::XS;
 
-my sub minify {
-    return CSS::Minifier::XS::minify(shift);
-}
-
 =head1 Trog::Renderer::css
 
 Render CSS, and minify the output.
@@ -19,7 +15,7 @@ Render CSS, and minify the output.
 =cut
 
 sub render (%options) {
-    $options{post_processor} = \&minify;
+    $options{post_processor} = \&CSS::Minifier::XS::minify;
     return Trog::Renderer::Base::render(%options);
 }
 

lib/Trog/Renderer/html.pm

@@ -35,7 +35,8 @@ sub render (%options) {
             },
         }
     );
-    state $child_renderer = sub {
+    $options{child_processor} = $child_processor;
+    $options{child_renderer}  = sub {
         my ( $template_string, $options ) = @_;
 
         # If it fails to render, it must be something else
@@ -43,9 +44,6 @@ sub render (%options) {
         return $out ? $out : $template_string;
     };
 
-    $options{child_processor} = $child_processor;
-    $options{child_renderer}  = $child_renderer;
-
     return Trog::Renderer::Base::render(%options);
 }
 

lib/Trog/Routes/HTML.pm

@@ -447,7 +447,7 @@ sub feedback_from_cookie ($cookies) {
     return ( int($failure), URI::Escape::uri_unescape($message) );
 }
 
-my sub build_social_meta ( $query, $title ) {
+my sub build_social_meta ( $query, $title ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 55 lines, which would overcomplicate index()
     return ( undef, undef, undef ) unless $query->{social_meta} && $query->{route} && $query->{domain};
 
     my $default_tags = $Theme::default_tags;
@@ -503,7 +503,7 @@ my sub build_social_meta ( $query, $title ) {
     return ( $default_tags, $meta_desc, $meta_tags );
 }
 
-my sub get_series ( $edit = 0 ) {
+my sub get_series ( $edit = 0 ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 13 lines, which would overcomplicate index()
     state $data;
     $data //= Trog::Data->new( Trog::Config::get() );
 
@@ -659,7 +659,7 @@ sub totp ($query) {
     );
 }
 
-my sub setup_initial_db ( $dat, $user, $display_name, $contact_email ) {
+my sub setup_initial_db ( $dat, $user, $display_name, $contact_email ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 72 lines, which would overcomplicate login()
     $dat->add(
         {
             "aclname"    => "series",
@@ -861,41 +861,21 @@ sub config ( $query = {} ) {
     );
 }
 
-my sub get_data_models {
-    foreach my $incdir (@INC) {
-        my $dir = "$incdir/Trog/Data";
-        next unless -d $dir;
-        return [ map { $_->basename('.pm') } grep { -f } Path::Tiny::path($dir)->children(qr/[.]pm\z/) ];    ## no critic (ProhibitFiletest_f) -- building a menu of module names
-    }
-    die "Could not find tCMS data modules!  Is tCMS in \@INC?";
-}
-
 # The settings which are a choice among what this instance actually has
 # installed rather than free text.  default.cfg can say a key exists, but not
 # that it has to be one of the themes on disk, so that part lives here.
 my %config_choices = (
     'general.theme'      => sub { return [ '', @{ get_themes() || [] } ] },
-    'general.data_model' => \&get_data_models,
+    'general.data_model' => sub {
+        foreach my $incdir (@INC) {
+            my $dir = "$incdir/Trog/Data";
+            next unless -d $dir;
+            return [ map { $_->basename('.pm') } grep { -f } Path::Tiny::path($dir)->children(qr/[.]pm\z/) ];    ## no critic (ProhibitFiletest_f) -- building a menu of module names
+        }
+        die "Could not find tCMS data modules!  Is tCMS in \@INC?";
+    },
 );
 
-# What this instance has configured a setting as, or undef if it never has --
-# which is not the same thing as having set it to nothing, or the editor would
-# hand back the shipped default to anyone who deliberately cleared a setting,
-# and quietly restore it on the next save.
-#
-# XXX ACHTUNG config::simple's param() answers a key which does not exist with a
-# multi element array, so it can never tell you those two apart; vars() can, and
-# 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};    # 'never configured' has to be distinguishable from ''
-
-    my $value = $configured->{$name};
-    return '' unless defined $value;
-    return join( ', ', @$value ) if ref $value eq 'ARRAY';
-    return ref $value ? '' : $value;
-}
-
 my sub config_title ($name) {
     $name =~ s/[_-]/ /g;
     return join( ' ', map { ucfirst } split( ' ', $name ) );
@@ -922,8 +902,18 @@ sub config_sections {
     foreach my $section ( @{ Trog::Config::schema() } ) {
         my @fields;
         foreach my $field ( @{ $section->{fields} } ) {
-            my $value = config_value( \%configured, $field->{name} );
-            $value = $field->{default} unless defined $value;
+
+            # A setting never configured takes the default, but one set to nothing
+            # stays empty, or the editor would quietly restore the default to
+            # anyone who cleared it.  XXX ACHTUNG config::simple's param() answers
+            # a key which does not exist with a multi element array, so vars() is
+            # what tells the two apart.  A key holding commas is an arrayref too.
+            my $name = $field->{name};
+            my $value =
+               !exists $configured{$name}         ? $field->{default}
+              : ref $configured{$name} eq 'ARRAY' ? join( ', ', @{ $configured{$name} } )
+              : ref $configured{$name}            ? ''
+              :                                     $configured{$name} // '';
 
             my %rendered = (
                 %$field,
@@ -1370,7 +1360,7 @@ sub post_delete ($query) {
 # Anything a type needs computed rather than merely fetched.  The sub is named
 # in the sidecar, so validate it the same way a post's own callback field is --
 # a sidecar naming an arbitrary sub is a privilege question, not a typo.
-my sub enrich_callback ( $post, $query ) {
+my sub enrich_callback ( $post, $query ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 33 lines, which would overcomplicate enrich_post()
     my $meta = Trog::DataModule::type_meta_for( $post->{form} );
     my $sub  = $meta->{'x-tcms-post-type'}{enrich};
     return if !$sub || ref $sub;
@@ -1614,11 +1604,6 @@ sub users ($query) {
     return posts($query);
 }
 
-my sub themed_title ($path) {
-    return $path unless %Theme::paths;
-    return $Theme::paths{$path} ? $Theme::paths{$path} : $path;
-}
-
 my sub post2rss ( $rss, $url, $post ) {
     $rss->add_item(
         title       => $post->{title},
@@ -1632,7 +1617,7 @@ my sub post2rss ( $rss, $url, $post ) {
     return 1;
 }
 
-my sub _rss ( $query, $subtitle, $posts ) {
+my sub _rss ( $query, $subtitle, $posts ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 49 lines, which would overcomplicate posts()
 
     require XML::RSS;
     my $rss  = XML::RSS->new( version => '2.0', stylesheet => '/styles/rss-style.xsl' );
@@ -1757,7 +1742,7 @@ sub posts ( $query, $direct = 0 ) {
     $query->{etag} = "$posts[0]{id}-$posts[0]{version}" if @posts;
 
     #Correct page headers
-    my $ph = $themed ? themed_title( $query->{route} ) : $query->{route};
+    my $ph = ( $themed && $Theme::paths{ $query->{route} } ) || $query->{route};
 
     return _rss( $query, $ph, \@posts ) if $fmt eq 'rss';
 
@@ -2712,7 +2697,7 @@ point, works, and is only missing an optimization.
 
 =cut
 
-my sub wizard_reindex ( $name, $fields ) {
+my sub wizard_reindex ( $name, $fields ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 22 lines, which would overcomplicate post_wizard_save()
     my %indexed = map { $_->{name} => 1 } grep { $_->{indexed} } @$fields;
 
     my $this_type = "$name.tx";
@@ -2747,7 +2732,7 @@ my sub wizard_fail ( $query, $message ) {
     );
 }
 
-my sub wizard_field_html ($field) {
+my sub wizard_field_html ($field) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 23 lines, which would overcomplicate wizard_template()
     my ( $n, $t, $l, $p ) = @$field{qw{name type label placeholder}};
     my $required = $field->{required} ? 'required ' : '';
 
@@ -2778,7 +2763,7 @@ a display half guarded by !$post.addpost, and an edit half guarded by $can_edit.
 
 =cut
 
-my sub wizard_template ( $query, $fields, $includes, $body_form, $datasource = '' ) {
+my sub wizard_template ( $query, $fields, $includes, $body_form, $datasource = '' ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 54 lines, which would overcomplicate post_wizard_save()
     my $placeholder = kolon_safe( $query->{title_placeholder} ) || 'Iowa Man Destroys Moon';
 
     # NOT escaped, on purpose.  Letting an admin write template code is the
@@ -2962,16 +2947,6 @@ sub short_error ( $error = '' ) {
     return $error;
 }
 
-# Which body form a type carries, which is an include like any other -- see the
-# bottom of wizard_template.  The sidecar is the fallback for a type whose
-# template says nothing, which is what a datasource type with no editor at all
-# looks like.
-my sub wizard_body_form_of ( $includes, $type ) {
-    return 'form_multi.tx'  if $includes->{'form_multi.tx'};
-    return 'form_common.tx' if $includes->{'form_common.tx'};
-    return $type->{body_form} // 'form_common.tx';
-}
-
 # What a type's template says about the parts of it the wizard emits itself
 # rather than through %wizard_includes: the wrapper div, and the two canned
 # blocks which go in the display half rather than in the editor.
@@ -2980,7 +2955,7 @@ my sub wizard_body_form_of ( $includes, $type ) {
 # sidecar as the fallback rather than making it a second opinion.  The template
 # is what actually renders, so where the two disagree it is the template which
 # is telling the truth.
-my sub wizard_display_of ($form) {
+my sub wizard_display_of ($form) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 26 lines, which would overcomplicate wizard_types()
     my $path = Trog::Themes::themed_file_in_dir( 'forms', $form, 'text/html', 1 );
     return undef unless $path;
 
@@ -3008,7 +2983,7 @@ my sub wizard_display_of ($form) {
 }
 
 # The custom fields of a type, as rows the wizard would have submitted.
-my sub wizard_fields_of ( $schema, $meta, $includes = {} ) {
+my sub wizard_fields_of ( $schema, $meta, $includes = {} ) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 72 lines, which would overcomplicate wizard_types()
     my $properties = $schema->{properties} // {};
     my %required   = map { $_ => 1 } @{ $schema->{required} // [] };
     my $relations  = $meta->{'x-tcms-relations'};
@@ -3093,7 +3068,7 @@ there is no wizard form that produces one.
 
 =cut
 
-my sub wizard_display_from_template ($form) {
+my sub wizard_display_from_template ($form) {    ## no critic (ProhibitSingleUseLexicalSubs) -- 33 lines, which would overcomplicate wizard_types()
     my $path = Trog::Themes::themed_file_in_dir( 'forms', $form, 'text/html', 1 );
     return '' unless $path;
 
@@ -3175,10 +3150,13 @@ sub wizard_types ($forms) {
         my $shown = wizard_display_of($form) // { map { $_ => $type->{$_} ? 1 : 0 } @wizard_display_checkboxes };
 
         $types{$form} = {
-            name              => ( $form =~ s/\.tx$//r ),
-            description       => $type->{description} // '',
-            display           => $display             // '',
-            body_form         => wizard_body_form_of( \%includes, $type ),
+            name        => ( $form =~ s/\.tx$//r ),
+            description => $type->{description} // '',
+            display     => $display             // '',
+
+            # An include like any other -- see the bottom of wizard_template.  The
+            # sidecar is the fallback, for a datasource type with no editor at all.
+            body_form         => ( List::Util::first { $includes{$_} } qw{form_multi.tx form_common.tx} ) // $type->{body_form} // 'form_common.tx',
             datasource        => $meta->{'x-tcms-datasource'} // '',
             title_placeholder => $type->{title_placeholder}   // '',
             generated         => $type->{generated} ? 1 : 0,
@@ -3460,11 +3438,6 @@ sub rss_style ($query) {
     );
 }
 
-my sub build_themed_scripts ($scripts) {
-    my @scripts = map { Trog::Themes::themed_script("$_") } @{ Trog::Utils::coerce_array($scripts) };
-    return \@scripts;
-}
-
 =head2 finish_render($template, $vars, %headers)
 
 Render a full page, as opposed to a component.
@@ -3493,7 +3466,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\///r } @{ build_themed_scripts( $vars->{scripts} ) } ];
+    $vars->{scripts}      = [ map { Trog::Themes::themed_script("$_") =~ s/^www\///r } @{ Trog::Utils::coerce_array( $vars->{scripts} ) } ];
 
     # Add in avatars.css, it's special
     push( @{ $vars->{stylesheets} }, "/styles/avatars.css" );

lib/Trog/Themes.pm

@@ -195,14 +195,6 @@ sub forms_dir {
     return dir_for( 'forms', 'text/html', 1 );
 }
 
-my sub read_dir ( $dir, $ext ) {
-    return [] unless -d $dir;
-    my @files = eval {
-        grep { -f } Path::Tiny::path($dir)->children(qr/[.]\Q$ext\E\z/);    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
-    };
-    return [ map { $_->basename } @files ];
-}
-
 =head2 themed_templates_in_dir($path, $content_type, $is_component)
 
 The template names in an abstract template dir, from the theme and the stock
@@ -220,7 +212,11 @@ sub themed_templates_in_dir ( $path, $ct, $is_component = 0 ) {
 
     my ( @templates, %seen );
     foreach my $dir (@dirs) {
-        foreach my $template ( @{ read_dir( $dir, 'tx' ) } ) {
+        next unless -d $dir;
+        my @files = eval {
+            grep { -f } Path::Tiny::path($dir)->children(qr/[.]tx\z/);    ## no critic (ProhibitFiletest_f) -- listing names, nothing is opened
+        };
+        foreach my $template ( map { $_->basename } @files ) {
 
             # First one wins, and the theme's dir comes first.
             push( @templates, $template ) unless $seen{$template}++;

lib/Trog/Vault.pm

@@ -121,19 +121,16 @@ my sub decode ( $raw, $whence ) {
     return $key;
 }
 
-my sub from_env {
+our $master = do {
     my $raw = delete $ENV{TPSGI_VAULT_KEY};
-    return undef unless $raw;
-    return decode( $raw, 'TPSGI_VAULT_KEY' );
-}
-
-our $master         = from_env();
+    $raw ? decode( $raw, 'TPSGI_VAULT_KEY' ) : undef;
+};
 our $looked_further = 0;
 
 # The two places worth looking that are not the environment.  Deferred rather
 # than done at load, since both are files and this module is loaded by things
 # which have no interest in a vault.
-my sub look_further {
+my sub look_further {    ## no critic (ProhibitSingleUseLexicalSubs) -- 21 lines, which would overcomplicate key()
     $looked_further = 1;
 
     my $dir = $ENV{CREDENTIALS_DIRECTORY};
@@ -195,13 +192,6 @@ my sub derive ($salt) {
     return ( substr( $material, 0, 32 ), substr( $material, 32, 12 ) );
 }
 
-# A name is a label in a form and a key in a table, and it is half of what binds
-# a row to its owner, so it is a short plain thing or it is nothing.
-my sub safe_name ($name) {
-    return 0 if !$name || length $name > 64;
-    return $name =~ m/^[[:alnum:]][\w.-]*$/ ? 1 : 0;
-}
-
 # The same database the users are in, since a secret belongs to one.
 my sub dbh { return Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' ) }
 
@@ -213,8 +203,11 @@ Remember one thing for one user, replacing whatever was there under that name.
 
 sub set ( $user, $name, $secret ) {
     return ( 0, 'this installation has no vault key, so there is nowhere to keep it' ) unless has_key();
-    return ( 0, 'a secret needs a name' )                                              unless safe_name($name);
-    return ( 0, 'nothing to store' ) if ( $secret // q{} ) eq q{};
+
+    # A name is a label in a form and a key in a table, and it is half of what
+    # binds a row to its owner, so it is a short plain thing or it is nothing.
+    return ( 0, 'a secret needs a name' ) if !$name || length $name > 64 || $name !~ m/^[[:alnum:]][\w.-]*$/;
+    return ( 0, 'nothing to store' )      if ( $secret // q{} ) eq q{};
 
     my $salt = Crypt::PRNG::random_bytes(32);
     my ( $key, $iv ) = derive($salt);

t/Trog-DataSource-ProvisionedVirt-spawn.t

@@ -45,9 +45,12 @@ my sub provisioner ( $name, $body ) {
     return $program;
 }
 
-# What the run says once it has stopped, or undef if it has not stopped within
-# ten seconds.
-my sub finished ($domain) {
+my sub run ( $domain, $program, $credentials ) {
+    my ( $ok, $why ) = Trog::DataSource::ProvisionedVirt::spawn( $domain, $credentials, $ROOT, [ $program, $domain ], 'admin' );
+    ok( $ok, "a run for $domain starts" ) or diag($why);
+
+    # What the run says once it has stopped, or undef if it has not stopped
+    # within ten seconds.
     foreach ( 1 .. 100 ) {
         my $status = Trog::DataSource::ProvisionedVirt::status($domain);
         return $status if $status && $status->{state} ne 'running';
@@ -56,12 +59,6 @@ my sub finished ($domain) {
     return;
 }
 
-my sub run ( $domain, $program, $credentials ) {
-    my ( $ok, $why ) = Trog::DataSource::ProvisionedVirt::spawn( $domain, $credentials, $ROOT, [ $program, $domain ], 'admin' );
-    ok( $ok, "a run for $domain starts" ) or diag($why);
-    return finished($domain);
-}
-
 # Starman, under which tPSGI runs, ignores SIGPIPE, and its children inherit
 # that.  So a write to a provisioner that has gone fails rather than kills.
 local $SIG{PIPE} = 'IGNORE';

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

@@ -70,7 +70,7 @@ state sub snapshot {
     return %seen;
 }
 
-state sub copy_tree {
+state sub copy_tree {    ## no critic (ProhibitSingleUseLexicalSubs) -- 18 lines, which would overcomplicate the BEGIN block
     my ( $from, $to ) = @_;
     File::Path::make_path($to);
     File::Find::find(
@@ -330,23 +330,6 @@ my sub topbar_titles {
     return $span =~ m{class="topbar">([^<]*)</a>}g;
 }
 
-# post_title.tx emits exactly one of these per displayed post.
-my sub post_count ($body) {
-    my $n = () = $body =~ m{<h3[ ]class='blogtitles'>}g;
-    return $n;
-}
-
-# The rendered page is ~40KB and mostly JavaScript.  Show the content well.
-my sub kontent {
-    my ($body) = @_;
-    state $from = qr{<div[ ]id="kontent"[ ]class="kontained">};
-    state $to   = qr{<div[ ]id="rightbar"};
-    my ($k) = $body =~ m{$from(.*?)$to}s;
-    $k //= $body;
-    $k =~ s/<script\b.*?<\/script>//gs;
-    return length($k) > 2500 ? substr( $k, 0, 2500 ) . "\n...[truncated]" : $k;
-}
-
 # Save through post_save() rather than $data->add(): add() dies with an
 # arrayref of validator errors, whereas post_save catches them and hands back a
 # 400 with the field-level detail in the body -- which is the single most
@@ -1046,8 +1029,19 @@ my sub series_page {
     is( $code, 200, "$label: series page renders" ) or do { diag($err); return '' };
 
     like( $body, qr{<title>[^<]*\Q$series_title\E}, "$label: series page is the right series" );
-    is( post_count($body), $expected_posts, "$label: exactly $expected_posts post(s) listed" )
-      or diag( kontent($body) );
+
+    # post_title.tx emits exactly one of these per displayed post.
+    my $listed = () = $body =~ m{<h3[ ]class='blogtitles'>}g;
+    if ( !is( $listed, $expected_posts, "$label: exactly $expected_posts post(s) listed" ) ) {
+
+        # The rendered page is ~40KB and mostly JavaScript.  Show the content well.
+        my $from = qr{<div[ ]id="kontent"[ ]class="kontained">};
+        my $to   = qr{<div[ ]id="rightbar"};
+        my ($k)  = $body =~ m{$from(.*?)$to}s;
+        $k //= $body;
+        $k =~ s/<script\b.*?<\/script>//gs;
+        diag( length($k) > 2500 ? substr( $k, 0, 2500 ) . "\n...[truncated]" : $k );
+    }
 
     return $body;
 }