File Coverage

File:blib/lib/Log/Abstraction/Backend/Journald.pm
Coverage:96.6%

linestmtbrancondsubtimecode
1package Log::Abstraction::Backend::Journald;
2
3# The journald backend: send messages to the systemd journal
4
37
37
37
37
101
25
131
use strict;
5
37
37
37
37
30
24
232
use warnings;
6
7
37
37
37
37
25
25
34
use parent 'Log::Abstraction::Backend';
8
9# Automatically throw exceptions on failed built-ins (socket, close ...)
10
37
37
37
37
414
23
105
use autodie qw(:default);
11
12
37
37
37
37
47140
27
120
use Carp ();
13
37
37
37
37
34
22
123
use POSIX ();
14
37
37
37
37
32
27
298
use Readonly ();
15
16# _send is private to this package (see Log::Abstraction)
17
37
37
37
37
31
207
127
use Sub::Private 0.07 { mode => 'enforce' };
18
19our $VERSION = '0.40';
20
21# Default path to the journald native-protocol socket on systemd systems
22Readonly::Scalar my $DEFAULT_SOCKET => '/run/systemd/journal/socket';
23
24# Largest journald datagram sent; the default socket send buffer is ~212KB
25# on most Linux systems and bigger datagrams fail, so longer messages are
26# truncated to fit.  Some systems have smaller buffers, so on EMSGSIZE the
27# limit is halved and the send retried, down to $MIN_PAYLOAD
28Readonly::Scalar my $MAX_PAYLOAD => 200_000;
29Readonly::Scalar my $MIN_PAYLOAD => 4_096;
30
31# Longest journald field name; journald ignores fields with longer names
32Readonly::Scalar my $MAX_FIELD_NAME => 64;
33
34# Marker appended to a message truncated to fit in a datagram
35Readonly::Scalar my $TRUNCATED_MARKER => ' [truncated]';
36
37 - 66
=head1 NAME

Log::Abstraction::Backend::Journald - send messages to the systemd journal

=head1 VERSION

0.40

=head1 DESCRIPTION

