Răsfoiți Sursa

Tidy everything that was not

Twenty-one files, all of which predate this branch in their untidiness --
Makefile.PL was indented two spaces throughout while .perltidyrc asks for
four, and the test suite had never been run through it at all.  Note the
pre-commit hook only tidies files matching .p[m|l]$, case sensitively, which
is why Makefile.PL and the bin/ scripts without extensions had drifted.

Formatting only.  Every file is byte-identical to its predecessor once
whitespace is stripped, with one exception: perltidy dropped a stray
semicolon after Trog::Themes::get_dir's closing brace, which was a redundant
empty statement and a no-op either way.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01CJ2NAMQyytncwHKSmD5dFe
George Baugh 2 luni în urmă
părinte
comite
1ca59697f2

+ 79 - 79
Makefile.PL

@@ -4,85 +4,85 @@ use warnings;
 use ExtUtils::MakeMaker;
 
 WriteMakefile(
-  VERSION   => '0.01',
+    VERSION => '0.01',
 
-  # Every module and script declares 'use v5.36' -- signatures without the
-  # experimental warning is what we build on.
-  MIN_PERL_VERSION => '5.036000',
-  META_MERGE        => {
-    "meta-spec" => { version => 2 },
-    resources => {
-      repository => {
-          type => 'git',
-          url  => 'git@github.com:Troglodyne-Internet-Widgets/tCMS.git',
-          web  => 'https://github.com/Troglodyne-Internet-Widgets/tCMS',
-      },
+    # Every module and script declares 'use v5.36' -- signatures without the
+    # experimental warning is what we build on.
+    MIN_PERL_VERSION => '5.036000',
+    META_MERGE       => {
+        "meta-spec" => { version => 2 },
+        resources   => {
+            repository => {
+                type => 'git',
+                url  => 'git@github.com:Troglodyne-Internet-Widgets/tCMS.git',
+                web  => 'https://github.com/Troglodyne-Internet-Widgets/tCMS',
+            },
+        },
     },
-  },
-  PREREQ_PM => {
-    'Trog::TOTP'           => '0',
-    'CGI::Cookie'            => '0',
-    'Capture::Tiny'          => '0',
-    'Carp'                   => '0',
-    'Config::Simple'         => '0',
-    'DBD::SQLite'            => '0',
-    'DBI'                    => '0',
-    'Date::Format'           => '0',
-    'DateTime::Format::HTTP' => '0',
-    'Digest::SHA'            => '0',
-    'Errno'                  => '0',
-    'File::Basename'         => '0',
-    'File::Copy'             => '0',
-    'File::Slurper'          => '0',
-    'File::Slurper::Temp'    => '0',
-    'File::Touch'            => '0',
-    'File::Path'             => '0',
-    'File::Which'            => '0',
-    'File::Temp'             => '0',
-    'HTML::SocialMeta'       => '0',
-    'HTTP::Body'             => '0',
-    'IO::String'             => '0',
-    'IO::Compress::Gzip'     => '0',
-    'Imager'                 => '0',
-    'Imager::File::ICO'      => '0',
-    'Imager::File::PNG'      => '0',
-    'Imager::QRCode'         => '0',
-    'JSON::MaybeXS'          => '0',
-    'JSON::Validator::Schema::Troglodyne' => '0',
-    'Sys::Virt'              => '0',
-    'Sys::Hostname::FQDN'    => '0',
-    'List::Util'             => '0',
-    'Mojo::File'             => '0',
-    'POSIX'                  => '0',
-    'Ref::Util'              => '0',
-    'Pod::Html'              => '0',
-    'Starman'                => '0',
-    'Text::Xslate'           => '0',
-    'URL::Encode'            => '0',
-    'UUID'                   => '0',
-    'WWW::Sitemap::XML'      => '0',
-    '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',
-    'MIME::Base32::XS'          => '0',
-    'URI'                       => '0',
-    'FindBin::libs'             => '0',
-    'Carp::Always'              => '0',
-    'HTTP::Tiny::UNIX'          => '0',
-    'Email::MIME'               => '0',
-    'Email::Sender::Simple'     => '0',
-    'POSIX::strptime'           => '0',
-    'Log::Dispatch::DBI'        => '0',
-    'Email::MIME'               => '0',
-    'Email::Sender::Simple'     => '0',
-    'Net::IP'                   => '0',
-    'File::LibMagic'            => '0',
-    'Linux::Perl::inotify'      => '0',
-  },
-  test => {TESTS => 't/*.t'}
+    PREREQ_PM => {
+        'Trog::TOTP'                          => '0',
+        'CGI::Cookie'                         => '0',
+        'Capture::Tiny'                       => '0',
+        'Carp'                                => '0',
+        'Config::Simple'                      => '0',
+        'DBD::SQLite'                         => '0',
+        'DBI'                                 => '0',
+        'Date::Format'                        => '0',
+        'DateTime::Format::HTTP'              => '0',
+        'Digest::SHA'                         => '0',
+        'Errno'                               => '0',
+        'File::Basename'                      => '0',
+        'File::Copy'                          => '0',
+        'File::Slurper'                       => '0',
+        'File::Slurper::Temp'                 => '0',
+        'File::Touch'                         => '0',
+        'File::Path'                          => '0',
+        'File::Which'                         => '0',
+        'File::Temp'                          => '0',
+        'HTML::SocialMeta'                    => '0',
+        'HTTP::Body'                          => '0',
+        'IO::String'                          => '0',
+        'IO::Compress::Gzip'                  => '0',
+        'Imager'                              => '0',
+        'Imager::File::ICO'                   => '0',
+        'Imager::File::PNG'                   => '0',
+        'Imager::QRCode'                      => '0',
+        'JSON::MaybeXS'                       => '0',
+        'JSON::Validator::Schema::Troglodyne' => '0',
+        'Sys::Virt'                           => '0',
+        'Sys::Hostname::FQDN'                 => '0',
+        'List::Util'                          => '0',
+        'Mojo::File'                          => '0',
+        'POSIX'                               => '0',
+        'Ref::Util'                           => '0',
+        'Pod::Html'                           => '0',
+        'Starman'                             => '0',
+        'Text::Xslate'                        => '0',
+        'URL::Encode'                         => '0',
+        'UUID'                                => '0',
+        'WWW::Sitemap::XML'                   => '0',
+        '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',
+        'MIME::Base32::XS'                    => '0',
+        'URI'                                 => '0',
+        'FindBin::libs'                       => '0',
+        'Carp::Always'                        => '0',
+        'HTTP::Tiny::UNIX'                    => '0',
+        'Email::MIME'                         => '0',
+        'Email::Sender::Simple'               => '0',
+        'POSIX::strptime'                     => '0',
+        'Log::Dispatch::DBI'                  => '0',
+        'Email::MIME'                         => '0',
+        'Email::Sender::Simple'               => '0',
+        'Net::IP'                             => '0',
+        'File::LibMagic'                      => '0',
+        'Linux::Perl::inotify'                => '0',
+    },
+    test => { TESTS => 't/*.t' }
 );

+ 4 - 3
bin/tcms-hostname

@@ -45,7 +45,8 @@ Dies if asked to print a hostname which was never set.
 =cut
 
 my $user;
-GetOptionsFromArray(\@ARGV,
+GetOptionsFromArray(
+    \@ARGV,
     'user' => \$user,
 );
 
@@ -53,7 +54,7 @@ my $hostname = $ARGV[0];
 
 my $conf = Trog::Config->get();
 if ($hostname) {
-    $conf->param('general.hostname', $hostname);
+    $conf->param( 'general.hostname', $hostname );
 
     # write(), not save().  save() writes back to whatever file get() loaded,
     # which is the tracked config/default.cfg until the instance has saved a
@@ -66,7 +67,7 @@ die "Hostname not set in tCMS configuration.  Please set this first by passing t
 
 # Transform the domain name into something maximally compatible with being a username.
 if ($user) {
-    $domain = substr($domain, 0, 32);
+    $domain = substr( $domain, 0, 32 );
     $domain =~ s/\./-/g;
 }
 

+ 16 - 15
lib/TCMS.pm

@@ -3,7 +3,7 @@ package TCMS;
 use v5.36;
 use re '/aa';
 
-use Carp qw{confess};
+use Carp         qw{confess};
 use Clone        qw{clone};
 use Date::Format qw{strftime};
 
@@ -14,7 +14,7 @@ use Text::Xslate ();
 use DateTime::Format::HTTP();
 use CGI::Cookie ();
 use File::Basename();
-use Time::HiRes      qw{gettimeofday tv_interval};
+use Time::HiRes qw{gettimeofday tv_interval};
 use List::Util;
 use URI();
 use Ref::Util qw{is_coderef is_hashref is_arrayref};
@@ -49,12 +49,12 @@ sub build_routes {
 
     # Transform 'method' / 'callback' to new scheme
     my %routes_adj;
-    foreach my $k (keys(%routes)) {
+    foreach my $k ( keys(%routes) ) {
         my $v = $routes{$k};
 
         # Some routes are just pointers to other routes.
         # In this case they might have already been transformed and need to be skipped.
-        if (exists $v->{callbacks}) {
+        if ( exists $v->{callbacks} ) {
             $routes_adj{$k} = $v;
             next;
         }
@@ -70,7 +70,7 @@ sub build_routes {
             confess "Cannot determine directory for logs!" unless $tpsgi->{log_dir};
 
             # Make sure the tCMS logs live in the same dir as the tpsgi logs.
-            log_init("$tpsgi->{log_dir}/tpsgi.log", $tpsgi->{verbose} ? 'debug' : 'info');
+            log_init( "$tpsgi->{log_dir}/tpsgi.log", $tpsgi->{verbose} ? 'debug' : 'info' );
 
             # Let's open up our default route if needed before we bother thinking any harder
             return $default_route->($query) unless -f "config/setup";    ## no critic (ProhibitFiletest_f) -- a flag file, only ever touched
@@ -96,6 +96,7 @@ sub build_routes {
                 $active_user     = Trog::Auth::session2user( $cookies->{tcmslogin}->value );
                 $Trog::Log::user = $active_user if $active_user;
             }
+
             # Make sure TPSGI can log the user
             $tpsgi->{user} = $active_user;
 
@@ -114,7 +115,7 @@ sub build_routes {
             $query->{body}         = '';
             $query->{social_meta}  = 1;
             $query->{primary_post} = {};
-            $query->{nocache} = $v->{nocache};
+            $query->{nocache}      = $v->{nocache};
 
             # Some routes may just need to do serve()
             $query->{tpsgi} = $tpsgi;
@@ -165,8 +166,8 @@ sub _routes ( $data = {} ) {
     my %roots = $data->routes();
 
     # Setup the /secure/... versions for logged in users, except for already secured routes.
-    foreach my $route (keys(%roots)) {
-        next if index($route, '/secure/') == 0;
+    foreach my $route ( keys(%roots) ) {
+        next if index( $route, '/secure/' ) == 0;
         $roots{"/secure$route"} = $roots{$route};
     }
 
@@ -187,9 +188,9 @@ sub _routes ( $data = {} ) {
 
     # Special 'am I authenticated' route for nginx
     $routes{'/authenticated'} = {
-        method => 'GET',
-        nocache => 1,
-        noindex => 1,
+        method   => 'GET',
+        nocache  => 1,
+        noindex  => 1,
         callback => sub {
             my ($query) = @_;
             return $query->{tpsgi}->ok($query) if $query->{user};
@@ -199,9 +200,9 @@ sub _routes ( $data = {} ) {
 
     # Heartbeat route
     $routes{'/status'} = {
-        method => 'GET',
-        nocache => 1,
-        noindex => 1,
+        method   => 'GET',
+        nocache  => 1,
+        noindex  => 1,
         callback => sub {
             my ($query) = @_;
             return $query->{tpsgi}->ok($query);
@@ -210,7 +211,7 @@ sub _routes ( $data = {} ) {
 
     # The Various aliases for directory indices
     foreach my $index (qw{ / /index.html /index.htm}) {
-        $routes{$index} = $routes{'/index'} unless exists $routes{$index};
+        $routes{$index}          = $routes{'/index'} unless exists $routes{$index};
         $routes{"/secure$index"} = $routes{'/index'} unless exists $routes{"/secure$index"};
     }
 

+ 1 - 1
lib/Trog/Config.pm

@@ -33,7 +33,7 @@ our $default = "config/default.cfg";
 sub get {
     state $cf;
     return $cf if $cf;
-    foreach my $cfg2try ($home_cfg, $default) {
+    foreach my $cfg2try ( $home_cfg, $default ) {
         next unless -f $cfg2try;    ## no critic (ProhibitFiletest_f) -- the instance config, else the shipped default
         $cf = Config::Simple->new($cfg2try);
         last;

+ 10 - 9
lib/Trog/DataModule.pm

@@ -20,7 +20,6 @@ use Trog::Log qw{:all};
 use Trog::Utils;
 use Trog::Auth();
 
-
 =head1 QUERY FORMAT
 
 The $query_language and $query_help variables are presented to the user as to how to use the search box in the tCMS header.
@@ -149,7 +148,7 @@ sub _fixup ( $self, @filtered ) {
         $subj->{display_name} = $user2display{ $subj->{user} };
 
         #XXX Add dynamic routing data for posts which don't have them (/posts/$id) and (/users/$user)
-        my $is_user_page = List::Util::any { ($_ // '') eq 'about' } @{ $subj->{tags} };
+        my $is_user_page = List::Util::any { ( $_ // '' ) eq 'about' } @{ $subj->{tags} };
         if ( !exists $subj->{local_href} ) {
             $subj->{local_href} = "/posts/$subj->{id}";
 
@@ -220,7 +219,7 @@ sub filter ( $self, $query, @filtered ) {
         my $tags = $_->{tags};
         grep {
             my $t = $_;
-            grep { ($t // '') eq $_ } @{ $query->{tags} }
+            grep { ( $t // '' ) eq $_ } @{ $query->{tags} }
         } @$tags
     } @filtered if @{ $query->{tags} };
 
@@ -242,7 +241,7 @@ sub filter ( $self, $query, @filtered ) {
         } @$tags
     } @filtered unless grep { $_ eq 'admin' } @{ $query->{acls} };
 
-    @filtered = grep { ($_->{form} || '') eq $query->{form} } @filtered if $query->{form};
+    @filtered = grep { ( $_->{form} || '' ) eq $query->{form} } @filtered if $query->{form};
 
     @filtered = grep { $_->{title} =~ m/\Q$query->{like}\E/i || $_->{data} =~ m/\Q$query->{like}\E/i } @filtered if $query->{like};
 
@@ -427,8 +426,8 @@ sub type_meta_for ( $form = '' ) {
     my $type = _type_of($form);
     return $cache{$generation}{$type} if exists $cache{$generation}{$type};
 
-    my $path = $type ? Trog::Themes::themed_file_in_dir( 'forms', "$type.json", 'text/html', 1 ) : undef;
-    my $sidecar = $path ? _read_sidecar($path) : undef;
+    my $path    = $type ? Trog::Themes::themed_file_in_dir( 'forms', "$type.json", 'text/html', 1 ) : undef;
+    my $sidecar = $path ? _read_sidecar($path)                                                      : undef;
 
     my %meta;
     if ($sidecar) {
@@ -511,6 +510,7 @@ sub schema_for ( $form = '' ) {
 }
 
 sub _read_sidecar ($path) {
+
     # -e, not -f: the question is whether a sidecar exists at all, and most
     # post types have none.  Letting the read below fail instead would WARN
     # about every type that simply does not have one.
@@ -658,7 +658,7 @@ sub add ( $self, @posts ) {
         $post->{version} //= 0;
 
         #XXX if local_href has /secure paths in it, fix this.  We don't want to save that.
-        if (index($post->{local_href}, '/secure/') == 0) {
+        if ( index( $post->{local_href}, '/secure/' ) == 0 ) {
             $post->{local_href} =~ s|/secure||gmx;
         }
 
@@ -730,7 +730,7 @@ sub _process ($post) {
 # Browsers try and save time in the event that the same file is sent twice, so handle that.
 my %seen_files;
 
-sub _handle_upload ( $file, $uuid, $private=0 ) {
+sub _handle_upload ( $file, $uuid, $private = 0 ) {
     my $fname;
     if ( ref $file ne 'HASH' ) {
         use Data::Dumper;
@@ -744,8 +744,9 @@ sub _handle_upload ( $file, $uuid, $private=0 ) {
     my $newname = "$uuid.$file->{filename}";
     $newname = "private/$newname" if $private;
     File::Copy::move( $f, "www/assets/$newname" );
+
     # Regrettably, we have no control over the perms of the temp file that starman creates for uploads.
-    chmod(0755, "www/assets/$newname");
+    chmod( 0755, "www/assets/$newname" );
     $seen_files{$fname} = "/assets/$newname";
     return $seen_files{$fname};
 }

+ 3 - 1
lib/Trog/DataSource/Virt.pm

@@ -102,7 +102,8 @@ sub _hostname {
 
     # Sys::Hostname croaks rather than returning undef when it cannot tell, and
     # the configured hostname is the next best thing we know about ourselves.
-    $hostname = eval { Sys::Hostname::FQDN::fqdn() }
+    $hostname =
+         eval { Sys::Hostname::FQDN::fqdn() }
       || eval { Trog::Config->get()->param('general.hostname') }
       || '';
 
@@ -260,6 +261,7 @@ sub screenshot ( $hypervisor, $guest_name ) {
 
     my $dir  = "$screenshot_dir/$host";
     my $path = "$dir/$safe.png";
+
     # One stat rather than -f and then a second stat for the mtime.  A missing
     # file gives the empty list, so $mtime is undef and we fall through to a
     # fresh capture.

+ 1 - 1
lib/Trog/FileHandler.pm

@@ -73,7 +73,7 @@ sub serve ( $fullpath, $path, $start, $streaming, $ranges, $last_fetch = 0, $def
         print $IO::Compress::Gzip::GzipError if $IO::Compress::Gzip::GzipError;
         push( @headers, "Content-Length" => length($dfh) );
 
-        INFO("GET 200 ".length($dfh)." $fullpath");
+        INFO( "GET 200 " . length($dfh) . " $fullpath" );
 
         # Append server-timing headers
         my $tot = tv_interval($start) * 1000;

+ 2 - 2
lib/Trog/Log.pm

@@ -17,7 +17,7 @@ use Exporter 'import';
 our @EXPORT_OK   = qw{log_init is_debug INFO DEBUG WARN FATAL};
 our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
 
-my ($LEVEL, $LOGDIR);
+my ( $LEVEL, $LOGDIR );
 our ( $log, $user );
 
 $Trog::Log::user = 'nobody';
@@ -74,7 +74,7 @@ Returns 1.
 =cut
 
 sub log_init {
-    my ($LOGNAME, $LEVEL)  =@_;
+    my ( $LOGNAME, $LEVEL ) = @_;
 
     die "Cannot initialize logs without log name and log level" unless $LOGNAME && $LEVEL;
 

+ 2 - 2
lib/Trog/Log/DBI.pm

@@ -88,9 +88,9 @@ sub log_message {
         ( $date, $uuid, $ip, $user, $message ) = $msg =~ m!^([\w|\-|:]+) \[\w+\]: RequestId ([\w|\-]+) From ([\w|\.|:]+) \|(\w+)\| (.+)!;
 
         # If we can't figure out its request, ignore the message
-        if(length $uuid) {
+        if ( length $uuid ) {
             $buffer{$uuid} //= [];
-            push(@{$buffer{$uuid}}, $message);
+            push( @{ $buffer{$uuid} }, $message );
         }
         return 1;
     }

+ 10 - 7
lib/Trog/Renderer.pm

@@ -55,18 +55,20 @@ sub render ( $class, %options ) {
     return _yeet( $renderer, "Template not provided",                    %options ) unless $options{template};
 
     #TODO future - save the components too and then compose them?
-    my $data = $options{data};
+    my $data      = $options{data};
     my $skip_save = $options{component} || $options{nocache} || !$data->{route} || $data->{has_query} || $data->{user} || ( $options{code} // 0 ) != 200 || Trog::Log::is_debug();
 
     my $ret;
     local $@;
     eval {
         $ret = $renderer->(%options);
-        if (exists $data->{tpsgi} && !$skip_save) {
-            $data->{tpsgi}->add_post_close_callback(sub {
-                # We invalidate these in the individual routes themselves.
-                $data->{tpsgi}->save_render( $data->{route}, $rendertype, $ret->[2][0] );
-            });
+        if ( exists $data->{tpsgi} && !$skip_save ) {
+            $data->{tpsgi}->add_post_close_callback(
+                sub {
+                    # We invalidate these in the individual routes themselves.
+                    $data->{tpsgi}->save_render( $data->{route}, $rendertype, $ret->[2][0] );
+                }
+            );
         }
         1;
     } or do {
@@ -92,8 +94,9 @@ sub _yeet ( $renderer, $error, %options ) {
     } or do {
         my $msg = $error;
         $msg .= " and subsequently during render of error template, $@" if $renderer;
+
         #XXX bytes is probably not correct here
-        INFO("$options{data}{method} 500 ".length($msg)." $options{data}{route}");
+        INFO( "$options{data}{method} 500 " . length($msg) . " $options{data}{route}" );
         FATAL($msg);
     };
     return $ret;

+ 81 - 72
lib/Trog/Routes/HTML.pm

@@ -15,8 +15,8 @@ use Ref::Util();
 use Capture::Tiny qw{capture};
 use HTML::SocialMeta;
 
-use Clone qw{clone};
-use Encode qw{encode_utf8};
+use Clone       qw{clone};
+use Encode      qw{encode_utf8};
 use Digest::MD5 qw{md5_hex};
 use Digest::SHA qw{sha256_hex};
 use JSON::MaybeXS();
@@ -60,6 +60,7 @@ our %routes = (
         method   => 'GET',
         callback => \&Trog::Routes::HTML::index,
     },
+
     # This should only be enabled to debug
     #    '/setup' => {
     #        method   => 'GET',
@@ -128,6 +129,7 @@ our %routes = (
         callback => \&Trog::Routes::HTML::resetpass,
         noindex  => 1,
     },
+
     # When we are logged in, we get a diff ver of the page.
     '/secure/password_reset' => {
         method   => 'GET',
@@ -270,7 +272,7 @@ our %routes = (
 );
 
 # Grab theme routes
-my $themed = 0;
+my $themed    = 0;
 my $theme_dir = Trog::Themes::get_dir();
 if ($theme_dir) {
 
@@ -308,8 +310,8 @@ sub _feedback_redirect ( $query, $to, $failure, $message ) {
     $message =~ s/\s*\n+\s*/; /g;
     $message =~ s/;\s*$//;
 
-    my $sep = index( $to, '?' ) != -1 ? '&' : '?';
-    my $key = $failure     ? 'savefailed' : 'saved';
+    my $sep = index( $to, '?' ) != -1 ? '&'          : '?';
+    my $key = $failure                ? 'savefailed' : 'saved';
     return $query->{tpsgi}->see_also( $to . $sep . $key . '=' . URI::Escape::uri_escape($message) );
 }
 
@@ -393,7 +395,7 @@ sub index ( $query, $content = '', $i_styles = [], $i_scripts = [] ) {
     }
 
     state $data;
-    $data //= Trog::Data->new(Trog::Config::get());
+    $data //= Trog::Data->new( Trog::Config::get() );
 
     return finish_render(
         $tmpl,
@@ -432,7 +434,7 @@ sub _build_social_meta ( $query, $title ) {
     $default_tags .= ',' . join( ',', @{ $query->{primary_post}->{tags} } ) if $default_tags && $query->{primary_post}->{tags};
 
     my $primary_data = ref $query->{primary_post}{data} eq 'ARRAY' ? $query->{primary_post}{data}[0] : $query->{primary_post}{data};
-    my $meta_desc = $primary_data // $Theme::description // "tCMS Site";
+    my $meta_desc    = $primary_data // $Theme::description // "tCMS Site";
     $meta_desc = Trog::Utils::strip_and_trunc($meta_desc) || '';
 
     my $meta_tags = '';
@@ -518,8 +520,8 @@ sub totp ($query) {
     $query->{failure} //= -1;
     my ( $uri, $qr, $failure, $message, $totp ) = Trog::Auth::totp( $active_user, $domain );
 
-    my $now_tm = time;
-    my $now_string = strftime("%a %b %e T%H:%M:%SZ %Y", gmtime($now_tm));
+    my $now_tm     = time;
+    my $now_string = strftime( "%a %b %e T%H:%M:%SZ %Y", gmtime($now_tm) );
     return Trog::Routes::HTML::index(
         {
             title     => 'Enable TOTP 2-Factor Auth',
@@ -558,7 +560,7 @@ sub login ($query) {
     }
 
     #Check and see if we have no users.  If so we will just accept whatever creds are passed.
-    my $hasusers = -f "config/has_users";    ## no critic (ProhibitFiletest_f) -- a flag file, only ever touched
+    my $hasusers = -f "config/has_users";               ## no critic (ProhibitFiletest_f) -- a flag file, only ever touched
     my $btnmsg   = $hasusers ? "Log In" : "Register";
 
     my $headers;
@@ -570,7 +572,7 @@ sub login ($query) {
             Trog::Auth::useradd( $query->{username}, $query->{display_name}, $query->{password}, ['admin'], $query->{contact_email} );
 
             # Add a stub user page and the initial series.
-            my $dat = Trog::Data->new(Trog::Config::get());
+            my $dat = Trog::Data->new( Trog::Config::get() );
             _setup_initial_db( $dat, $query->{username}, $query->{display_name}, $query->{contact_email} );
 
             # Ensure we stop registering new users
@@ -703,8 +705,8 @@ Renders the configuration page, or redirects you back to the login page.
 =cut
 
 sub config ( $query = {} ) {
-    return $query->{tpsgi}->see_also('/login')                    unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     $query->{failure} //= -1;
 
@@ -830,7 +832,7 @@ sub do_totp_clear ($query) {
 
 sub _get_series ( $edit = 0 ) {
     state $data;
-    $data //= Trog::Data->new(Trog::Config::get());
+    $data //= Trog::Data->new( Trog::Config::get() );
 
     my @series = $data->get(
         acls  => [qw{public}],
@@ -919,8 +921,8 @@ Implements /config/save route.  Saves what little configuration we actually use
 =cut
 
 sub config_save ($query) {
-    return $query->{tpsgi}->see_also('/login')                    unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     my $conf = Trog::Config::get();
     $conf->param( 'general.theme',              $query->{theme} )      if defined $query->{theme};
@@ -948,8 +950,8 @@ Clone a theme by copying a directory.
 =cut
 
 sub themeclone ($query) {
-    return $query->{tpsgi}->see_also('/login')                    unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     my ( $theme, $newtheme ) = ( $query->{theme}, $query->{newtheme} );
 
@@ -973,7 +975,7 @@ Saves posts submitted via the /post pages
 
 sub post_save ($qq) {
     return $qq->{tpsgi}->see_also('/login') unless $qq->{user};
-    return $qq->{tpsgi}->forbidden($qq)  unless grep { $_ eq 'admin' } @{ $qq->{user_acls} };
+    return $qq->{tpsgi}->forbidden($qq)     unless grep { $_ eq 'admin' } @{ $qq->{user_acls} };
 
     my $query = clone($qq);
 
@@ -983,8 +985,9 @@ sub post_save ($qq) {
     my $acls = $query->{acls};
 
     $query->{tags} = Trog::Utils::coerce_array( $query->{tags} );
+
     # Support data with multiple pages like presentations
-    $query->{data} = Trog::Utils::coerce_array( $query->{data} ) if $query->{data_is_array};
+    $query->{data}        = Trog::Utils::coerce_array( $query->{data} ) if $query->{data_is_array};
     $query->{attachments} = Trog::Utils::coerce_array( $query->{attachments} );
 
     # Filter bits and bobs XXX this is done deeper in, may require removal
@@ -1000,7 +1003,7 @@ sub post_save ($qq) {
     $query->{method} = 'GET';
 
     state $data;
-    $data //= Trog::Data->new(Trog::Config::get());
+    $data //= Trog::Data->new( Trog::Config::get() );
 
     # A post that doesn't match its type's schema is the user's mistake, not a
     # server error, so hand the validation errors back rather than dying.
@@ -1016,11 +1019,13 @@ sub post_save ($qq) {
     };
 
     # Instruct tpsgi to invalidate the cached render.
-    $qq->{tpsgi}->add_post_close_callback(sub {
-        # XXX there is not a great way to find what needs to be re-rendered because posts can include other posts.
-        # As such we just have to nuke all the .html renders.
-        $qq->{tpsgi}->invalidate_renders('html');
-    });
+    $qq->{tpsgi}->add_post_close_callback(
+        sub {
+            # XXX there is not a great way to find what needs to be re-rendered because posts can include other posts.
+            # As such we just have to nuke all the .html renders.
+            $qq->{tpsgi}->invalidate_renders('html');
+        }
+    );
 
     # Force a reload of the routing table
     $qq->{tpsgi}->signal_restart_parent();
@@ -1035,12 +1040,12 @@ Saves / updates new users.
 =cut
 
 sub profile ($query) {
-    return $query->{tpsgi}->see_also('/login')                    unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     # Find the user's post and edit it
     state $data;
-    $data //= Trog::Data->new(Trog::Config::get());
+    $data //= Trog::Data->new( Trog::Config::get() );
 
     my @userposts = $data->get( tags => ['about'], acls => [qw{admin}] );
 
@@ -1050,7 +1055,8 @@ sub profile ($query) {
 
     my $username = $query->{username};
     my $password = $query->{password};
-    my $changed  = $username ne ( $user_obj->{user} // '' )
+    my $changed =
+         $username ne ( $user_obj->{user} // '' )
       || $password
       || ( $query->{contact_email} // '' ) ne ( $user_obj->{contact_email} // '' )
       || ( $query->{display_name}  // '' ) ne ( $user_obj->{display_name}  // '' );
@@ -1097,11 +1103,11 @@ deletes posts.
 =cut
 
 sub post_delete ($query) {
-    return $query->{tpsgi}->see_also('/login')                    unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     state $data;
-    $data //= Trog::Data->new(Trog::Config::get());
+    $data //= Trog::Data->new( Trog::Config::get() );
 
     $data->delete($query) and die "Could not delete post";
     return $query->{tpsgi}->see_also( $query->{to} );
@@ -1311,7 +1317,7 @@ sub libravatar ($query) {
 
     return $query->{tpsgi}->notfound($query) unless $matched_user;
 
-    my @posts = _post_helper( { author => $matched_user }, ['about'], [qw{public admin}] );
+    my @posts   = _post_helper( { author => $matched_user }, ['about'], [qw{public admin}] );
     my $preview = @posts ? $posts[0]->{preview} : '';
 
     return $query->{tpsgi}->notfound($query) unless $preview;
@@ -1509,7 +1515,7 @@ sub posts ( $query, $direct = 0 ) {
     my $tiled    = $query->{primary_post} ? !$is_admin && $query->{primary_post}->{tiled} : 0;
 
     state $data;
-    $data //= Trog::Data->new(Trog::Config::get());
+    $data //= Trog::Data->new( Trog::Config::get() );
 
     # Grab the rest of the tags to dump into the edit form
     my @tags_all = $data->tags();
@@ -1542,7 +1548,6 @@ sub posts ( $query, $direct = 0 ) {
     my %relation_cache;
     _enrich_post( $_, $query, \%relation_cache ) foreach @posts;
 
-
     #XXX the only reason this is needed is due to direct=1
     # Last thing before the data becomes a page: anything a type marks private
     # goes no further for a reader who cannot edit.  Deliberately after the
@@ -1697,7 +1702,7 @@ sub _datasource_posts ( $query, $posts ) {
 
 sub _post_helper ( $query, $tags, $acls ) {
     state $data;
-    $data //= Trog::Data->new(Trog::Config::get());
+    $data //= Trog::Data->new( Trog::Config::get() );
 
     $query->{page}  ||= 1;
     $query->{limit} ||= 25;
@@ -1742,7 +1747,7 @@ Passing compressed=1 will gzip the output.
 sub sitemap ($query) {
 
     state $data;
-    $data //= Trog::Data->new(Trog::Config::get());
+    $data //= Trog::Data->new( Trog::Config::get() );
 
     state $etag = "sitemap-" . time();
     my ( @to_map, $is_index, $route_type );
@@ -1950,8 +1955,8 @@ Basically a thin wrapper around Pod::Html.
 =cut
 
 sub manual ($query) {
-    return $query->{tpsgi}->see_also('/login')                    unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     require Pod::Html;
     require Capture::Tiny;
@@ -1961,10 +1966,10 @@ sub manual ($query) {
     $query->{failure} //= -1;
 
     my $infile = $query->{module} ? "$query->{module}.pm" : 'tCMS/Manual.pod';
-    my $found = 0;
+    my $found  = 0;
     foreach my $libdir (@INC) {
         $found = $libdir if -f "$libdir/$infile";    ## no critic (ProhibitFiletest_f) -- which @INC dir supplies the pod
-        last if $found;
+        last             if $found;
     }
     return $query->{tpsgi}->notfound($query) unless $found;
 
@@ -2016,8 +2021,8 @@ compute here.
 =cut
 
 sub metrics ($query) {
-    return $query->{tpsgi}->see_also('/login')                    unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     $query->{failure} //= -1;
 
@@ -2050,8 +2055,8 @@ session id on a page.
 =cut
 
 sub sessions ($query) {
-    return $query->{tpsgi}->see_also('/login')  unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     my $limit  = int( $query->{limit} // 100 );
     my $events = Trog::Auth::audit_log(
@@ -2064,7 +2069,7 @@ sub sessions ($query) {
     @$events = map {
         my $e = {%$_};
         my @t = localtime( $e->{event_time} );
-        $e->{event_ts} = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0] );
+        $e->{event_ts}      = sprintf( '%04d-%02d-%02d %02d:%02d:%02d', $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0] );
         $e->{session_short} = $e->{session_id} ? substr( $e->{session_id}, 0, 8 ) . '...' : '';
         $e
     } @$events;
@@ -2145,7 +2150,7 @@ captures in parallel instead of us taking them one after another.
 
 sub guest_screenshot ($query) {
     return $query->{tpsgi}->see_also('/login') unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     my $hypervisor = _guest_hypervisor( $query, $query->{hypervisor} );
     return $query->{tpsgi}->notfound($query) unless $hypervisor;
@@ -2158,7 +2163,7 @@ sub guest_screenshot ($query) {
     }
 
     return $query->{tpsgi}->serve(
-        $query->{route}, $path, $query->{start}, $query->{streaming},
+        $query->{route},  $path, $query->{start}, $query->{streaming},
         $query->{ranges}, $query->{last_fetched}, $query->{deflate},
     );
 }
@@ -2175,7 +2180,7 @@ Trog::DataSource::Virt::act.
 
 sub guest_act ($query) {
     return $query->{tpsgi}->see_also('/login') unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     my $to = $query->{to} || '/';
 
@@ -2183,6 +2188,7 @@ sub guest_act ($query) {
     return _feedback_redirect( $query, $to, 1, 'No such hypervisor.' ) unless $hypervisor;
 
     require Trog::DataSource::Virt;
+
     # Same reason the screenshot route captures 'guest': a form field called
     # 'domain' would be overwritten by the router with the request's host.
     my ( $ok, $message ) = Trog::DataSource::Virt::act(
@@ -2217,8 +2223,8 @@ everything after a rejected submission.
 =cut
 
 sub post_wizard ($query) {
-    return $query->{tpsgi}->see_also('/login')  unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     $query->{failure} //= -1;
 
@@ -2269,8 +2275,8 @@ type's own fields survive validation at save time.
 =cut
 
 sub post_wizard_save ($query) {
-    return $query->{tpsgi}->see_also('/login')  unless $query->{user};
-    return $query->{tpsgi}->forbidden($query) unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
+    return $query->{tpsgi}->see_also('/login') unless $query->{user};
+    return $query->{tpsgi}->forbidden($query)  unless grep { $_ eq 'admin' } @{ $query->{user_acls} };
 
     # Anchored capture rather than a substitution, so anything containing a '/'
     # or a '..' simply fails to match instead of being silently scrubbed into
@@ -2282,6 +2288,7 @@ sub post_wizard_save ($query) {
     # otherwise.  Never mkdir it -- silently conjuring a forms/ dir inside a
     # theme is not something an admin asked for by pressing this button.
     my $dir = Trog::Themes::forms_dir();
+
     # -d only.  A -w here would check mode bits against our uid, which says
     # nothing about read-only mounts, ACLs or immutable flags -- and it is the
     # files, not the directory, that get written.  The eval around the two
@@ -2312,7 +2319,7 @@ sub post_wizard_save ($query) {
     # title or restrict.
     $query->{$_} = 1 foreach @wizard_mandatory;
 
-    my @includes = grep { $query->{$_} } @wizard_include_order;
+    my @includes  = grep { $query->{$_} } @wizard_include_order;
     my $body_form = _wizard_scalar( $query->{body_form} ) eq 'form_multi.tx' ? 'form_multi.tx' : 'form_common.tx';
 
     my $spec = _wizard_sidecar( $name, $fields, \@includes, $body_form, $datasource );
@@ -2396,11 +2403,11 @@ arrays stay aligned even when a row is left blank.
 =cut
 
 sub _wizard_fields ($query) {
-    my $names  = Trog::Utils::coerce_array( $query->{param_name} );
-    my $types  = Trog::Utils::coerce_array( $query->{param_type} );
-    my $labels = Trog::Utils::coerce_array( $query->{param_label} );
-    my $phs    = Trog::Utils::coerce_array( $query->{param_placeholder} );
-    my $reqs   = Trog::Utils::coerce_array( $query->{param_required} );
+    my $names   = Trog::Utils::coerce_array( $query->{param_name} );
+    my $types   = Trog::Utils::coerce_array( $query->{param_type} );
+    my $labels  = Trog::Utils::coerce_array( $query->{param_label} );
+    my $phs     = Trog::Utils::coerce_array( $query->{param_placeholder} );
+    my $reqs    = Trog::Utils::coerce_array( $query->{param_required} );
     my $rforms  = Trog::Utils::coerce_array( $query->{param_relation_form} );
     my $rmodes  = Trog::Utils::coerce_array( $query->{param_relation_mode} );
     my $private = Trog::Utils::coerce_array( $query->{param_private} );
@@ -2470,8 +2477,8 @@ sub _wizard_sidecar ( $name, $fields, $includes, $body_form, $datasource = '' )
         }
 
         my $property = { %{ $wizard_field_types{ $field->{type} } } };
-        $property->{'x-tcms-input'} = $field->{type};
-        $property->{'x-tcms-label'} = $field->{label};
+        $property->{'x-tcms-input'}       = $field->{type};
+        $property->{'x-tcms-label'}       = $field->{label};
         $property->{'x-tcms-placeholder'} = $field->{placeholder} if length $field->{placeholder};
 
         # Only written when it is true: a field is public unless it says so,
@@ -2500,8 +2507,8 @@ sub _wizard_sidecar ( $name, $fields, $includes, $body_form, $datasource = '' )
         type       => 'object',
         properties => \%properties,
     );
-    $spec{required}             = \@required   if @required;
-    $spec{'x-tcms-relations'}  = \%relations  if %relations;
+    $spec{required}            = \@required  if @required;
+    $spec{'x-tcms-relations'}  = \%relations if %relations;
     $spec{'x-tcms-datasource'} = $datasource if $datasource;
 
     return \%spec;
@@ -2548,6 +2555,7 @@ sub _wizard_template ( $query, $fields, $includes, $body_form, $datasource = ''
     my $display = _wizard_scalar( $query->{display} );
 
     my $out = "<!-- Generated by the tCMS Post Type Wizard.  Regenerating this type will overwrite any hand edits. -->\n";
+
     # A series can ask for its children to be tiled, which is a layout the
     # wrapper has to carry -- see how file.tx and series.tx do it.  Harmless
     # when the series hasn't asked, and it means a generated type gets tiling
@@ -2592,8 +2600,8 @@ sub _wizard_template ( $query, $fields, $includes, $body_form, $datasource = ''
     return $out;
 }
 
-
 # basically a file rewrite rule for themes
+
 =head2 icon
 
 Implements the /img/icon/* routes.
@@ -2604,9 +2612,9 @@ steps, essentially, so that themes can replace individual icons.
 =cut
 
 sub icon ($query) {
-    my $path = $query->{route};
+    my $path  = $query->{route};
     my $tpath = Trog::Themes::themed("img/icon/$path");
-    return $query->{tpsgi}->serve( $path, $tpath, $query->{start}, $query->{streaming}, $query->{ranges}, $query->{last_fetched}, $query->{deflate}  );
+    return $query->{tpsgi}->serve( $path, $tpath, $query->{start}, $query->{streaming}, $query->{ranges}, $query->{last_fetched}, $query->{deflate} );
 }
 
 =head2 totp_qr
@@ -2621,7 +2629,8 @@ shared secret.
 =cut
 
 sub totp_qr ($query) {
-    my $fname = basename($query->{route});
+    my $fname = basename( $query->{route} );
+
     # For authenticated content, we have to now do a serve().
     return $query->{tpsgi}->serve(
         "totp/$fname",
@@ -2687,11 +2696,11 @@ Just about everything in this module ends up here; index() is the usual way in.
 sub finish_render ( $template, $vars, %headers ) {
 
     #XXX default vars that need to be pulled from config
-    $vars->{lang}        //= 'en-US';
-    $vars->{title}       //= 'tCMS';
-    $vars->{stylesheets} //= [];
+    $vars->{lang}         //= 'en-US';
+    $vars->{title}        //= 'tCMS';
+    $vars->{stylesheets}  //= [];
     $vars->{print_styles} //= [qw{structure.css print.css}];
-    $vars->{scripts}     //= [];
+    $vars->{scripts}      //= [];
 
     # Theme-ize the paths
     $vars->{stylesheets}  = [ @{ _build_themed_styles( $vars->{stylesheets} ) } ];

+ 3 - 2
lib/Trog/Routes/JSON.pm

@@ -94,7 +94,7 @@ sub catalog ($query) {
 }
 
 sub webmanifest ($query) {
-    state $headers  = { ETag => 'manifest-' . _version() };
+    state $headers = { ETag => 'manifest-' . _version() };
     my $theme_dir = Trog::Themes::get_dir();
     state %manifest = (
         "icons" => [
@@ -159,8 +159,9 @@ sub _render ( $code, $headers, %data ) {
         template    => 'bogus.tx',
         contenttype => 'application/json',
         headers     => $headers,
+
         # TODO it may be appropriate to cache some of these methods.
-        nocache     => 1,
+        nocache => 1,
     );
 }
 

+ 1 - 1
lib/Trog/SQLite/TagIndex.pm

@@ -22,7 +22,7 @@ sub posts_for_tags (@tags) {
     my $dbh    = _dbh();
     my $clause = @tags ? "WHERE tag IN (" . join( ',', ( map { '?' } @tags ) ) . ")" : '';
     ## no critic(ValuesAndExpressions::PreventSQLInjection)
-    my $rows   = $dbh->selectall_arrayref( "SELECT DISTINCT id FROM posts $clause ORDER BY created DESC", { Slice => {} }, @tags );
+    my $rows = $dbh->selectall_arrayref( "SELECT DISTINCT id FROM posts $clause ORDER BY created DESC", { Slice => {} }, @tags );
     return () unless ref $rows eq 'ARRAY' && @$rows;
     return map { $_->{id} } @$rows;
 }

+ 3 - 3
lib/Trog/Themes.pm

@@ -54,14 +54,14 @@ Memoized for the life of the process: changing the theme goes through
 sub get_dir {
     state $tdir = '';
     return $tdir if $tdir;
-    my $conf = Trog::Config::get();
+    my $conf  = Trog::Config::get();
     my $theme = $conf->param('general.theme') || '';
-    if( $theme ) {
+    if ($theme) {
         my $themedir = "www/themes/$theme";
         $tdir = $themedir if -d $themedir;
     }
     return $tdir;
-};
+}
 
 =head2 td() = STRING $dir
 

+ 24 - 18
t/Trog-Auth-libravatar.t

@@ -28,15 +28,18 @@ require_ok('Trog::Auth') or BAIL_OUT("Can't load Trog::Auth");
 
 subtest 'users_with_emails — no rows returned' => sub {
     my $sqlite_mock = Test::MockModule->new('Trog::SQLite');
-    $sqlite_mock->redefine( 'dbh', sub {
-        my $fake_dbh = bless {}, 'FakeDBH_NoRows';
-        no warnings 'once';
-        *FakeDBH_NoRows::selectall_arrayref = sub { undef };
-        return $fake_dbh;
-    });
+    $sqlite_mock->redefine(
+        'dbh',
+        sub {
+            my $fake_dbh = bless {}, 'FakeDBH_NoRows';
+            no warnings 'once';
+            *FakeDBH_NoRows::selectall_arrayref = sub { undef };
+            return $fake_dbh;
+        }
+    );
     my $result = Trog::Auth::users_with_emails();
-    is( ref $result, 'ARRAY', 'returns arrayref even when DB returns undef' );
-    is( scalar @$result, 0, 'empty arrayref when no rows' );
+    is( ref $result,     'ARRAY', 'returns arrayref even when DB returns undef' );
+    is( scalar @$result, 0,       'empty arrayref when no rows' );
 };
 
 subtest 'users_with_emails — returns populated list' => sub {
@@ -45,23 +48,26 @@ subtest 'users_with_emails — returns populated list' => sub {
         { name => 'bob',   contact_email => 'bob@example.com' },
     ];
     my $sqlite_mock = Test::MockModule->new('Trog::SQLite');
-    $sqlite_mock->redefine( 'dbh', sub {
-        my $fake_dbh = bless {}, 'FakeDBH_WithRows';
-        no warnings 'once';
-        *FakeDBH_WithRows::selectall_arrayref = sub { $fake_rows };
-        return $fake_dbh;
-    });
+    $sqlite_mock->redefine(
+        'dbh',
+        sub {
+            my $fake_dbh = bless {}, 'FakeDBH_WithRows';
+            no warnings 'once';
+            *FakeDBH_WithRows::selectall_arrayref = sub { $fake_rows };
+            return $fake_dbh;
+        }
+    );
     my $result = Trog::Auth::users_with_emails();
-    is( ref $result, 'ARRAY', 'returns arrayref' );
-    is( scalar @$result, 2, 'correct number of users' );
+    is( ref $result,                 'ARRAY',             'returns arrayref' );
+    is( scalar @$result,             2,                   'correct number of users' );
     is( $result->[0]{name},          'alice',             'first user name' );
     is( $result->[0]{contact_email}, 'alice@example.com', 'first user email' );
     is( $result->[1]{name},          'bob',               'second user name' );
 };
 
 subtest 'libravatar hash matching logic' => sub {
-    use Digest::MD5  qw{md5_hex};
-    use Digest::SHA  qw{sha256_hex};
+    use Digest::MD5 qw{md5_hex};
+    use Digest::SHA qw{sha256_hex};
 
     my $email  = 'Test@Example.COM';
     my $norm   = lc($email);

+ 6 - 3
t/Trog-Config.t

@@ -23,7 +23,7 @@ our $ROOT   = File::Temp::tempdir( 'tcms-config-XXXXXX', TMPDIR => 1, CLEANUP =>
 our $OLDCWD = Cwd::getcwd();
 
 END {
-    chdir($OLDCWD) if $OLDCWD;
+    chdir($OLDCWD)                 if $OLDCWD;
     File::Path::remove_tree($ROOT) if $ROOT && -d $ROOT;
 }
 
@@ -63,12 +63,15 @@ subtest 'a config written to home_cfg is the one that gets read back' => sub {
 };
 
 subtest 'the shipped defaults are left alone' => sub {
+
     # get() is memoized, so this is the same object as above -- which is the
     # point: bin/tcms-hostname used to call save() on it, and save() writes back
     # to whichever file it was constructed from.
-    is( Path::Tiny->new('config/default.cfg')->slurp_utf8,
+    is(
+        Path::Tiny->new('config/default.cfg')->slurp_utf8,
         "[general]\ndata_model=FlatFile\ntitle=Stock\n",
-        'default.cfg is untouched' );
+        'default.cfg is untouched'
+    );
 };
 
 done_testing();

+ 26 - 21
t/Trog-DataModule-schema.t

@@ -21,7 +21,7 @@ require_ok('Trog::Routes::HTML');
 # component dir with a forms/ inside it -- because schema_for() keys its cache
 # on the mtime of forms/, and an earlier version of this fixture flattened the
 # two and so could not have caught it being keyed on the wrong directory.
-my $tempdir = Path::Tiny->tempdir();
+my $tempdir  = Path::Tiny->tempdir();
 my $formsdir = $tempdir->child('forms');
 $formsdir->mkpath();
 my %sidecars;
@@ -45,6 +45,7 @@ $slurpmock->redefine( 'read_text', sub { $sidecars{ Path::Tiny::path(shift)->bas
 # -f has to agree with %sidecars, and the dir mtime has to move, or the
 # mtime-keyed cache will hand back a stale answer.
 my $generation = 0;
+
 sub set_sidecars {
     %sidecars = @_;
     $_->remove foreach $formsdir->children();
@@ -60,9 +61,9 @@ subtest 'the base schema applies with no sidecar at all' => sub {
     set_sidecars();
 
     my $schema = Trog::DataModule::schema_for('blog.tx');
-    ok( exists $schema->{properties}{title},   "base properties are there" );
-    ok( !exists $schema->{properties}{gravy},  "and nothing else is" );
-    ok( !exists $schema->{required},           "an empty required list isn't emitted - it isn't legal OpenAPI" );
+    ok( exists $schema->{properties}{title},  "base properties are there" );
+    ok( !exists $schema->{properties}{gravy}, "and nothing else is" );
+    ok( !exists $schema->{required},          "an empty required list isn't emitted - it isn't legal OpenAPI" );
 
     is_deeply(
         Trog::DataModule::schema_for(''),
@@ -84,8 +85,10 @@ subtest 'a sidecar merges over the base' => sub {
     ok( exists $schema->{properties}{title},    "...without losing the base's" );
     is_deeply( $schema->{required}, ['servings'], "required carries over" );
 
-    ok( !exists Trog::DataModule::schema_for('blog.tx')->{properties}{servings},
-        "and they don't leak onto another post type" );
+    ok(
+        !exists Trog::DataModule::schema_for('blog.tx')->{properties}{servings},
+        "and they don't leak onto another post type"
+    );
 };
 
 subtest 'sidecars cannot redefine core post fields' => sub {
@@ -118,8 +121,10 @@ subtest 'the cache follows the forms dir mtime' => sub {
     ok( exists Trog::DataModule::schema_for('recipe.tx')->{properties}{servings}, "declared" );
 
     set_sidecars();
-    ok( !exists Trog::DataModule::schema_for('recipe.tx')->{properties}{servings},
-        "removing the sidecar is picked up without a restart" );
+    ok(
+        !exists Trog::DataModule::schema_for('recipe.tx')->{properties}{servings},
+        "removing the sidecar is picked up without a restart"
+    );
 };
 
 subtest 'validate() filters, coerces and reports' => sub {
@@ -156,7 +161,7 @@ subtest 'validate() filters, coerces and reports' => sub {
     # 'upload' is our own sugar for the string-or-hashref an upload field is,
     # depending on which direction it's travelling.
     is_deeply( [ Trog::DataModule::validate( { form => 'recipe.tx', photo => { filename => 'x' } } ) ], [], "an upload hashref passes" );
-    is_deeply( [ Trog::DataModule::validate( { form => 'recipe.tx', photo => '/assets/x.jpg' } ) ],      [], "so does the href it becomes" );
+    is_deeply( [ Trog::DataModule::validate( { form => 'recipe.tx', photo => '/assets/x.jpg' } ) ],     [], "so does the href it becomes" );
 };
 
 subtest 'empty inputs are treated as absent, except for strings' => sub {
@@ -189,7 +194,7 @@ subtest 'add() rejects a post that does not validate' => sub {
     my $written;
     {
         no warnings qw{once};
-        @TestData::ISA = ('Trog::DataModule');
+        @TestData::ISA   = ('Trog::DataModule');
         *TestData::get   = sub { return () };
         *TestData::write = sub { $written = $_[1]; return 0 };
     }
@@ -215,7 +220,7 @@ subtest 'a post always ends up with a visibility' => sub {
     my $written;
     {
         no warnings qw{once};
-        @VisData::ISA = ('Trog::DataModule');
+        @VisData::ISA   = ('Trog::DataModule');
         *VisData::get   = sub { return () };
         *VisData::write = sub { $written = $_[1]; return 0 };
     }
@@ -246,27 +251,27 @@ subtest '_wizard_fields zips the parallel arrays' => sub {
         }
     );
 
-    is( scalar @$fields, 2, "blank, core-shadowing and duplicate rows are dropped" );
-    is( $fields->[0]{name},      'servings',  "names are lowercased" );
-    is( $fields->[0]{required},  1,           "required survives" );
-    is( $fields->[1]{name},      'cook_time', "the row after the blank one is still present" );
-    is( $fields->[1]{type},      'textarea',  "...with its own type, not the blank row's" );
+    is( scalar @$fields,        2,           "blank, core-shadowing and duplicate rows are dropped" );
+    is( $fields->[0]{name},     'servings',  "names are lowercased" );
+    is( $fields->[0]{required}, 1,           "required survives" );
+    is( $fields->[1]{name},     'cook_time', "the row after the blank one is still present" );
+    is( $fields->[1]{type},     'textarea',  "...with its own type, not the blank row's" );
 };
 
 subtest '_wizard_sidecar emits a usable OpenAPIv3 schema' => sub {
     my $spec = Trog::Routes::HTML::_wizard_sidecar(
         'recipe',
         [
-            { name => 'servings',  type => 'number',   label => 'Servings',  placeholder => '4', required => 1 },
-            { name => 'vegan',     type => 'checkbox', label => 'Vegan?',    placeholder => '', required => 0 },
+            { name => 'servings', type => 'number',   label => 'Servings', placeholder => '4', required => 1 },
+            { name => 'vegan',    type => 'checkbox', label => 'Vegan?',   placeholder => '',  required => 0 },
         ],
         ['inc_tags'],
         'form_common.tx',
     );
 
-    is( $spec->{type},                          'object',   "it's an object schema" );
-    is( $spec->{properties}{servings}{type},    'integer',  "a number input is an integer" );
-    is( $spec->{properties}{vegan}{type},       'boolean',  "a checkbox is a boolean" );
+    is( $spec->{type},                       'object',  "it's an object schema" );
+    is( $spec->{properties}{servings}{type}, 'integer', "a number input is an integer" );
+    is( $spec->{properties}{vegan}{type},    'boolean', "a checkbox is a boolean" );
     is_deeply( $spec->{required}, ['servings'], "only the required rows are required" );
 
     # UI metadata rides along on x- keys so there's only one file to keep in sync.

+ 71 - 57
t/Trog-DataSource-Virt.t

@@ -3,7 +3,7 @@ use warnings;
 
 use Test::More;
 use Test::MockModule qw{strict};
-use Test::Fatal qw{exception};
+use Test::Fatal      qw{exception};
 use Path::Tiny();
 use JSON::MaybeXS();
 use FindBin;
@@ -23,17 +23,18 @@ $logmock->redefine( INFO => sub { note(shift) } );
 our @CALLS;
 
 {
+
     package FakeDomain;
-    sub new { my ( $c, %a ) = @_; return bless {%a}, $c }
+    sub new             { my ( $c, %a ) = @_; return bless {%a}, $c }
     sub get_name        { $_[0]{name} }
     sub get_uuid_string { $_[0]{uuid} }
     sub is_active       { $_[0]{active} }
     sub get_info        { { state => $_[0]{state}, memory => 1024, nrVirtCpu => 2 } }
 
     # The operations we must never actually perform: record and return.
-    sub create        { push @main::CALLS, [ 'create',        $_[0]{name} ]; 1 }
-    sub shutdown      { push @main::CALLS, [ 'shutdown',      $_[0]{name} ]; 1 }
-    sub destroy       { push @main::CALLS, [ 'destroy',       $_[0]{name} ]; 1 }
+    sub create          { push @main::CALLS, [ 'create',          $_[0]{name} ]; 1 }
+    sub shutdown        { push @main::CALLS, [ 'shutdown',        $_[0]{name} ]; 1 }
+    sub destroy         { push @main::CALLS, [ 'destroy',         $_[0]{name} ]; 1 }
     sub create_snapshot { push @main::CALLS, [ 'create_snapshot', $_[0]{name} ]; 1 }
 
     # Reading a console is not a mutation, so this one really runs.
@@ -41,16 +42,19 @@ our @CALLS;
 }
 
 {
+
     package FakeStream;
-    sub new { bless {}, shift }
+    sub new      { bless {}, shift }
     sub recv_all { my ( $self, $cb ) = @_; $cb->( $self, 'fake-png-bytes' ); return 1 }
     sub finish   { 1 }
 }
 
 {
+
     package FakeConn;
-    sub new { bless {}, shift }
+    sub new        { bless {}, shift }
     sub new_stream { FakeStream->new() }
+
     sub list_all_domains {
         return (
             FakeDomain->new( name => 'alpha', uuid => 'uuid-alpha', active => 1, state => 1 ),
@@ -60,7 +64,7 @@ our @CALLS;
 }
 
 my $connect_fails = 0;
-my $virtmock = Test::MockModule->new('Sys::Virt');
+my $virtmock      = Test::MockModule->new('Sys::Virt');
 $virtmock->redefine(
     new => sub {
         die "libvirt error: nope\n" if $connect_fails;
@@ -85,14 +89,14 @@ subtest 'guests become posts' => sub {
     @CALLS = ();
     my @posts = Trog::DataSource::Virt::posts( $series, { user_acls => ['admin'] } );
 
-    is( scalar @posts, 2, 'one post per guest' );
-    is( $posts[0]{title}, 'alpha',      'named after the guest' );
-    is( $posts[0]{id},    'uuid-alpha', "and identified by the guest's uuid, not ours" );
-    is( $posts[0]{form},  'guests.tx',  "wearing the series' child type" );
-    is( $posts[0]{state}, 'running',    'with a legible state' );
-    is( $posts[1]{state}, 'shut off',   '...for each of libvirt\'s numeric ones' );
-    is( $posts[0]{is_active}, 1, 'active guests are marked so' );
-    is( $posts[1]{is_active}, 0, 'and inactive ones are not' );
+    is( scalar @posts,        2,            'one post per guest' );
+    is( $posts[0]{title},     'alpha',      'named after the guest' );
+    is( $posts[0]{id},        'uuid-alpha', "and identified by the guest's uuid, not ours" );
+    is( $posts[0]{form},      'guests.tx',  "wearing the series' child type" );
+    is( $posts[0]{state},     'running',    'with a legible state' );
+    is( $posts[1]{state},     'shut off',   '...for each of libvirt\'s numeric ones' );
+    is( $posts[0]{is_active}, 1,            'active guests are marked so' );
+    is( $posts[1]{is_active}, 0,            'and inactive ones are not' );
 
     # The listing must not take screenshots: that is a per-guest round trip,
     # and it is the browser's job via the preview route.
@@ -124,11 +128,11 @@ subtest 'a guest is this server when it is named like it' => sub {
     }
 
     my @different = (
-        [ 'beta',               'foo'                => 'a different name' ],
-        [ 'fooling',            'foo'                => 'a name this one is only a prefix of' ],
-        [ 'foo.test.test',      'foo.troglodyne.net' => 'the same label in someone else\'s domain' ],
-        [ '',                   'foo'                => 'a guest with no name at all' ],
-        [ 'foo',                ''                   => 'any guest, when we cannot tell what we are called' ],
+        [ 'beta',          'foo'                => 'a different name' ],
+        [ 'fooling',       'foo'                => 'a name this one is only a prefix of' ],
+        [ 'foo.test.test', 'foo.troglodyne.net' => 'the same label in someone else\'s domain' ],
+        [ '',              'foo'                => 'a guest with no name at all' ],
+        [ 'foo',           ''                   => 'any guest, when we cannot tell what we are called' ],
     );
     foreach my $case (@different) {
         my ( $guest, $host, $why ) = @$case;
@@ -288,7 +292,7 @@ subtest 'the datasource hook only loads what it should' => sub {
     $declared = 'Trog::DataSource::Virt';
     $query->{primary_post}{hypervisors} = [ { id => 'hv-1', title => 'spec-hv', conn_uri => 'test:///default' } ];
     my @got = Trog::Routes::HTML::_datasource_posts( $query, \@stored );
-    is( scalar @got,   2,       'a declared datasource replaces the stored posts' );
+    is( scalar @got,    2,       'a declared datasource replaces the stored posts' );
     is( $got[0]{title}, 'alpha', 'with what it built' );
 };
 
@@ -328,11 +332,11 @@ subtest 'guests show nothing an unprivileged viewer cannot use' => sub {
     );
 
     my %post = (
-        form    => 'guests.tx',
-        id      => 'uuid-alpha', title  => 'alpha',  state   => 'running', is_active => 1,
-        preview => '/guest/screenshot/hv-1/alpha',   domain  => 'alpha',
-        hypervisor => 'hv-1', hypervisor_title => 'spec-hv', vcpus => 2,
-        addpost => 0, unreachable => 0,
+        form       => 'guests.tx',
+        id         => 'uuid-alpha',                   title            => 'alpha', state => 'running', is_active => 1,
+        preview    => '/guest/screenshot/hv-1/alpha', domain           => 'alpha',
+        hypervisor => 'hv-1',                         hypervisor_title => 'spec-hv', vcpus => 2,
+        addpost    => 0,                              unreachable      => 0,
     );
 
     my %views = (
@@ -359,7 +363,7 @@ subtest 'guests show nothing an unprivileged viewer cannot use' => sub {
 
         # The screenshot route requires the admin acl, so showing the img to
         # anyone else is a broken image and nothing else.
-        is( scalar( () = $out =~ m/<img /g ), $admin ? 1 : 0, "$view: console capture shown only to an admin" );
+        is( scalar( () = $out =~ m/<img /g ),                   $admin ? 1 : 0, "$view: console capture shown only to an admin" );
         is( scalar( () = $out =~ m{href="/guest/screenshot}g ), $admin ? 1 : 0, "$view: and so is the link to it" );
 
         # Powering off, snapshotting and destroying likewise.
@@ -379,20 +383,24 @@ subtest 'the server itself is drawn without the controls that would kill it' =>
     );
 
     my %post = (
-        form    => 'guests.tx',
-        id      => 'uuid-alpha', title => 'alpha', state => 'running', is_active => 1,
-        preview => '/guest/screenshot/hv-1/alpha', domain => 'alpha',
-        hypervisor => 'hv-1', hypervisor_title => 'spec-hv', vcpus => 2,
-        addpost => 0, unreachable => 0,
+        form       => 'guests.tx',
+        id         => 'uuid-alpha',                   title            => 'alpha', state => 'running', is_active => 1,
+        preview    => '/guest/screenshot/hv-1/alpha', domain           => 'alpha',
+        hypervisor => 'hv-1',                         hypervisor_title => 'spec-hv', vcpus => 2,
+        addpost    => 0,                              unreachable      => 0,
     );
 
     foreach my $tiled ( 0, 1 ) {
         my $view = $tiled ? 'tiled' : 'untiled';
 
-        my $me = $tx->render( 'forms/guests.tx',
-            { post => { %post, is_self => 1 }, style => '', route => '/vm', tiled => $tiled, can_edit => 1 } );
-        my $them = $tx->render( 'forms/guests.tx',
-            { post => { %post, is_self => 0 }, style => '', route => '/vm', tiled => $tiled, can_edit => 1 } );
+        my $me = $tx->render(
+            'forms/guests.tx',
+            { post => { %post, is_self => 1 }, style => '', route => '/vm', tiled => $tiled, can_edit => 1 }
+        );
+        my $them = $tx->render(
+            'forms/guests.tx',
+            { post => { %post, is_self => 0 }, style => '', route => '/vm', tiled => $tiled, can_edit => 1 }
+        );
 
         # Said out loud, so an admin knows why this one is different.
         like( $me, qr/dom0/, "$view: the guest we are running in says so" );
@@ -400,8 +408,10 @@ subtest 'the server itself is drawn without the controls that would kill it' =>
     }
 
     # Only the untiled view draws controls at all.
-    my $me = $tx->render( 'forms/guests.tx',
-        { post => { %post, is_self => 1 }, style => '', route => '/vm', tiled => 0, can_edit => 1 } );
+    my $me = $tx->render(
+        'forms/guests.tx',
+        { post => { %post, is_self => 1 }, style => '', route => '/vm', tiled => 0, can_edit => 1 }
+    );
 
     foreach my $action (qw{poweroff destroy}) {
         is( scalar( () = $me =~ m/value="\Q$action\E"/g ), 0, "no $action button for the server itself" );
@@ -411,8 +421,10 @@ subtest 'the server itself is drawn without the controls that would kill it' =>
 
     # A guest that is merely switched off must keep its Power On button -- the
     # is_self guard wraps that branch too.
-    my $off = $tx->render( 'forms/guests.tx',
-        { post => { %post, is_self => 0, is_active => 0, state => 'shut off' }, style => '', route => '/vm', tiled => 0, can_edit => 1 } );
+    my $off = $tx->render(
+        'forms/guests.tx',
+        { post => { %post, is_self => 0, is_active => 0, state => 'shut off' }, style => '', route => '/vm', tiled => 0, can_edit => 1 }
+    );
     is( scalar( () = $off =~ m/value="poweron"/g ), 1, 'an ordinary stopped guest can still be started' );
 };
 
@@ -421,9 +433,9 @@ subtest 'a datasource says whether its posts can be edited' => sub {
 
     my $sources = Trog::Routes::HTML::_get_datasources();
     ok( ( grep { $_ eq 'Trog::DataSource::Virt' } @$sources ), 'the wizard can find this datasource' );
-    ok( !( grep { !m/^Trog::DataSource::\w+$/ } @$sources ), 'and finds nothing that is not one' );
+    ok( !( grep { !m/^Trog::DataSource::\w+$/ } @$sources ),   'and finds nothing that is not one' );
 
-    is( Trog::DataSource::Virt->EDITABLE, 0, 'a guest cannot be edited' );
+    is( Trog::DataSource::Virt->EDITABLE,                                   0, 'a guest cannot be edited' );
     is( Trog::Routes::HTML::_datasource_editable('Trog::DataSource::Virt'), 0, 'so no editor is appropriate' );
 
     # The datastore is the default, and posts in it are written by people.
@@ -440,15 +452,16 @@ subtest 'a datasource says whether its posts can be edited' => sub {
 };
 
 subtest 'the guests type is built by the wizard, from a datasource' => sub {
-    my $sidecar = JSON::MaybeXS::decode_json(
-        Path::Tiny->new("$FindBin::Bin/../www/templates/html/components/forms/guests.json")->slurp_utf8 );
+    my $sidecar = JSON::MaybeXS::decode_json( Path::Tiny->new("$FindBin::Bin/../www/templates/html/components/forms/guests.json")->slurp_utf8 );
 
     is( $sidecar->{'x-tcms-datasource'}, 'Trog::DataSource::Virt', 'it names its datasource' );
     ok( $sidecar->{'x-tcms-post-type'}{generated}, 'and is wizard generated rather than hand written' );
 
     # The relation is what tells the datasource which hypervisors to ask.
-    is_deeply( $sidecar->{'x-tcms-relations'}, { hypervisors => { form => 'hypervisor.tx' } },
-        'and keeps the relation the datasource reads' );
+    is_deeply(
+        $sidecar->{'x-tcms-relations'}, { hypervisors => { form => 'hypervisor.tx' } },
+        'and keeps the relation the datasource reads'
+    );
 
     # No editor: a guest is built on every view and has nothing to save.
     my $form = Path::Tiny->new("$FindBin::Bin/../www/templates/html/components/forms/guests.tx")->slurp_utf8;
@@ -458,8 +471,10 @@ subtest 'the guests type is built by the wizard, from a datasource' => sub {
 subtest 'the guests type declares its console capture private' => sub {
     require Trog::DataModule;
 
-    is_deeply( Trog::DataModule::private_fields_for('guests.tx'), ['preview'],
-        'so the url to it is withheld rather than guarded in the template' );
+    is_deeply(
+        Trog::DataModule::private_fields_for('guests.tx'), ['preview'],
+        'so the url to it is withheld rather than guarded in the template'
+    );
 };
 
 subtest 'private fields are dropped before a non-editor sees them' => sub {
@@ -478,16 +493,16 @@ subtest 'private fields are dropped before a non-editor sees them' => sub {
         # A relation is a post in its own right, with its own private fields.
         related => { form => 'secretive.tx', title => 'related', hidden => 'another secret' },
         many    => [ { form => 'secretive.tx', hidden => 'a third secret' } ],
-        other   => { form => 'ordinary.tx',   hidden => 'not declared private here' },
+        other   => { form => 'ordinary.tx', hidden => 'not declared private here' },
     };
 
     Trog::Routes::HTML::_redact_private($post);
 
-    ok( !exists $post->{hidden},              'the private field is gone' );
-    is( $post->{shown}, 'not a secret',       'and the public ones are not' );
-    is( $post->{title}, 'a post',             '...including the ones every post has' );
-    ok( !exists $post->{related}{hidden},     'a related post is redacted too' );
-    ok( !exists $post->{many}[0]{hidden},     'and so is one reached through a list' );
+    ok( !exists $post->{hidden}, 'the private field is gone' );
+    is( $post->{shown}, 'not a secret', 'and the public ones are not' );
+    is( $post->{title}, 'a post',       '...including the ones every post has' );
+    ok( !exists $post->{related}{hidden}, 'a related post is redacted too' );
+    ok( !exists $post->{many}[0]{hidden}, 'and so is one reached through a list' );
     is( $post->{other}{hidden}, 'not declared private here', 'a type that declares nothing keeps everything' );
 };
 
@@ -515,8 +530,7 @@ subtest 'a hypervisor does not show its connection uri to everyone' => sub {
     my $private = Trog::DataModule::private_fields_for('hypervisor.tx');
     is_deeply( $private, ['conn_uri'], 'the connection uri is declared private' );
 
-    my $sidecar = JSON::MaybeXS::decode_json(
-        Path::Tiny->new("$FindBin::Bin/../www/templates/html/components/forms/hypervisor.json")->slurp_utf8 );
+    my $sidecar = JSON::MaybeXS::decode_json( Path::Tiny->new("$FindBin::Bin/../www/templates/html/components/forms/hypervisor.json")->slurp_utf8 );
     ok( $sidecar->{properties}{conn_uri}{'x-tcms-private'}, 'and says so in its sidecar' );
 };
 

+ 83 - 85
t/Trog-Routes-HTML-series-lifecycle.t

@@ -18,15 +18,15 @@ use FindBin;
 use lib "$FindBin::Bin/../lib";
 
 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 Cwd           ();
+use Encode        ();
+use File::Copy    ();
+use File::Find    ();
+use File::Path    ();
+use File::Temp    ();
+use Time::HiRes   ();
+use URI::Escape   ();
+use JSON::MaybeXS ();
 
 our ( $REPO, $ROOT, $OLDCWD );
 our %REPO_BEFORE;
@@ -84,10 +84,11 @@ BEGIN {
 
     # Installer.mk's tree, plus upload-src for the file.tx fixture.
     File::Path::make_path(
-        map { "$ROOT/$_" } qw{
+        map { "$ROOT/$_" }
+          qw{
           config schema data/files logs totp upload-src
           www/assets/private www/statics www/themes www/scripts
-        }
+          }
     );
 
     # A real fresh install: get() looks for config/main.cfg, doesn't find one,
@@ -121,6 +122,7 @@ END {
         diag("TCMS_TEST_KEEP set, sandbox left at $ROOT");
     }
     elsif ( $ROOT && -d $ROOT ) {
+
         # SQLite handles are file-lexical in Trog::SQLite and unreachable from
         # here; DBI disconnects at global destruction, after these are gone.
         eval { File::Path::remove_tree($ROOT) };
@@ -144,6 +146,7 @@ require Trog::Routes::JSON;
 # A stand-in for the tPSGI object the router injects as $query->{tpsgi}.
 #--------------------------------------------------------------------------
 {
+
     package Test::TPSGI;
 
     sub new {
@@ -161,20 +164,20 @@ require Trog::Routes::JSON;
         }, $class;
     }
 
-    sub INFO  {1}
-    sub DEBUG {1}
-    sub WARN  {1}
-    sub ERROR {1}
-    sub CRIT  {1}
-    sub ALERT {1}
-    sub EMERG {1}
-    sub FATAL {1}
+    sub INFO  { 1 }
+    sub DEBUG { 1 }
+    sub WARN  { 1 }
+    sub ERROR { 1 }
+    sub CRIT  { 1 }
+    sub ALERT { 1 }
+    sub EMERG { 1 }
+    sub FATAL { 1 }
 
     sub see_also           { return [ 303, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
     sub redirect           { return [ 302, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
     sub redirect_permanent { return [ 301, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
 
-    sub _reply { return [ $_[1], [ 'Content-type' => 'text/html' ], [ defined $_[2] ? $_[2] : '' ] ] }
+    sub _reply     { return [ $_[1], [ 'Content-type' => 'text/html' ], [ defined $_[2] ? $_[2] : '' ] ] }
     sub ok         { return $_[0]->_reply( 200, $_[2] ) }
     sub notfound   { return $_[0]->_reply( 404, $_[2] // 'Not Found' ) }
     sub forbidden  { return $_[0]->_reply( 403, $_[2] // 'Forbidden' ) }
@@ -193,7 +196,7 @@ require Trog::Routes::JSON;
     # The real one is `kill 'HUP', getppid`.  Under prove, that is prove.
     sub signal_restart_parent { $_[0]{restarts}++; return 1 }
 
-    sub invalidate_renders { push @{ $_[0]{invalidated} }, $_[1]; return 1 }
+    sub invalidate_renders { push @{ $_[0]{invalidated} }, $_[1];              return 1 }
     sub invalidate_render  { push @{ $_[0]{invalidated} }, [ @_[ 1 .. $#_ ] ]; return 1 }
     sub save_render        { $_[0]{renders}{"$_[1]:$_[2]"} = $_[3]; return 1 }
 }
@@ -216,9 +219,9 @@ sub _query {
     my %q = (
         route        => '/',
         method       => 'GET',
-        scheme       => 'http',                          # Renderer::Base compares this with no undef guard
+        scheme       => 'http',                             # Renderer::Base compares this with no undef guard
         domain       => 'tcms.test',
-        start        => [ Time::HiRes::gettimeofday() ], # tv_interval() dies on anything else
+        start        => [ Time::HiRes::gettimeofday() ],    # tv_interval() dies on anything else
         deflate      => 0,
         streaming    => 0,
         ranges       => [],
@@ -246,7 +249,7 @@ sub _render {
     $how ||= \&Trog::Routes::HTML::index;
 
     my $res = eval { $how->($query) };
-    return ( 0, '', "died: $@" ) if !$res;
+    return ( 0, '', "died: $@" )                                      if !$res;
     return ( 0, '', 'returned a ' . ( ref($res) || 'plain scalar' ) ) if ref $res ne 'ARRAY';
 
     my ( $code, $headers, $body ) = @$res;
@@ -286,7 +289,7 @@ sub _post_count {
 # The rendered page is ~40KB and mostly JavaScript.  Show the content well.
 sub _kontent {
     my ($body) = @_;
-    my ($k) = $body =~ m{<div id="kontent" class="kontained">(.*?)<div id="rightbar"}s;
+    my ($k)    = $body =~ m{<div id="kontent" class="kontained">(.*?)<div id="rightbar"}s;
     $k //= $body;
     $k =~ s/<script\b.*?<\/script>//gs;
     return length($k) > 2500 ? substr( $k, 0, 2500 ) . "\n...[truncated]" : $k;
@@ -328,10 +331,9 @@ sub _save_post {
     return $saved;
 }
 
-
-
 sub _find_post {
     my ($title) = @_;
+
     # filter() short-circuits on title; the admin acl skips the visibility filter.
     my @posts = _data()->get( title => $title, acls => ['admin'], limit => 0 );
     return $posts[0];
@@ -341,7 +343,7 @@ sub _find_post {
 
 subtest 'the sandbox is what we are actually running against' => sub {
     is( Cwd::getcwd(), Cwd::abs_path($ROOT), 'cwd is the sandbox' );
-    ok( -d 'data/files',  'datastore dir exists' );
+    ok( -d 'data/files',         'datastore dir exists' );
     ok( -f 'config/default.cfg', 'config was seeded' );
     ok( !-f 'config/main.cfg',   'and there is no main.cfg, so we fall through to the default' );
 
@@ -400,9 +402,7 @@ subtest 'the post wizard invents a new post type' => sub {
         param_label       => ['Flavor'],
         param_placeholder => ['Strawberry'],
         param_required    => [0],
-        display           => q{<div class="postData responsive-text" id="postData-<: $post.id :>">}
-          . q{<span class="spec-flavor"><: $post.flavor :></span>}
-          . q{<: render_it($post.data) | mark_raw :></div>},
+        display           => q{<div class="postData responsive-text" id="postData-<: $post.id :>">} . q{<span class="spec-flavor"><: $post.flavor :></span>} . q{<: render_it($post.data) | mark_raw :></div>},
     );
 
     my ( $code, $body, $err ) = _render(
@@ -448,8 +448,8 @@ subtest 'the post wizard invents a new post type' => sub {
         unlike( $body, qr/name="\Q$gone\E"/, "the wizard no longer offers '$gone' as a choice" );
     }
 
-    like( $body, qr/name="param_private"/, 'and it offers per-field privacy' );
-    like( $body, qr/name="datasource"/,    'and a datasource to draw the posts from' );
+    like( $body, qr/name="param_private"/,   'and it offers per-field privacy' );
+    like( $body, qr/name="datasource"/,      'and a datasource to draw the posts from' );
     like( $body, qr/Trog::DataSource::Virt/, 'listing the ones that exist' );
 };
 
@@ -478,8 +478,7 @@ subtest 'a datasource-backed type gets no editor' => sub {
     unlike( $generated, qr/\$can_edit/,          'and nothing guards one' );
     like( $generated, qr/class="s"/, 'but the display half is there' );
 
-    my $sidecar = JSON::MaybeXS::decode_json(
-        Path::Tiny->new('www/templates/html/components/forms/spec_sourced.json')->slurp_utf8 );
+    my $sidecar = JSON::MaybeXS::decode_json( Path::Tiny->new('www/templates/html/components/forms/spec_sourced.json')->slurp_utf8 );
     is( $sidecar->{'x-tcms-datasource'}, 'Trog::DataSource::Virt', 'and the sidecar records the datasource' );
 
     # The same type without one keeps its editor.
@@ -510,21 +509,21 @@ subtest 'a datasource-backed type gets no editor' => sub {
 subtest 'a field can be declared editors-only' => sub {
     my ( $code, $body, $err ) = _render(
         _admin(
-            route             => '/admin/wyzzerdd/save',
-            method            => 'POST',
-            name              => 'spec_secretive',
-            body_form         => 'form_common.tx',
-            wrapper           => 1,
-            inc_post_title    => 1,
-            inc_tags          => 1,
-            param_name        => [ 'shown',            'hidden' ],
-            param_type        => [ 'text',             'text' ],
-            param_label       => [ 'Shown',            'Hidden' ],
-            param_placeholder => [ '',                 '' ],
-            param_required    => [ 0,                  0 ],
-            param_private     => [ 0,                  1 ],
-            param_relation_form => [ 'blog.tx',        'blog.tx' ],
-            param_relation_mode => [ 'one',            'one' ],
+            route               => '/admin/wyzzerdd/save',
+            method              => 'POST',
+            name                => 'spec_secretive',
+            body_form           => 'form_common.tx',
+            wrapper             => 1,
+            inc_post_title      => 1,
+            inc_tags            => 1,
+            param_name          => [ 'shown',   'hidden' ],
+            param_type          => [ 'text',    'text' ],
+            param_label         => [ 'Shown',   'Hidden' ],
+            param_placeholder   => [ '',        '' ],
+            param_required      => [ 0,         0 ],
+            param_private       => [ 0,         1 ],
+            param_relation_form => [ 'blog.tx', 'blog.tx' ],
+            param_relation_mode => [ 'one',     'one' ],
 
             # Deliberately unguarded: declaring the field private is supposed
             # to be enough, so an author does not have to remember.
@@ -534,9 +533,8 @@ subtest 'a field can be declared editors-only' => sub {
     );
     is( $code, 200, 'the type was created' ) or diag($err);
 
-    my $sidecar = JSON::MaybeXS::decode_json(
-        Path::Tiny->new('www/templates/html/components/forms/spec_secretive.json')->slurp_utf8 );
-    ok( $sidecar->{properties}{hidden}{'x-tcms-private'},   'the private field is marked so' );
+    my $sidecar = JSON::MaybeXS::decode_json( Path::Tiny->new('www/templates/html/components/forms/spec_secretive.json')->slurp_utf8 );
+    ok( $sidecar->{properties}{hidden}{'x-tcms-private'},        'the private field is marked so' );
     ok( !exists $sidecar->{properties}{shown}{'x-tcms-private'}, 'and a public one carries no flag at all' );
 
     _reindex();
@@ -592,8 +590,8 @@ sub _make_series {
         "$label series",
         form       => 'series.tx',
         title      => $title,
-        aclname    => $aclname,       # required by series.json
-        child_form => $child_form,    # required by series.json
+        aclname    => $aclname,                       # required by series.json
+        child_form => $child_form,                    # required by series.json
         local_href => "/$aclname",
         href       => "/$aclname",
         data       => "$title subhead",
@@ -692,11 +690,11 @@ subtest 'blog' => sub {
 
     my $body = _series_page( 'blog', 'specblog', $title, 1 ) or return;
 
-    like( $body, qr/Spec Blog Child/,                  'child title rendered' );
-    like( $body, qr{href='/posts/\Q$child->{id}\E'},   'child permalink rendered' );
-    like( $body, qr{id="postData-\Q$child->{id}\E"},   'child body block rendered' );
-    like( $body, qr/Spec blog body text\./,            'child body text rendered' );
-    unlike( $body, qr/Spec Payee Entity/,              'no bleed from the entities series' );
+    like( $body, qr/Spec Blog Child/,                'child title rendered' );
+    like( $body, qr{href='/posts/\Q$child->{id}\E'}, 'child permalink rendered' );
+    like( $body, qr{id="postData-\Q$child->{id}\E"}, 'child body block rendered' );
+    like( $body, qr/Spec blog body text\./,          'child body text rendered' );
+    unlike( $body, qr/Spec Payee Entity/, 'no bleed from the entities series' );
 };
 
 subtest 'microblog' => sub {
@@ -717,8 +715,8 @@ subtest 'microblog' => sub {
     my $body = _series_page( 'microblog', 'specmicroblog', $title, 1 ) or return;
 
     like( $body, qr{href='https://example\.com/spec' >Spec Microblog Child</a>}, 'title links out to href' );
-    like( $body, qr{id="postData-\Q$child->{id}\E"}, 'body block rendered' );
-    like( $body, qr/Spec microblog body\./,          'body text rendered' );
+    like( $body, qr{id="postData-\Q$child->{id}\E"},                             'body block rendered' );
+    like( $body, qr/Spec microblog body\./,                                      'body text rendered' );
 };
 
 subtest 'file' => sub {
@@ -742,14 +740,14 @@ subtest 'file' => sub {
         to         => '/specfile',
     ) or return;
 
-    ok( !-e $src, 'the upload was moved out of its temp location, not copied' );
+    ok( !-e $src,                                     'the upload was moved out of its temp location, not copied' );
     ok( -f "www/assets/$child->{id}.spec-upload.txt", 'and it landed in www/assets' );
 
     my $body = _series_page( 'file', 'specfile', $title, 1 ) or return;
 
     like( $body, qr{href='/assets/\Q$child->{id}\E\.spec-upload\.txt'}, 'title links to the asset' );
-    like( $body, qr{id="postData-\Q$child->{id}\E"}, 'body block carries a unique id, like every other form' );
-    like( $body, qr/Spec file body\./, 'body text rendered' );
+    like( $body, qr{id="postData-\Q$child->{id}\E"},                    'body block carries a unique id, like every other form' );
+    like( $body, qr/Spec file body\./,                                  'body text rendered' );
 
     # This form used to emit <div class="postData" id="postData" class="responsive-text">
     # -- a duplicated class attribute, and an id shared by every file post on
@@ -842,7 +840,7 @@ subtest 'spec_widget (the wizard-built type)' => sub {
     # schema_for merged it over the base post schema, and validate() therefore
     # kept 'flavor' instead of deleting it as an unknown key.
     like( $body, qr{<span class="spec-flavor">Strawberry</span>}, 'the custom field rendered on the page' );
-    like( $body, qr/Spec widget body\./, 'and the body came through the generated template' );
+    like( $body, qr/Spec widget body\./,                          'and the body came through the generated template' );
 };
 
 subtest 'a wizard-built type can depend on another type' => sub {
@@ -879,25 +877,23 @@ subtest 'a wizard-built type can depend on another type' => sub {
             inc_title_input     => 1,
             inc_visibility      => 1,
             inc_tags            => 1,
-            param_name          => [ 'chosen',       'everything' ],
-            param_type          => [ 'relation',     'relation' ],
-            param_label         => [ 'Chosen One',   'All Of Them' ],
-            param_placeholder   => [ '',             '' ],
-            param_required      => [ 0,              0 ],
+            param_name          => [ 'chosen',         'everything' ],
+            param_type          => [ 'relation',       'relation' ],
+            param_label         => [ 'Chosen One',     'All Of Them' ],
+            param_placeholder   => [ '',               '' ],
+            param_required      => [ 0,                0 ],
             param_relation_form => [ 'spec_target.tx', 'spec_target.tx' ],
-            param_relation_mode => [ 'one',          'all' ],
-            display             => q{<div class="rel"><span class="chosen"><: $post.chosen_post.title :></span>}
-              . q{<: for $post.everything -> $t { :><span class="each"><: $t.title :></span><: } :></div>},
+            param_relation_mode => [ 'one',            'all' ],
+            display             => q{<div class="rel"><span class="chosen"><: $post.chosen_post.title :></span>} . q{<: for $post.everything -> $t { :><span class="each"><: $t.title :></span><: } :></div>},
         ),
         \&Trog::Routes::HTML::post_wizard_save,
     );
     is( $code, 200, 'relating type created' ) or diag($err);
 
-    my $sidecar = JSON::MaybeXS::decode_json(
-        Path::Tiny->new('www/templates/html/components/forms/spec_relator.json')->slurp_utf8 );
+    my $sidecar = JSON::MaybeXS::decode_json( Path::Tiny->new('www/templates/html/components/forms/spec_relator.json')->slurp_utf8 );
 
     # 'one' is a field the post stores; 'all' is not a field at all.
-    is( $sidecar->{properties}{chosen}{type}, 'relation', 'the picked relation is a stored property' );
+    is( $sidecar->{properties}{chosen}{type},                   'relation',       'the picked relation is a stored property' );
     is( $sidecar->{properties}{chosen}{'x-tcms-relation-form'}, 'spec_target.tx', 'naming its target type' );
     ok( !exists $sidecar->{properties}{everything}, "the 'all' relation stores nothing" );
 
@@ -912,8 +908,10 @@ subtest 'a wizard-built type can depend on another type' => sub {
 
     # The relation pseudo-type has to become a real one before validation, or
     # every relation field would be stripped as an unknown type.
-    is( Trog::DataModule::schema_for('spec_relator.tx')->{properties}{chosen}{type},
-        'string', "'relation' expands to a real schema type" );
+    is(
+        Trog::DataModule::schema_for('spec_relator.tx')->{properties}{chosen}{type},
+        'string', "'relation' expands to a real schema type"
+    );
 
     _reindex();
 
@@ -969,15 +967,15 @@ subtest '/api/posts_of_form feeds the relation picker' => sub {
 
     # An unknown type is an empty list, not an error -- a type with no posts
     # yet is the normal state of affairs right after you create it.
-    $res = Trog::Routes::JSON::posts_of_form( _admin( route => '/api/posts_of_form', form => 'nosuchtype.tx' ) );
+    $res     = Trog::Routes::JSON::posts_of_form( _admin( route => '/api/posts_of_form', form => 'nosuchtype.tx' ) );
     $payload = JSON::MaybeXS::decode_json( join( '', @{ $res->[2] } ) );
     is_deeply( $payload->{posts}, [], 'an unknown type lists nothing rather than failing' );
 
     # The route's own declaration is what keeps a malformed form out; check it
     # matches what series.json demands of child_form.
     my $validator = $Trog::Routes::JSON::routes{'/api/posts_of_form'}{parameters}{form};
-    ok( $validator->('blog.tx'), 'the parameter validator accepts a form name' );
-    ok( !$validator->('../../etc/passwd'), 'and rejects a path' );
+    ok( $validator->('blog.tx'),                                 'the parameter validator accepts a form name' );
+    ok( !$validator->('../../etc/passwd'),                       'and rejects a path' );
     ok( $Trog::Routes::JSON::routes{'/api/posts_of_form'}{auth}, 'the route requires a login' );
 };
 
@@ -1031,7 +1029,7 @@ subtest 'saves report back through the jsalert banner' => sub {
         \&Trog::Routes::HTML::series,
     );
     is( $rcode, 200, 'the destination renders' ) or diag($err);
-    like( $body, qr/var loginFailure = 0;/,               'the banner is in success mode' );
+    like( $body, qr/var loginFailure = 0;/,                      'the banner is in success mode' );
     like( $body, qr/Saved post &#39;Spec Feedback Child&#39;\./, 'and says what was saved' );
 
     # Nothing to navigate on to, so the banner must not bounce us anywhere.
@@ -1052,8 +1050,8 @@ subtest 'saves report back through the jsalert banner' => sub {
     ( $code, $headers ) = @$res;
     %h = @{ $headers || [] };
     is( $code, 303, 'a rejected save redirects too, rather than dead-ending on a 400' );
-    like( $h{Location}, qr{^/secure/specblog\?savefailed=}, 'flagged as failed' );
-    like( URI::Escape::uri_unescape( $h{Location} ), qr/Not in enum list/, 'carrying the validator error' );
+    like( $h{Location},                              qr{^/secure/specblog\?savefailed=}, 'flagged as failed' );
+    like( URI::Escape::uri_unescape( $h{Location} ), qr/Not in enum list/,               'carrying the validator error' );
 
     ok( !_find_post('Spec Rejected Child'), 'and the bad post was not written' );
 

+ 18 - 18
t/Trog-SQLite.t

@@ -13,44 +13,44 @@ require_ok('Trog::SQLite') or BAIL_OUT("Can't find SUT");
 
 subtest 'dbh' => sub {
     my $readmock = Test::MockModule->new('File::Slurper');
-    $readmock->redefine('read_text', sub { "SELECT me FROM candidates" });
+    $readmock->redefine( 'read_text', sub { "SELECT me FROM candidates" } );
     my $dbimock = Test::MockModule->new("DBI");
-    $dbimock->redefine('connect', sub { bless({},'TrogDBD') });
+    $dbimock->redefine( 'connect', sub { bless( {}, 'TrogDBD' ) } );
 
     my $works = 0;
     no warnings qw{redefine once};
-    local *TrogDBD::do = sub { $works };
+    local *TrogDBD::do     = sub { $works };
     local *TrogDBD::errstr = sub { 'bogus' };
 
-    like(exception { Trog::SQLite::dbh('bogus','bogus') }, qr/ensure/i, "Failure to enforce schema throws");
+    like( exception { Trog::SQLite::dbh( 'bogus', 'bogus' ) }, qr/ensure/i, "Failure to enforce schema throws" );
     $works = 1;
 
     # Otherwise it works
-    isa_ok(Trog::SQLite::dbh('bogus','bogus'),'TrogDBD');
+    isa_ok( Trog::SQLite::dbh( 'bogus', 'bogus' ), 'TrogDBD' );
     unlink 'bogus';
 };
 
 subtest bulk_insert => sub {
-    like(exception { Trog::SQLite::bulk_insert({},'bogus', [qw{a b c}], 'PROCASTINATE') }, qr/unsupported/i, "insert OR keyword consistency enforced");
-    like(exception { Trog::SQLite::bulk_insert({},'bogus', []) }, qr/nonempty/, "keys must be provided");
-    like(exception { Trog::SQLite::bulk_insert({},'bogus',[qw{a b c}],'IGNORE',qw{jello}) }, qr/multiple of/i, "sufficient values must be provided");
+    like( exception { Trog::SQLite::bulk_insert( {}, 'bogus', [qw{a b c}], 'PROCASTINATE' ) },      qr/unsupported/i, "insert OR keyword consistency enforced" );
+    like( exception { Trog::SQLite::bulk_insert( {}, 'bogus', [] ) },                               qr/nonempty/,     "keys must be provided" );
+    like( exception { Trog::SQLite::bulk_insert( {}, 'bogus', [qw{a b c}], 'IGNORE', qw{jello} ) }, qr/multiple of/i, "sufficient values must be provided" );
 
     my $smt;
-    my $dbh = bless({},'TrogDBH');
+    my $dbh = bless( {}, 'TrogDBH' );
     no warnings qw{redefine once};
-    local *TrogDBH::prepare = sub { $smt .= $_[1]; return bless({},'TrogSMT') };
-    local *TrogSMT::execute = sub {};
+    local *TrogDBH::prepare = sub { $smt .= $_[1]; return bless( {}, 'TrogSMT' ) };
+    local *TrogSMT::execute = sub { };
 
-    is(exception { Trog::SQLite::bulk_insert($dbh,'bogus', [qw{moo cows}], 'IGNORE', qw{a b c d}) }, undef, "can do bulk insert");
-    is($smt, "INSERT OR IGNORE INTO bogus (moo,cows) VALUES (?,?),(?,?)", "Expected query prepared");
+    is( exception { Trog::SQLite::bulk_insert( $dbh, 'bogus', [qw{moo cows}], 'IGNORE', qw{a b c d} ) }, undef,                                                       "can do bulk insert" );
+    is( $smt,                                                                                            "INSERT OR IGNORE INTO bogus (moo,cows) VALUES (?,?),(?,?)", "Expected query prepared" );
 
     # Million insert
-    $smt='';
-    my $keys = [("a") x 10];
-    my @values = ("b") x (10**6);
-    Trog::SQLite::bulk_insert($dbh,'bogus', $keys, 'IGNORE', @values);
+    $smt = '';
+    my $keys   = [ ("a") x 10 ];
+    my @values = ("b") x ( 10**6 );
+    Trog::SQLite::bulk_insert( $dbh, 'bogus', $keys, 'IGNORE', @values );
     my $expected = "INSERT OR IGNORE INTO bogus (a,a,a,a,a,a,a,a,a,a) VALUES (?,?,?,?,?,?,?,?,?,?),(?,?,?,?,?,?,?,?,?,?),(?,?,?,?,?,?,?,?,?,?),(?,?,?,?,?,?,?,?,?,?),(?,?,?,?,?,?,?,?,?,?),(?,?,?,?,?,?,?,?,?,?),(?,?,?,?,?,?,?,?,?,?),(?,?,?,?,?,?,?,?,?,?),(?,?,?,?,?,?,?,?,?,?)INSERT OR IGNORE INTO bogus (a,a,a,a,a,a,a,a,a,a) VALUES (?,?,?,?,?,?,?,?,?,?)";
-    is($smt,$expected, "As expected, only two statements are necessary to be prepared, no matter how many rows to insert.");
+    is( $smt, $expected, "As expected, only two statements are necessary to be prepared, no matter how many rows to insert." );
 };
 
 done_testing;

+ 16 - 10
t/Trog-Themes-themed-templates.t

@@ -16,7 +16,7 @@ my $stock = $root->child('www/templates/html/components/forms');
 my $theme = $root->child('www/themes/spec/templates/html/components/forms');
 $_->mkpath foreach ( $stock, $theme );
 
-$stock->child($_)->spew_utf8("stock $_") foreach qw{blog.tx series.tx profile.tx blog.json series.json};
+$stock->child($_)->spew_utf8("stock $_")  foreach qw{blog.tx series.tx profile.tx blog.json series.json};
 $theme->child($_)->spew_utf8("themed $_") foreach qw{blog.tx gallery.tx blog.json};
 
 my $themedir = '';
@@ -40,7 +40,7 @@ subtest 'with no theme, nothing changes' => sub {
 
     my $old = [ sort @{ Trog::Themes::templates_in_dir( 'forms', 'text/html', 1 ) } ];
     my $new = [ sort @{ Trog::Themes::themed_templates_in_dir( 'forms', 'text/html', 1 ) } ];
-    is_deeply( $new, $old, "the themed helper agrees with the old one" );
+    is_deeply( $new, $old,                               "the themed helper agrees with the old one" );
     is_deeply( $new, [qw{blog.tx profile.tx series.tx}], "...and lists the stock templates" );
 };
 
@@ -68,19 +68,25 @@ subtest 'with a partial theme, the two disagree' => sub {
     );
 
     my $listed = Trog::Themes::themed_templates_in_dir( 'forms', 'text/html', 1 );
-    is( scalar( grep { $_ eq 'blog.tx' } @$listed ), 1, "an overridden template is listed once, not twice" );
-    is( $listed->[0], 'blog.tx', "and the theme's copies come first" );
+    is( scalar( grep { $_ eq 'blog.tx' } @$listed ), 1,         "an overridden template is listed once, not twice" );
+    is( $listed->[0],                                'blog.tx', "and the theme's copies come first" );
 };
 
 subtest 'themed_file_in_dir prefers the theme, falls back to stock' => sub {
     $themedir = "$root/www/themes/spec";
 
-    is( Trog::Themes::themed_file_in_dir( 'forms', 'blog.json', 'text/html', 1 ),
-        "$theme/blog.json", "the theme's copy wins" );
-    is( Trog::Themes::themed_file_in_dir( 'forms', 'series.json', 'text/html', 1 ),
-        "$stock/series.json", "one the theme lacks falls back" );
-    is( Trog::Themes::themed_file_in_dir( 'forms', 'nope.json', 'text/html', 1 ),
-        undef, "and one nobody has is undef, not a path that doesn't exist" );
+    is(
+        Trog::Themes::themed_file_in_dir( 'forms', 'blog.json', 'text/html', 1 ),
+        "$theme/blog.json", "the theme's copy wins"
+    );
+    is(
+        Trog::Themes::themed_file_in_dir( 'forms', 'series.json', 'text/html', 1 ),
+        "$stock/series.json", "one the theme lacks falls back"
+    );
+    is(
+        Trog::Themes::themed_file_in_dir( 'forms', 'nope.json', 'text/html', 1 ),
+        undef, "and one nobody has is undef, not a path that doesn't exist"
+    );
 };
 
 subtest 'an empty or missing dir is not fatal' => sub {