tCMS/t/Trog-Log-Syslog.t

#!/usr/bin/env perl
use 5.040;
use re '/aasx';
use warnings FATAL => 'all';

use Test::More;
use Test::NoWarnings;
use Test::Fatal qw{exception};
use File::Temp  qw{tempdir};
use IO::Socket::UNIX;
use Socket qw{SOCK_DGRAM};
use Log::Dispatch;

use FindBin::libs;

require_ok('Trog::Log::Syslog') or BAIL_OUT("Can't find SUT");

# A datagram socket in a temporary directory stands in for /dev/log, which is
# a datagram socket too.
my $dir  = tempdir( CLEANUP => 1 );
my $path = "$dir/log";
my $sink = IO::Socket::UNIX->new( Type => SOCK_DGRAM, Local => $path ) or die "Cannot listen on $path: $!";

sub received {
    my $got = '';
    $sink->recv( $got, 65536 );
    return $got;
}

# What tPSGI passes to every logger that its configuration names.
my $output = Trog::Log::Syslog->new( min_level => 'info', log_dir => $dir, socket => $path );
my $log    = Log::Dispatch->new();
$log->add($output);

subtest 'a line arrives as the syslog of this machine reads it' => sub {
    $log->info("2026-09-29T12:00:00Z [INFO]: RequestId x From 192.0.2.1 |nobody| Failed login for user\n");
    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' );
    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 {
    my %severity = ( info => 6, notice => 5, warning => 4, error => 3, critical => 2, alert => 1, emergency => 0 );
    foreach my $level ( sort keys %severity ) {
        $log->log( level => $level, message => "at $level" );
        my $priority = 24 + $severity{$level};    # the daemon facility, 3, times 8
        like( received(), qr/^<$priority>\N*:[ ]at[ ]$level$/, "$level is severity $severity{$level}" );
    }
};

subtest 'nothing below the level goes out' => sub {
    $log->debug('too quiet');
    $log->info('loud enough');
    like( received(), qr/loud[ ]enough$/, 'the debug line was not sent' );
};

subtest 'a syslog that went away does not take the application with it' => sub {
    close($sink) or die $!;
    unlink($path);

    # The file output still has the line, and a request that fails because
    # its log line did not arrive is worse than a line that did not arrive.
    is( exception { $log->warning('into the void') }, undef, 'logging to a missing socket does not die' );
};

subtest 'log_init adds the loggers that tpsgi.ini names' => sub {
    require Trog::Log;

    # A stand-in, so that this test does not write to the syslog of the
    # machine that runs it.
    {

        package Test::Capture;
        use parent -norequire, qw{Log::Dispatch::Output};
        our ( @lines, %given );

        sub new {
            my ( $class, %p ) = @_;
            %given = %p;
            my $self = bless( {}, $class );
            $self->_basic_init( min_level => $p{min_level} );
            return $self;
        }
        sub log_message { my ( $self, %p ) = @_; push( @lines, $p{message} ); return }
    }
    local $INC{'Test/Capture.pm'} = __FILE__;

    Trog::Log::log_init( "$dir/tcms.log", 'info', ['Test::Capture'] );
    Trog::Log::INFO('through every output');

    no warnings 'once';
    is( $Test::Capture::given{log_dir}, $dir, 'handed the log directory, as tPSGI hands it' );
    like( $Test::Capture::lines[-1], qr/through[ ]every[ ]output/, 'and given the lines' );

    like( exception { Trog::Log::log_init( "$dir/tcms.log", 'info', ['../../etc/passwd'] ) }, qr/not[ ]a[ ]module[ ]name/, 'a logger that is not a module name is refused' );
};

Test::NoWarnings::had_no_warnings();

done_testing();