Enable ProhibitSingleUseLexicalSubs, inlining the short subs used once

A lexical sub with one caller sends the reader away from the caller and
back.  The 21 of ten lines or fewer now read where they are used.  Two
of them were the same init_logs in tcms-useradd and tcmslogin, whose
comment said that a CLI run dies without it; Trog::Log falls back to
stderr before log_init, so the comment at each call now says only what
the two lines do.

The vault key from the environment is read in a do block rather than
inline, so the raw key does not outlive the read in a file lexical.  The
HTML renderer builds its child renderer per call rather than once in a
state variable; the processor it closes over is still built once.

The other 30 run from 12 to 77 lines, and inlining them would bury the
sub that calls each one, so each says so in a no critic.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>

.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 bury 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 bury 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 bury 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 bury _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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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 bury 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;
 }