Built for the C<journald> key of a C<logger> hash.  Each message is one
datagram in the journald native protocol
(L<https://systemd.io/JOURNAL_NATIVE_PROTOCOL/>), with the fields
C<MESSAGE> (with a C<format>, the formatted line), C<PRIORITY>,
C<SYSLOG_IDENTIFIER>, the hash's other keys upper-cased, and the structured
fields.  A message too big for one datagram is truncated.  A failed send
carps, once until a send succeeds again.  The socket is opened for the
first message and reused for the next ones, until a send fails.

For use by L<Log::Abstraction> only; see L<Log::Abstraction::Backend>.

=head1 METHODS

=head2 new

  my $backend = Log::Abstraction::Backend::Journald->new(
      journald => \%journald, level => $level, format => $format,
  );

=cut
67
68sub new {
69
24
24
104
        my ($class, %args) = @_;
70
71        # The config hash's other keys are extra journal fields (their names
72        # have been checked by Log::Abstraction->new())
73
24
15
        my $config = $args{'journald'};
74
5
10
        my %extra = map { uc($_) => $config->{$_} }
75
24
34
24
23
48
16
                grep { lc($_) !~ /^(?:socket|identifier|level|format)$/ } keys %{$config};
76
77        return $class->SUPER::new(
78                %args,
79                socket     => $config->{'socket'} || $DEFAULT_SOCKET,
80
24
67
63
                identifier => $config->{'identifier'},
81                extra      => \%extra,
82        );
83}
84
85 - 89
=head2 emit

  $backend->emit($logger, $event);

=cut
90
91sub emit {
92
40
40
30
        my ($self, $logger, $event) = @_;
93
94        # The syslog identifier: the configured one, the script name, or $0
95
40
33
65
        my $ident = $self->{'identifier'} || $logger->{'script_name'} || do {
96                require File::Basename;
97                File::Basename::basename($0);
98        };
99
100        # Mandatory fields (PRIORITY is 0=emerg ... 7=debug), then the extra
101        # fields from the config hash
102        my %entry = (
103                MESSAGE           => $self->text($event, $event->{'message'}),
104                PRIORITY          => $event->{'priority'},
105                SYSLOG_IDENTIFIER => $ident,
106
40
40
47
49
                %{$self->{'extra'}},
107        );
108
109        # Then the structured fields.  These weren't checked by new(), so make
110        # each name valid rather than reject it: upper-case, other characters
111        # to '_', no leading '_' (journald reserves those for trusted fields)
112        # and at most 64 characters
113
40
100
49
        my $fields = $event->{'fields'} || {};
114
40
40
21
33
        for my $key (keys %{$fields}) {
115
20
18
                (my $name = uc($key)) =~ s/[^A-Z0-9_]/_/g;
116
20
13
                $name =~ s/^_+//;
117
20
14
                $name = substr($name, 0, $MAX_FIELD_NAME);
118
20
100
100
23
                next if(($name eq '') || $name =~ /^(?:MESSAGE|PRIORITY|SYSLOG_IDENTIFIER)$/);
119
16
10
                $entry{$name} = $event->{'field_string'}->($fields->{$key});
120        }
121
122        # Delivery failures are silent; the app must not crash on log errors.
123        # Carp only on the first failure, so that a system without journald
124        # (FreeBSD, macOS) isn't flooded with warnings; a later success re-arms
125        # the warning.
126
40
40
20
100
100
22
54
19
        if(eval { $self->_send($self->{'socket'}, %entry); 1 }) {
127
20
120
                delete $logger->{'_journald_failed'};
128        } elsif(!$logger->{'_journald_failed'}++) {
129
6
1024
                Carp::carp(ref($logger), ": journald send failed: $@");
130        }
131}
132
133# ---------------------------------------------------------------------------
134# _send -- encode fields and send one datagram to the journald socket
135#
136# Purpose:      Format key=value fields in the journald native protocol and
137#               deliver them as a single Unix-domain SOCK_DGRAM packet.
138# Entry:        $self        -- the backend, which keeps the socket in
139#                              $self->{_socket} between messages.
140#               $socket_path -- filesystem path of the journald socket.
141#               %fields      -- FIELD_NAME => value pairs; names must be
142#                              uppercase ASCII + digits + underscore.
143# Exit:         Returns nothing.  Croaks on socket or send failure (the caller
144#               wraps every call in eval{} so failures are silent to the app).
145# Side effects: Opens a Unix datagram socket on the first call, and keeps it
146#               for the next; closes it after a failed send, so that the
147#               next message gets a new one.
148# Notes:        Values containing newline or NUL use the binary framing
149#               (field-name NL uint64-LE-length value NL) as specified by
150#               https://systemd.io/JOURNAL_NATIVE_PROTOCOL/.
151#               Values without newlines or NULs use the simpler FIELD=VALUE NL
152#               text format.  The send buffer, and so the largest datagram,
153#               varies between systems: a send failing with EMSGSIZE is
154#               retried with MESSAGE truncated to half the size, down to
155#               $MIN_PAYLOAD.  The socket isn't connected: each datagram is
156#               addressed to the path, so it still arrives after journald
157#               restarts and creates the socket file again.
158# ---------------------------------------------------------------------------
159sub _send :Private {
160        my ($self, $socket_path, %fields) = @_;
161
162        # The protocol carries bytes, and binary framing declares a byte length,
163        # so encode character strings to UTF-8 first
164        for my $key (keys %fields) {
165                my $value = defined($fields{$key}) ? "$fields{$key}" : '';
166                utf8::encode($value) if(utf8::is_utf8($value));
167                $fields{$key} = $value;
168        }
169
170        # Build the datagram payload from all supplied fields
171        my $build = sub {
172                my $payload = '';
173                for my $key (sort keys %fields) {
174                        my $value = $fields{$key};
175                        if($value =~ /[\n\0]/) {
176                                # Binary framing: field-name LF uint64LE-length value LF.
177                                # The length is packed as two 32-bit little-endian words
178                                # because pack('Q') dies on perls without 64-bit integers
179                                my $len = length($value);
180                                $payload .= $key . "\n"
181                                        . pack('VV', $len % 2**32, int($len / 2**32))
182                                        . $value . "\n";
183                        } else {
184                                $payload .= "$key=$value\n";
185                        }
186                }
187                return $payload;
188        };
189        my $full = $build->();
190        my $message = $fields{'MESSAGE'};
191
192        # A datagram bigger than the socket send buffer fails outright, so
193        # truncate MESSAGE to fit in $limit bytes.  The extra 8 bytes allow for
194        # the message switching from text to binary framing.
195        my $fit = sub {
196                my $limit = shift;
197                my $excess = length($full) - $limit;
198                return $full if(($excess <= 0) || !defined($message));
199                my $keep = length($message) - $excess - length($TRUNCATED_MARKER) - 8;
200                my $cut = substr($message, 0, ($keep > 0) ? $keep : 0);
201                # Don't leave a partial UTF-8 sequence at the cut
202                $cut =~ s/[\xC0-\xFF][\x80-\xBF]*\z//;
203                $fields{'MESSAGE'} = $cut . $TRUNCATED_MARKER;
204                return $build->();
205        };
206
207        # The Unix-domain datagram socket, opened on the first message and then
208        # reused
209        require Socket;
210        my $sock = $self->{_socket} //= do {
211                socket(my $new, Socket::AF_UNIX(), Socket::SOCK_DGRAM(), 0);
212
213                # Ask for a send buffer big enough for the largest datagram; the
214                # kernel may cap it (net.core.wmem_max), which the retry handles
215
37
37
37
37
14357
21
90
                no autodie qw(setsockopt);
216                setsockopt($new, Socket::SOL_SOCKET(), Socket::SO_SNDBUF(), $MAX_PAYLOAD + 1024);
217                $new;
218        };
219        my $dest = Socket::sockaddr_un($socket_path);
220
221        {
222                # send() is checked by hand: EMSGSIZE means retry smaller
223
37
37
37
37
3705
22
43
                no autodie qw(send);
224
225                my $limit = $MAX_PAYLOAD;
226                while(1) {
227                        last if(defined(send($sock, $fit->($limit), 0, $dest)));
228                        my $err = $!;
229                        if(($err == POSIX::EMSGSIZE()) && ($limit > $MIN_PAYLOAD)) {
230                                $limit = int($limit / 2);
231                                next;
232                        }
233                        # Start again with a new socket next time
234                        delete $self->{_socket};
235                        eval { close $sock };
236                        Carp::croak("Can't send to $socket_path: $err");
237                }
238        }
239        return;
240
37
37
37
37
3823
18
523
}
241
242
243 - 259
=head1 AUTHOR

Nigel Horne C<njh@nigelhorne.com>

=head1 SEE ALSO

L<Log::Abstraction>, L<Log::Abstraction::Backend>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2025-2026 Nigel Horne

Usage is subject to the GPL2 licence terms.
If you use it,
please let me know.

=cut
260
2611;