File Coverage

blib/lib/Log/Dispatch/Syslog.pm
Criterion Covered Total %
statement 42 49 85.7
branch 6 16 37.5
condition 1 6 16.6
subroutine 11 11 100.0
pod 0 2 0.0
total 60 84 71.4


line stmt bran cond sub pod time code
1             package Log::Dispatch::Syslog;
2              
3 2     2   13251 use strict;
  2         4  
  2         49  
4 2     2   9 use warnings;
  2         3  
  2         81  
5              
6             our $VERSION = '2.69';
7              
8 2     2   11 use Log::Dispatch::Types;
  2         13  
  2         14  
9 2     2   47463 use Params::ValidationCompiler qw( validation_for );
  2         5  
  2         140  
10 2     2   13 use Scalar::Util qw( reftype );
  2         4  
  2         100  
11 2     2   11 use Sys::Syslog 0.28 ();
  2         54  
  2         63  
12 2     2   10 use Try::Tiny;
  2         4  
  2         102  
13              
14 2     2   10 use base qw( Log::Dispatch::Output );
  2         3  
  2         1087  
15              
16             my $thread_lock;
17              
18             {
19             my ($DefaultIdent) = $0 =~ /(.+)/;
20              
21             my $validator = validation_for(
22             params => {
23             ident => {
24              
25             # It's weird to allow an empty string but that's how this
26             # worked pre-PVC.
27             type => t('Str'),
28             default => $DefaultIdent
29             },
30             logopt => {
31             type => t('Str'),
32             default => q{},
33             },
34             facility => {
35             type => t('NonEmptyStr'),
36             default => 'user'
37             },
38             socket => {
39             type => t('SyslogSocket'),
40             default => undef,
41             },
42             lock => {
43             type => t('Bool'),
44             default => 0,
45             },
46             },
47             slurpy => 1,
48             );
49              
50             my $threads_loaded;
51              
52             sub new {
53 3     3 0 19 my $class = shift;
54 3         46 my %p = $validator->(@_);
55              
56 3         129 my $self = bless { map { $_ => delete $p{$_} }
  15         31  
57             qw( ident logopt facility socket lock ) },
58             $class;
59              
60 3 50       16 if ( $self->{lock} ) {
61 0 0       0 unless ($threads_loaded) {
62 0         0 local ( $@, $SIG{__DIE__} ) = ( undef, undef );
63              
64             ## no critic (BuiltinFunctions::ProhibitStringyEval)
65             # These need to be loaded with use, not require.
66 0 0       0 die $@ unless eval 'use threads; use threads::shared; 1;';
67 0         0 $threads_loaded = 1;
68             }
69 0         0 &threads::shared::share( \$thread_lock );
70             }
71              
72 3         16 $self->_basic_init(%p);
73              
74 3         13 return $self;
75             }
76             }
77              
78             {
79             my @priorities = (
80             'DEBUG',
81             'INFO',
82             'NOTICE',
83             'WARNING',
84             'ERR',
85             'CRIT',
86             'ALERT',
87             'EMERG',
88             );
89              
90             sub log_message {
91 3     3 0 4 my $self = shift;
92 3         7 my %p = @_;
93              
94 3         7 my $pri = $self->_level_as_number( $p{level} );
95              
96 3 50       7 lock($thread_lock) if $self->{lock};
97              
98             return
99             if try {
100 3 100   3   76 if ( defined $self->{socket} ) {
101             Sys::Syslog::setlogsock(
102             ref $self->{socket}
103             && reftype( $self->{socket} ) eq 'ARRAY'
104 0         0 ? @{ $self->{socket} }
105             : $self->{socket}
106 2 50 33     14 );
107             }
108              
109             Sys::Syslog::openlog(
110             $self->{ident},
111             $self->{logopt},
112             $self->{facility}
113 3         14 );
114 3         10 Sys::Syslog::syslog( $priorities[$pri], $p{message} );
115 3         13 Sys::Syslog::closelog();
116              
117 3         8 1;
118 3 50       17 };
119              
120 0 0 0       warn $@ if $@ and $^W;
121             }
122             }
123              
124             1;
125              
126             # ABSTRACT: Object for logging to system log.
127              
128             __END__
129              
130             =pod
131              
132             =encoding UTF-8
133              
134             =head1 NAME
135              
136             Log::Dispatch::Syslog - Object for logging to system log.
137              
138             =head1 VERSION
139              
140             version 2.69
141              
142             =head1 SYNOPSIS
143              
144             use Log::Dispatch;
145              
146             my $log = Log::Dispatch->new(
147             outputs => [
148             [
149             'Syslog',
150             min_level => 'info',
151             ident => 'Yadda yadda'
152             ]
153             ]
154             );
155              
156             $log->emerg("Time to die.");
157              
158             =head1 DESCRIPTION
159              
160             This module provides a simple object for sending messages to the
161             system log (via UNIX syslog calls).
162              
163             Note that logging may fail if you try to pass UTF-8 characters in the
164             log message. If logging fails and warnings are enabled, the error
165             message will be output using Perl's C<warn>.
166              
167             =for Pod::Coverage new log_message
168              
169             =head1 CONSTRUCTOR
170              
171             The constructor takes the following parameters in addition to the standard
172             parameters documented in L<Log::Dispatch::Output>:
173              
174             =over 4
175              
176             =item * ident ($)
177              
178             This string will be prepended to all messages in the system log.
179             Defaults to $0.
180              
181             =item * logopt ($)
182              
183             A string containing the log options (separated by any separator you
184             like). See the openlog(3) and Sys::Syslog docs for more details.
185             Defaults to ''.
186              
187             =item * facility ($)
188              
189             Specifies what type of program is doing the logging to the system log.
190             Valid options are 'auth', 'authpriv', 'cron', 'daemon', 'kern',
191             'local0' through 'local7', 'mail, 'news', 'syslog', 'user',
192             'uucp'. Defaults to 'user'
193              
194             =item * socket ($, \@, or \%)
195              
196             Tells what type of socket to use for sending syslog messages. Valid
197             options are listed in C<Sys::Syslog>.
198              
199             If you don't provide this, then we let C<Sys::Syslog> simply pick one
200             that works, which is the preferred option, as it makes your code more
201             portable.
202              
203             If you pass an array reference, it is dereferenced and passed to
204             C<Sys::Syslog::setlogsock()>.
205              
206             If you pass a hash reference, it is passed to C<Sys::Syslog::setlogsock()> as
207             is.
208              
209             =item * lock ($)
210              
211             If this is set to a true value, then the calls to C<setlogsock()>,
212             C<openlog()>, C<syslog()>, and C<closelog()> will all be guarded by a
213             thread-locked variable.
214              
215             This is only relevant when running you are using Perl threads in your
216             application. Setting this to a true value will cause the L<threads> and
217             L<threads::shared> modules to be loaded.
218              
219             This defaults to false.
220              
221             =back
222              
223             =head1 SUPPORT
224              
225             Bugs may be submitted at L<https://github.com/houseabsolute/Log-Dispatch/issues>.
226              
227             I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
228              
229             =head1 SOURCE
230              
231             The source code repository for Log-Dispatch can be found at L<https://github.com/houseabsolute/Log-Dispatch>.
232              
233             =head1 AUTHOR
234              
235             Dave Rolsky <autarch@urth.org>
236              
237             =head1 COPYRIGHT AND LICENSE
238              
239             This software is Copyright (c) 2019 by Dave Rolsky.
240              
241             This is free software, licensed under:
242              
243             The Artistic License 2.0 (GPL Compatible)
244              
245             The full text of the license can be found in the
246             F<LICENSE> file included with this distribution.
247              
248             =cut