Merge pull request #369 from Troglodyne-Internet-Widgets/policies-three

Fix the footers README link and the log parser's classes, and enable two policies

.perlcriticrc

@@ -227,7 +227,7 @@ stop_words_file = .pod_stopwords
 # name on its own, so these are the parts.
 package_exemptions = main tcms login useradd blob css email html javascript json text
 [RegularExpressions::ProhibitCaptureWithoutTest]
-#[RegularExpressions::ProhibitComplexRegexes]
+[RegularExpressions::ProhibitComplexRegexes]
 [RegularExpressions::ProhibitEnumeratedClasses]
 [RegularExpressions::ProhibitFixedStringMatches]
 [RegularExpressions::ProhibitSingleCharAlternation]
@@ -236,7 +236,11 @@ package_exemptions = main tcms login useradd blob css email html javascript json
 [RegularExpressions::RequireDotMatchAnything]
 [RegularExpressions::RequireExtendedFormatting]
 [Subroutines::ProhibitAmpersandSigils]
-#[Subroutines::ProhibitBuiltinHomonyms]
+[Subroutines::ProhibitBuiltinHomonyms]
+# tCMS: read, write and delete are methods of every data model.  index is the
+# route that every page ends in, which a theme's routes call by that name.
+# shutdown is a method of Sys::Virt::Domain, which a test fakes.
+allow = read write delete index shutdown
 [Subroutines::ProhibitManyArgs]
 [Subroutines::ProhibitNestedSubs]
 [Subroutines::ProhibitReturnSort]

lib/Trog/Log/DBI.pm

@@ -67,6 +67,18 @@ sub create_statement {
 
 my %buffer;
 
+# A line as Trog::Log formats it: the time, the level, who asked, and what
+# happened.
+my $STAMP   = qr/[\w:-]+/;
+my $REQUEST = qr/[\w-]+/;
+my $ADDRESS = qr/[\w.:]+/;
+my $WHO     = qr/RequestId[ ]($REQUEST)[ ]From[ ]($ADDRESS)[ ]\|(\w+)\|/;
+my $LINE    = qr/\A($STAMP)[ ]\[(\w+)\]:[ ]$WHO[ ](\N+)/;
+
+# What happened, when that is a request that was served: the method, the
+# code, the bytes, and the route.
+my $SERVED = qr/\A(\w+)[ ](\d+)[ ](\d+)[ ](\N+)/;
+
 =head2 log_message(HASH params) = MIXED
 
 Record one log line.
@@ -80,26 +92,17 @@ A write that fails is a warning on stderr, and never dies.
 sub log_message {
     my ( $self, %params ) = @_;
 
-    # Rip apart the message.  If it's got any extended info, lets grab that too.
-    my $msg = $params{message};
-    my $message;
-    my ( $date, $uuid, $ip, $user, $method, $code, undef, $route ) = $msg =~ m!^([\w|\-|:]+)[ ]\[INFO\]:[ ]RequestId[ ]([\w|\-]+)[ ]From[ ]([\w|\.|:]+)[ ]\|(\w+)\|[ ](\w+)[ ](\d+)[ ](\d+)[ ](\N+)!;
+    my ( $date, $level, $uuid, $ip, $user, $message ) = $params{message} =~ $LINE;
+    return unless $uuid;
 
-    # Otherwise, let's mark it down in the "messages" table.  This will be deferred until the final write.
-    if ( !$date ) {
-        ( $date, $uuid, $ip, $user, $message ) = $msg =~ m!^([\w|\-|:]+)[ ]\[\w+\]:[ ]RequestId[ ]([\w|\-]+)[ ]From[ ]([\w|\.|:]+)[ ]\|(\w+)\|[ ](\N+)!;
+    my ( $method, $code, undef, $route ) = $level eq 'INFO' ? $message =~ $SERVED : ();
 
-        # If we can't figure out its request, ignore the message
-        if ($uuid) {
-            $buffer{$uuid} //= [];
-            push( @{ $buffer{$uuid} }, $message );
-        }
+    # Anything else goes in the "messages" table, once its request is written.
+    if ( !defined $method ) {
+        push( @{ $buffer{$uuid} }, $message );
         return 1;
     }
 
-    # If this is a mangled log, forget it.
-    return unless $date && $uuid;
-
     # 2024-01-20T22:37:41Z
     # Transform the date into an epoch so we can do math on it
     my $fmt     = "%Y-%m-%dT%H:%M:%SZ";

t/Trog-Log-DBI.t

@@ -41,7 +41,26 @@ subtest 'a write the database refuses is a warning, not a die' => sub {
 
     is( $died, undef, 'the caller of the log does not die' );
     is( $res,  undef, 'the write reports that it failed' );
-    like( $stderr, qr/Could[ ]not[ ]record[ ]request[ ]r-2[ ]in[ ]the[ ]metrics[ ]database:[ ]\N*refused[ ]for[ ]the[ ]test/, 'and says why on stderr' );
+    my $why = 'Could not record request r-2 in the metrics database: ';
+    like( $stderr, qr/\Q$why\E\N*refused[ ]for[ ]the[ ]test/, 'and says why on stderr' );
+};
+
+subtest 'a message waits for the line of its request' => sub {
+    is( $output->log_message( message => "2026-09-29T12:00:01Z [WARN]: RequestId r-3 From 192.0.2.1 |nobody| a thing went sideways\n" ), 1, 'the message is buffered' );
+    my ($early) = $dbh->selectrow_array("SELECT count(*) FROM messages WHERE uuid='r-3'");
+    is( $early, 0, 'and not written before its request' );
+
+    ok( $output->log_message( message => $line =~ s/r-1/r-3/r ), 'the request line is written' );
+    my $messages = $dbh->selectcol_arrayref("SELECT message FROM messages WHERE uuid='r-3'");
+    is_deeply( $messages, ['a thing went sideways'], 'and the message with it' );
+};
+
+subtest 'a line that names no request is dropped' => sub {
+    is( $output->log_message( message => "not a log line at all\n" ), undef, 'text that is not a log line' );
+    is( $output->log_message( message => $line =~ s/r-1/r|4/r ),                  undef, 'a request id with a pipe in it' );
+    is( $output->log_message( message => $line =~ s/192\.0\.2\.1/192.0.2.1|x/r ), undef, 'an address with a pipe in it' );
+    my ($count) = $dbh->selectrow_array("SELECT count(*) FROM all_requests WHERE uuid LIKE 'r|%' OR ip_address LIKE '%|%'");
+    is( $count, 0, 'and none of them is a row' );
 };
 
 done_testing();

t/Trog-Log-Syslog.t

@@ -37,9 +37,10 @@ subtest 'a line arrives as the syslog of this machine reads it' => sub {
     my $got = received();
 
     # daemon is facility 3 and info is severity 6, so the priority is 3*8+6.
-    like( $got, qr/^<30>/,                                                                                                                   'as daemon.info' );
-    like( $got, qr/\btcms\[$$\]:[ ]/,                                                                                                        'tagged with the program name and the pid' );
-    like( $got, qr/:[ ]2026-09-29T12:00:00Z[ ]\[INFO\]:[ ]RequestId[ ]x[ ]From[ ]192\.0\.2\.1[ ]\|nobody\|[ ]Failed[ ]login[ ]for[ ]user\z/, 'with the line that the file gets, and no newline' );
+    like( $got, qr/^<30>/,            'as daemon.info' );
+    like( $got, qr/\btcms\[$$\]:[ ]/, 'tagged with the program name and the pid' );
+    my $line = ': 2026-09-29T12:00:00Z [INFO]: RequestId x From 192.0.2.1 |nobody| Failed login for user';
+    like( $got, qr/\Q$line\E\z/, 'with the line that the file gets, and no newline' );
 };
 
 subtest 'each level keeps its severity' => sub {

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

@@ -339,7 +339,9 @@ my sub post_count {
 # The rendered page is ~40KB and mostly JavaScript.  Show the content well.
 my sub kontent {
     my ($body) = @_;
-    my ($k)    = $body =~ m{<div[ ]id="kontent"[ ]class="kontained">(.*?)<div[ ]id="rightbar"}s;
+    state $from = qr{<div[ ]id="kontent"[ ]class="kontained">};
+    state $to   = qr{<div[ ]id="rightbar"};
+    my ($k) = $body =~ m{$from(.*?)$to}s;
     $k //= $body;
     $k =~ s/<script\b.*?<\/script>//gs;
     return length($k) > 2500 ? substr( $k, 0, 2500 ) . "\n...[truncated]" : $k;
@@ -1134,9 +1136,10 @@ 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' );
+    my $link = q{href='https://example.com/spec' >Spec Microblog Child</a>};
+    like( $body, qr{\Q$link\E},                      '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' );
 };
 
 subtest 'file' => sub {
@@ -1199,7 +1202,8 @@ subtest 'presentation' => sub {
     my $body = series_page( 'presentation', 'specpresentation', $title, 1 ) or return;
 
     # Slides only render under nochrome; the series page just links to the deck.
-    like( $body, qr{<a[ ]href="/posts/\Q$child->{id}\E\?embed=1&nochrome=1">Click[ ]Here[ ]to[ ]view</a>}, 'deck link rendered' );
+    my $deck = qq{<a href="/posts/$child->{id}?embed=1&nochrome=1">Click Here to view</a>};
+    like( $body, qr{\Q$deck\E}, 'deck link rendered' );
     unlike( $body, qr/Slide[ ]one[ ]body\./, 'slides themselves are not rendered inline' );
 };
 

t/bin-migrate.t

@@ -130,8 +130,9 @@ subtest 'a dry run writes nothing' => sub {
 subtest 'the migration itself' => sub {
     my ( $rc, $out ) = migrate();
     is( $rc, 0, 'it succeeds' ) or diag($out);
-    like( $out, qr/Carried[ ]over[ ]6[ ]post[ ]version\(s\),[ ]skipped[ ]0/,                                'carrying over every version' );
-    like( $out, qr/data\/files[ ]holds[ ]6[ ]post[ ]version\(s\);[ ]data\/posts\.sqlite[ ]now[ ]holds[ ]6/, 'and says what actually landed' );
+    like( $out, qr/Carried[ ]over[ ]6[ ]post[ ]version\(s\),[ ]skipped[ ]0/, 'carrying over every version' );
+    my $landed = 'data/files holds 6 post version(s); data/posts.sqlite now holds 6';
+    like( $out, qr/\Q$landed\E/, 'and says what actually landed' );
 
     is( $sqlite->count(), 4, 'four posts' );
 

www/templates/html/components/footers/README.md

@@ -1 +1 @@
-www/templates/headers/README.md
+../headers/README.md