← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:07 2021

Filename/usr/local/lib/perl5/5.32/mach/Sys/Syslog.pm
StatementsExecuted 2941188 statements in 4.96s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
35436111.85s4.90sSys::Syslog::::syslogSys::Syslog::syslog
7087221873ms1.09sSys::Syslog::::xlateSys::Syslog::xlate
3543611207ms257msSys::Syslog::::connection_okSys::Syslog::connection_ok
3543611140ms251msSys::Syslog::::_syslog_send_socketSys::Syslog::_syslog_send_socket
3543611110ms110msSys::Syslog::::CORE:syswriteSys::Syslog::CORE:syswrite (opcode)
24805241100ms100msSys::Syslog::::CORE:matchSys::Syslog::CORE:match (opcode)
708721174.1ms74.1msSys::Syslog::::constantSys::Syslog::constant (xsub)
354331153.1ms53.1msSys::Syslog::::LOG_DEBUGSys::Syslog::LOG_DEBUG (xsub)
354361150.4ms50.4msSys::Syslog::::CORE:sselectSys::Syslog::CORE:sselect (opcode)
354361140.4ms40.4msSys::Syslog::::LOG_LOCAL1Sys::Syslog::LOG_LOCAL1 (xsub)
354361115.1ms15.1msSys::Syslog::::LOG_MASKSys::Syslog::LOG_MASK (xsub)
354361113.8ms13.8msSys::Syslog::::LOG_PRIMASKSys::Syslog::LOG_PRIMASK (xsub)
31155µs55µsSys::Syslog::::LOG_NOTICESys::Syslog::LOG_NOTICE (xsub)
0000s0sSys::Syslog::::AUTOLOADSys::Syslog::AUTOLOAD
0000s0sSys::Syslog::::BEGIN@10Sys::Syslog::BEGIN@10
0000s0sSys::Syslog::::BEGIN@104Sys::Syslog::BEGIN@104
0000s0sSys::Syslog::::BEGIN@114Sys::Syslog::BEGIN@114
0000s0sSys::Syslog::::BEGIN@17Sys::Syslog::BEGIN@17
0000s0sSys::Syslog::::BEGIN@190Sys::Syslog::BEGIN@190
0000s0sSys::Syslog::::BEGIN@196Sys::Syslog::BEGIN@196
0000s0sSys::Syslog::::BEGIN@2Sys::Syslog::BEGIN@2
0000s0sSys::Syslog::::BEGIN@3Sys::Syslog::BEGIN@3
0000s0sSys::Syslog::::BEGIN@4Sys::Syslog::BEGIN@4
0000s0sSys::Syslog::::BEGIN@5Sys::Syslog::BEGIN@5
0000s0sSys::Syslog::::BEGIN@6Sys::Syslog::BEGIN@6
0000s0sSys::Syslog::::BEGIN@618Sys::Syslog::BEGIN@618
0000s0sSys::Syslog::::BEGIN@647Sys::Syslog::BEGIN@647
0000s0sSys::Syslog::::BEGIN@7Sys::Syslog::BEGIN@7
0000s0sSys::Syslog::::BEGIN@8Sys::Syslog::BEGIN@8
0000s0sSys::Syslog::::BEGIN@81Sys::Syslog::BEGIN@81
0000s0sSys::Syslog::::BEGIN@82Sys::Syslog::BEGIN@82
0000s0sSys::Syslog::::BEGIN@83Sys::Syslog::BEGIN@83
0000s0sSys::Syslog::::BEGIN@84Sys::Syslog::BEGIN@84
0000s0sSys::Syslog::::BEGIN@85Sys::Syslog::BEGIN@85
0000s0sSys::Syslog::::BEGIN@86Sys::Syslog::BEGIN@86
0000s0sSys::Syslog::::BEGIN@88Sys::Syslog::BEGIN@88
0000s0sSys::Syslog::::BEGIN@9Sys::Syslog::BEGIN@9
0000s0sSys::Syslog::::BEGIN@93Sys::Syslog::BEGIN@93
0000s0sSys::Syslog::::BEGIN@98Sys::Syslog::BEGIN@98
0000s0sSys::Syslog::::CORE:connectSys::Syslog::CORE:connect (opcode)
0000s0sSys::Syslog::::CORE:ftewriteSys::Syslog::CORE:ftewrite (opcode)
0000s0sSys::Syslog::::CORE:ftsockSys::Syslog::CORE:ftsock (opcode)
0000s0sSys::Syslog::::CORE:selectSys::Syslog::CORE:select (opcode)
0000s0sSys::Syslog::::CORE:socketSys::Syslog::CORE:socket (opcode)
0000s0sSys::Syslog::::CORE:sortSys::Syslog::CORE:sort (opcode)
0000s0sSys::Syslog::::CORE:substSys::Syslog::CORE:subst (opcode)
0000s0sSys::Syslog::::LOG_INFOSys::Syslog::LOG_INFO (xsub)
0000s0sSys::Syslog::::LOG_UPTOSys::Syslog::LOG_UPTO (xsub)
0000s0sSys::Syslog::::_PATH_LOGSys::Syslog::_PATH_LOG (xsub)
0000s0sSys::Syslog::::__ANON__[:180]Sys::Syslog::__ANON__[:180]
0000s0sSys::Syslog::::__ANON__[:197]Sys::Syslog::__ANON__[:197]
0000s0sSys::Syslog::::__ANON__[:236]Sys::Syslog::__ANON__[:236]
0000s0sSys::Syslog::::__ANON__[:239]Sys::Syslog::__ANON__[:239]
0000s0sSys::Syslog::::__ANON__[:243]Sys::Syslog::__ANON__[:243]
0000s0sSys::Syslog::::__ANON__[:246]Sys::Syslog::__ANON__[:246]
0000s0sSys::Syslog::::__ANON__[:253]Sys::Syslog::__ANON__[:253]
0000s0sSys::Syslog::::__ANON__[:264]Sys::Syslog::__ANON__[:264]
0000s0sSys::Syslog::::__ANON__[:280]Sys::Syslog::__ANON__[:280]
0000s0sSys::Syslog::::__ANON__[:294]Sys::Syslog::__ANON__[:294]
0000s0sSys::Syslog::::__ANON__[:302]Sys::Syslog::__ANON__[:302]
0000s0sSys::Syslog::::_syslog_send_consoleSys::Syslog::_syslog_send_console
0000s0sSys::Syslog::::_syslog_send_nativeSys::Syslog::_syslog_send_native
0000s0sSys::Syslog::::_syslog_send_pipeSys::Syslog::_syslog_send_pipe
0000s0sSys::Syslog::::_syslog_send_streamSys::Syslog::_syslog_send_stream
0000s0sSys::Syslog::::can_load_sys_syslog_win32Sys::Syslog::can_load_sys_syslog_win32
0000s0sSys::Syslog::::closelogSys::Syslog::closelog
0000s0sSys::Syslog::::connect_consoleSys::Syslog::connect_console
0000s0sSys::Syslog::::connect_eventlogSys::Syslog::connect_eventlog
0000s0sSys::Syslog::::connect_logSys::Syslog::connect_log
0000s0sSys::Syslog::::connect_nativeSys::Syslog::connect_native
0000s0sSys::Syslog::::connect_pipeSys::Syslog::connect_pipe
0000s0sSys::Syslog::::connect_streamSys::Syslog::connect_stream
0000s0sSys::Syslog::::connect_tcpSys::Syslog::connect_tcp
0000s0sSys::Syslog::::connect_udpSys::Syslog::connect_udp
0000s0sSys::Syslog::::connect_unixSys::Syslog::connect_unix
0000s0sSys::Syslog::::disconnect_logSys::Syslog::disconnect_log
0000s0sSys::Syslog::::openlogSys::Syslog::openlog
0000s0sSys::Syslog::::setlogmaskSys::Syslog::setlogmask
0000s0sSys::Syslog::::setlogsockSys::Syslog::setlogsock
0000s0sSys::Syslog::::silent_evalSys::Syslog::silent_eval
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Sys::Syslog;
2use strict;
3use warnings;
4use warnings::register;
5use Carp;
6use Config;
7use Exporter ();
8use File::Basename;
9use POSIX qw< strftime setlocale LC_TIME >;
10use Socket qw< :all >;
11require 5.005;
12
13
14*import = \&Exporter::import;
15
16
17{ no strict 'vars';
18 $VERSION = '0.36';
19
20 %EXPORT_TAGS = (
21 standard => [qw(openlog syslog closelog setlogmask)],
22 extended => [qw(setlogsock)],
23 macros => [
24 # levels
25 qw(
26 LOG_ALERT LOG_CRIT LOG_DEBUG LOG_EMERG LOG_ERR
27 LOG_INFO LOG_NOTICE LOG_WARNING
28 ),
29
30 # standard facilities
31 qw(
32 LOG_AUTH LOG_AUTHPRIV LOG_CRON LOG_DAEMON LOG_FTP LOG_KERN
33 LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4
34 LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NEWS
35 LOG_SYSLOG LOG_USER LOG_UUCP
36 ),
37 # Mac OS X specific facilities
38 qw( LOG_INSTALL LOG_LAUNCHD LOG_NETINFO LOG_RAS LOG_REMOTEAUTH ),
39 # modern BSD specific facilities
40 qw( LOG_CONSOLE LOG_NTP LOG_SECURITY ),
41 # IRIX specific facilities
42 qw( LOG_AUDIT LOG_LFMT ),
43
44 # options
45 qw(
46 LOG_CONS LOG_PID LOG_NDELAY LOG_NOWAIT LOG_ODELAY LOG_PERROR
47 ),
48
49 # others macros
50 qw(
51 LOG_FACMASK LOG_NFACILITIES LOG_PRIMASK
52 LOG_MASK LOG_UPTO
53 ),
54 ],
55 );
56
57 @EXPORT = (
58 @{$EXPORT_TAGS{standard}},
59 );
60
61 @EXPORT_OK = (
62 @{$EXPORT_TAGS{extended}},
63 @{$EXPORT_TAGS{macros}},
64 );
65
66 eval {
67 require XSLoader;
68 XSLoader::load('Sys::Syslog', $VERSION);
69 1
70 } or do {
71 require DynaLoader;
72 push @ISA, 'DynaLoader';
73 bootstrap Sys::Syslog $VERSION;
74 };
75}
76
77
78#
79# Constants
80#
81use constant HAVE_GETPROTOBYNAME => $Config::Config{d_getpbyname};
82use constant HAVE_GETPROTOBYNUMBER => $Config::Config{d_getpbynumber};
83use constant HAVE_SETLOCALE => $Config::Config{d_setlocale};
84use constant HAVE_IPPROTO_TCP => defined &Socket::IPPROTO_TCP ? 1 : 0;
85use constant HAVE_IPPROTO_UDP => defined &Socket::IPPROTO_UDP ? 1 : 0;
86use constant HAVE_TCP_NODELAY => defined &Socket::TCP_NODELAY ? 1 : 0;
87
88use constant SOCKET_IPPROTO_TCP =>
89 HAVE_IPPROTO_TCP ? Socket::IPPROTO_TCP
90 : HAVE_GETPROTOBYNAME ? scalar getprotobyname("tcp")
91 : 6;
92
93use constant SOCKET_IPPROTO_UDP =>
94 HAVE_IPPROTO_UDP ? Socket::IPPROTO_UDP
95 : HAVE_GETPROTOBYNAME ? scalar getprotobyname("udp")
96 : 17;
97
98use constant SOCKET_TCP_NODELAY => HAVE_TCP_NODELAY ? Socket::TCP_NODELAY : 1;
99
100
101#
102# Public variables
103#
104use vars qw($host); # host to send syslog messages to (see notes at end)
105
106#
107# Prototypes
108#
109sub silent_eval (&);
110
111#
112# Global variables
113#
114use vars qw($facility);
115my $connected = 0; # flag to indicate if we're connected or not
116my $syslog_send; # coderef of the function used to send messages
117my $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms
118my $syslog_xobj = undef; # if defined, holds the external object used to send messages
119my $transmit_ok = 0; # flag to indicate if the last message was transmitted
120my $sock_port = undef; # socket port
121my $sock_timeout = 0; # socket timeout, see below
122my $current_proto = undef; # current mechanism used to transmit messages
123my $ident = ''; # identifiant prepended to each message
124$facility = ''; # current facility
125my $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask
126
127my %options = (
128 ndelay => 0,
129 noeol => 0,
130 nofatal => 0,
131 nonul => 0,
132 nowait => 0,
133 perror => 0,
134 pid => 0,
135);
136
137# Default is now to first use the native mechanism, so Perl programs
138# behave like other normal Unix programs, then try other mechanisms.
139my @connectMethods = qw(native tcp udp unix pipe stream console);
140if ($^O eq "freebsd" or $^O eq "linux") {
141 @connectMethods = grep { $_ ne 'udp' } @connectMethods;
142}
143
144# And on Win32 systems, we try to use the native mechanism for this
145# platform, the events logger, available through Win32::EventLog.
146EVENTLOG: {
147 my $verbose_if_Win32 = $^O =~ /Win32/i;
148
149 if (can_load_sys_syslog_win32($verbose_if_Win32)) {
150 unshift @connectMethods, 'eventlog';
151 }
152}
153
154my @defaultMethods = @connectMethods;
155my @fallbackMethods = ();
156
157# The timeout in connection_ok() was pushed up to 0.25 sec in
158# Sys::Syslog v0.19 in order to address a heisenbug on MacOSX:
159# http://london.pm.org/pipermail/london.pm/Week-of-Mon-20061211/005961.html
160#
161# However, this also had the effect of slowing this test for
162# all other operating systems, which apparently impacted some
163# users (cf. CPAN-RT #34753). So, in order to make everybody
164# happy, the timeout is now zero by default on all systems
165# except on OSX where it is set to 250 msec, and can be set
166# with the infamous setlogsock() function.
167#
168# Update 2011-08: this issue is also been seen on multiprocessor
169# Debian GNU/kFreeBSD systems. See http://bugs.debian.org/627821
170# and https://rt.cpan.org/Ticket/Display.html?id=69997
171# Also, lowering the delay to 1 ms, which should be enough.
172
173$sock_timeout = 0.001 if $^O =~ /darwin|gnukfreebsd/;
174
175
176# Perl 5.6.0's warnings.pm doesn't have warnings::warnif()
177if (not defined &warnings::warnif) {
178 *warnings::warnif = sub {
179 goto &warnings::warn if warnings::enabled(__PACKAGE__)
180 }
181}
182
183# coderef for a nicer handling of errors
184my $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
185
186
187sub AUTOLOAD {
188 # This AUTOLOAD is used to 'autoload' constants from the constant()
189 # XS function.
190 no strict 'vars';
191 my $constname;
192 ($constname = $AUTOLOAD) =~ s/.*:://;
193 croak "Sys::Syslog::constant() not defined" if $constname eq 'constant';
194 my ($error, $val) = constant($constname);
195 croak $error if $error;
196 no strict 'refs';
197 *$AUTOLOAD = sub { $val };
198 goto &$AUTOLOAD;
199}
200
201
202sub openlog {
203 ($ident, my $logopt, $facility) = @_;
204
205 # default values
206 $ident ||= basename($0) || getlogin() || getpwuid($<) || 'syslog';
207 $logopt ||= '';
208 $facility ||= LOG_USER();
209
210 for my $opt (split /\b/, $logopt) {
211 $options{$opt} = 1 if exists $options{$opt}
212 }
213
214 $err_sub = delete $options{nofatal} ? \&warnings::warnif : \&croak;
215 return 1 unless $options{ndelay};
216 connect_log();
217}
218
219sub closelog {
220 disconnect_log() if $connected;
221 $options{$_} = 0 for keys %options;
222 $facility = $ident = "";
223 $connected = 0;
224 return 1
225}
226
227sub setlogmask {
228 my $oldmask = $maskpri;
229 $maskpri = shift unless $_[0] == 0;
230 $oldmask;
231}
232
233
234my %mechanism = (
235 console => {
236 check => sub { 1 },
237 },
238 eventlog => {
239 check => sub { return can_load_sys_syslog_win32() },
240 err_msg => "no Win32 API available",
241 },
242 inet => {
243 check => sub { 1 },
244 },
245 native => {
246 check => sub { 1 },
247 },
248 pipe => {
249 check => sub {
250 ($syslog_path) = grep { defined && length && -p && -w _ }
251 $syslog_path, &_PATH_LOG, "/dev/log";
252 return $syslog_path ? 1 : 0
253 },
254 err_msg => "path not available",
255 },
256 stream => {
257 check => sub {
258 if (not defined $syslog_path) {
259 my @try = qw(/dev/log /dev/conslog);
260 unshift @try, &_PATH_LOG if length &_PATH_LOG;
261 ($syslog_path) = grep { -w } @try;
262 }
263 return defined $syslog_path && -w $syslog_path
264 },
265 err_msg => "could not find any writable device",
266 },
267 tcp => {
268 check => sub {
269 return 1 if defined $sock_port;
270
271 if (eval { local $SIG{__DIE__};
272 getservbyname('syslog','tcp') || getservbyname('syslogng','tcp')
273 }) {
274 $host = $syslog_path;
275 return 1
276 }
277 else {
278 return
279 }
280 },
281 err_msg => "TCP service unavailable",
282 },
283 udp => {
284 check => sub {
285 return 1 if defined $sock_port;
286
287 if (eval { local $SIG{__DIE__}; getservbyname('syslog', 'udp') }) {
288 $host = $syslog_path;
289 return 1
290 }
291 else {
292 return
293 }
294 },
295 err_msg => "UDP service unavailable",
296 },
297 unix => {
298 check => sub {
299 my @try = ($syslog_path, &_PATH_LOG);
300 ($syslog_path) = grep { defined && length && -w } @try;
301 return defined $syslog_path && -w $syslog_path
302 },
303 err_msg => "path not available",
304 },
305);
306
307sub setlogsock {
308 my %opt;
309
310 # handle arguments
311 # - old API: setlogsock($sock_type, $sock_path, $sock_timeout)
312 # - new API: setlogsock(\%options)
313 croak "setlogsock(): Invalid number of arguments"
314 unless @_ >= 1 and @_ <= 3;
315
316 if (my $ref = ref $_[0]) {
317 if ($ref eq "HASH") {
318 %opt = %{ $_[0] };
319 croak "setlogsock(): No argument given" unless keys %opt;
320 }
321 elsif ($ref eq "ARRAY") {
322 @opt{qw< type path timeout >} = @_;
323 }
324 else {
325 croak "setlogsock(): Unexpected \L$ref\E reference"
326 }
327 }
328 else {
329 @opt{qw< type path timeout >} = @_;
330 }
331
332 # check socket type, remove invalid ones
333 my $diag_invalid_type = "setlogsock(): Invalid type%s; must be one of "
334 . join ", ", map { "'$_'" } sort keys %mechanism;
335 croak sprintf $diag_invalid_type, "" unless defined $opt{type};
336 my @sock_types = ref $opt{type} eq "ARRAY" ? @{$opt{type}} : ($opt{type});
337 my @tmp;
338
339 for my $sock_type (@sock_types) {
340 carp sprintf $diag_invalid_type, " '$sock_type'" and next
341 unless exists $mechanism{$sock_type};
342 push @tmp, "tcp", "udp" and next if $sock_type eq "inet";
343 push @tmp, $sock_type;
344 }
345
346 @sock_types = @tmp;
347
348 # set global options
349 $syslog_path = $opt{path} if defined $opt{path};
350 $host = $opt{host} if defined $opt{host};
351 $sock_timeout = $opt{timeout} if defined $opt{timeout};
352 $sock_port = $opt{port} if defined $opt{port};
353
354 disconnect_log() if $connected;
355 $transmit_ok = 0;
356 @fallbackMethods = ();
357 @connectMethods = ();
358 my $found = 0;
359
360 # check each given mechanism and test if it can be used on the current system
361 for my $sock_type (@sock_types) {
362 if ( $mechanism{$sock_type}{check}->() ) {
363 push @connectMethods, $sock_type;
364 $found = 1;
365 }
366 else {
367 warnings::warnif("setlogsock(): type='$sock_type': "
368 . $mechanism{$sock_type}{err_msg});
369 }
370 }
371
372 # if no mechanism worked from the given ones, use the default ones
373 @connectMethods = @defaultMethods unless @connectMethods;
374
375 return $found;
376}
377
378
# spent 4.90s (1.85+3.05) within Sys::Syslog::syslog which was called 35436 times, avg 138µs/call: # 35436 times (1.85s+3.05s) by Sympa::Log::syslog at line 202 of /usr/local/libexec/sympa/Sympa/Log.pm, avg 138µs/call
sub syslog {
3793543622.1ms my ($priority, $mask, @args) = @_;
380354365.16ms my ($message, $buf);
381 my (@words, $num, $numpri, $numfac, $sum);
382354367.15ms my $failed = undef;
383354364.50ms my $fail_time = undef;
38435436143ms my $error = $!;
385
386 # if $ident is undefined, it means openlog() wasn't previously called
387 # so do it now in order to have sensible defaults
388354365.24ms openlog() unless $ident;
389
3903543610.5ms local $facility = $facility; # may need to change temporarily.
391
392354365.69ms croak "syslog: expecting argument \$priority" unless defined $priority;
393354364.08ms croak "syslog: expecting argument \$format" unless defined $mask;
394
39535436190ms7087238.5ms if ($priority =~ /^\d+$/) {
# spent 38.5ms making 70872 calls to Sys::Syslog::CORE:match, avg 544ns/call
396 $numpri = LOG_PRI($priority);
397 $numfac = LOG_FAC($priority) << 3;
398 undef $numfac if $numfac == 0; # no facility given => use default
399 }
400 elsif ($priority =~ /^\w+/) {
401 # Allow "level" or "level|facility".
4023543634.9ms @words = split /\W+/, $priority, 2;
403
404354367.32ms undef $numpri;
405354364.19ms undef $numfac;
406
4073543613.7ms for my $word (@words) {
408354367.69ms next if length $word == 0;
409
410 # Translate word to number.
4113543633.2ms35436590ms $num = xlate($word);
# spent 590ms making 35436 calls to Sys::Syslog::xlate, avg 17µs/call
412
41335436131ms3543613.8ms if ($num < 0) {
# spent 13.8ms making 35436 calls to Sys::Syslog::LOG_PRIMASK, avg 389ns/call
414 croak "syslog: invalid level/facility: $word"
415 }
416 elsif ($num <= LOG_PRIMASK() and $word ne "kern") {
417354365.59ms croak "syslog: too many levels given: $word"
418 if defined $numpri;
419354369.06ms $numpri = $num;
420 }
421 else {
422 croak "syslog: too many facilities given: $word"
423 if defined $numfac;
424 $facility = $word if $word =~ /^[A-Za-z]/;
425 $numfac = $num;
426 }
427 }
428 }
429 else {
430 croak "syslog: invalid level/facility: $priority"
431 }
432
433354365.49ms croak "syslog: level must be given" unless defined $numpri;
434
435 # don't log if priority is below mask level
43635436103ms3543615.1ms return 0 unless LOG_MASK($numpri) & $maskpri;
# spent 15.1ms making 35436 calls to Sys::Syslog::LOG_MASK, avg 425ns/call
437
4383543611.4ms if (not defined $numfac) { # Facility not specified in this call.
439354365.09ms $facility = 'user' unless $facility;
4403543632.1ms35436503ms $numfac = xlate($facility);
# spent 503ms making 35436 calls to Sys::Syslog::xlate, avg 14µs/call
441 }
442
443354364.80ms connect_log() unless $connected;
444
4453543678.0ms354369.37ms if ($mask =~ /%m/) {
# spent 9.37ms making 35436 calls to Sys::Syslog::CORE:match, avg 264ns/call
446 # escape percent signs for sprintf()
447 $error =~ s/%/%%/g if @args;
448 # replace %m with $error, if preceded by an even number of percent signs
449 $mask =~ s/(?<!%)((?:%%)*)%m/$1$error/g;
450 }
451
452 # add (or not) a newline
4533543620.6ms $mask .= "\n" if !$options{noeol} and rindex($mask, "\n") == -1;
4543543623.4ms $message = @args ? sprintf($mask, @args) : $mask;
455
4563543614.6ms if ($current_proto eq 'native') {
457 $buf = $message;
458 }
459 elsif ($current_proto eq 'eventlog') {
460 $buf = $message;
461 }
462 else {
463354367.04ms my $whoami = $ident;
464354367.24ms $whoami .= "[$$]" if $options{pid};
465
466354368.67ms $sum = $numpri + $numfac;
467
468354364.13ms my $oldlocale;
469354367.07ms if (HAVE_SETLOCALE) {
47035436119ms3543629.3ms $oldlocale = setlocale(LC_TIME);
# spent 29.3ms making 35436 calls to POSIX::setlocale, avg 828ns/call
47135436189ms35436103ms setlocale(LC_TIME, 'C');
# spent 103ms making 35436 calls to POSIX::setlocale, avg 3µs/call
472 }
473
474 # %e format isn't available on all systems (Win32, cf. CPAN RT #69310)
47535436456ms35436313ms my $day = strftime "%e", localtime;
# spent 313ms making 35436 calls to POSIX::strftime, avg 9µs/call
476
4773543611.3ms if (index($day, "%") == 0) {
478 $day = strftime "%d", localtime;
479 $day =~ s/^0/ /;
480 }
481
48235436362ms35436261ms my $timestamp = strftime "%b $day %H:%M:%S", localtime;
# spent 261ms making 35436 calls to POSIX::strftime, avg 7µs/call
48335436761ms35436662ms setlocale(LC_TIME, $oldlocale) if HAVE_SETLOCALE;
# spent 662ms making 35436 calls to POSIX::setlocale, avg 19µs/call
484
485 # construct the stream that will be transmitted
4863543619.2ms $buf = "<$sum>$timestamp $whoami: $message";
487
488 # add (or not) a NUL character
4893543624.3ms $buf .= "\0" if !$options{nonul};
490 }
491
492 # handle PERROR option
493 # "native" mechanism already handles it by itself
494354366.77ms if ($options{perror} and $current_proto ne 'native') {
495 my $whoami = $ident;
496 $whoami .= "[$$]" if $options{pid};
497 print STDERR "$whoami: $message";
498 print STDERR "\n" if rindex($message, "\n") == -1;
499 }
500
501 # it's possible that we'll get an error from sending
502 # (e.g. if method is UDP and there is no UDP listener,
503 # then we'll get ECONNREFUSED on the send). So what we
504 # want to do at this point is to fallback onto a different
505 # connection method.
5063543610.3ms while (scalar @fallbackMethods || $syslog_send) {
507354365.62ms if ($failed && (time - $fail_time) > 60) {
508 # it's been a while... maybe things have been fixed
509 @fallbackMethods = ();
510 disconnect_log();
511 $transmit_ok = 0; # make it look like a fresh attempt
512 connect_log();
513 }
514
5153543634.7ms35436257ms if ($connected && !connection_ok()) {
# spent 257ms making 35436 calls to Sys::Syslog::connection_ok, avg 7µs/call
516 # Something was OK, but has now broken. Remember coz we'll
517 # want to go back to what used to be OK.
518 $failed = $current_proto unless $failed;
519 $fail_time = time;
520 disconnect_log();
521 }
522
523354364.26ms connect_log() unless $connected;
524354366.92ms $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
525
526354365.52ms if ($syslog_send) {
5273543632.8ms35436251ms if ($syslog_send->($buf, $numpri, $numfac)) {
# spent 251ms making 35436 calls to Sys::Syslog::_syslog_send_socket, avg 7µs/call
528354365.39ms $transmit_ok++;
52935436128ms return 1;
530 }
531 # typically doesn't happen, since errors are rare from write().
532 disconnect_log();
533 }
534 }
535 # could not send, could not fallback onto a working
536 # connection method. Lose.
537 return 0;
538}
539
540sub _syslog_send_console {
541 my ($buf) = @_;
542
543 # The console print is a method which could block
544 # so we do it in a child process and always return success
545 # to the caller.
546 if (my $pid = fork) {
547
548 if ($options{nowait}) {
549 return 1;
550 } else {
551 if (waitpid($pid, 0) >= 0) {
552 return ($? >> 8);
553 } else {
554 # it's possible that the caller has other
555 # plans for SIGCHLD, so let's not interfere
556 return 1;
557 }
558 }
559 } else {
560 if (open(CONS, ">/dev/console")) {
561 my $ret = print CONS $buf . "\r"; # XXX: should this be \x0A ?
562 POSIX::_exit($ret) if defined $pid;
563 close CONS;
564 }
565
566 POSIX::_exit(0) if defined $pid;
567 }
568}
569
570sub _syslog_send_stream {
571 my ($buf) = @_;
572 # XXX: this only works if the OS stream implementation makes a write
573 # look like a putmsg() with simple header. For instance it works on
574 # Solaris 8 but not Solaris 7.
575 # To be correct, it should use a STREAMS API, but perl doesn't have one.
576 return syswrite(SYSLOG, $buf, length($buf));
577}
578
579sub _syslog_send_pipe {
580 my ($buf) = @_;
581 return print SYSLOG $buf;
582}
583
584
# spent 251ms (140+110) within Sys::Syslog::_syslog_send_socket which was called 35436 times, avg 7µs/call: # 35436 times (140ms+110ms) by Sys::Syslog::syslog at line 527, avg 7µs/call
sub _syslog_send_socket {
5853543612.1ms my ($buf) = @_;
58635436305ms35436110ms return syswrite(SYSLOG, $buf, length($buf));
# spent 110ms making 35436 calls to Sys::Syslog::CORE:syswrite, avg 3µs/call
587 #return send(SYSLOG, $buf, 0);
588}
589
590sub _syslog_send_native {
591 my ($buf, $numpri, $numfac) = @_;
592 syslog_xs($numpri|$numfac, $buf);
593 return 1;
594}
595
596
597# xlate()
598# -----
599# private function to translate names to numeric values
600#
601
# spent 1.09s (873ms+220ms) within Sys::Syslog::xlate which was called 70872 times, avg 15µs/call: # 35436 times (463ms+127ms) by Sys::Syslog::syslog at line 411, avg 17µs/call # 35436 times (410ms+93.2ms) by Sys::Syslog::syslog at line 440, avg 14µs/call
sub xlate {
6027087218.6ms my ($name) = @_;
603
60470872204ms7087238.0ms return $name+0 if $name =~ /^\s*\d+\s*$/;
# spent 38.0ms making 70872 calls to Sys::Syslog::CORE:match, avg 537ns/call
6057087221.3ms $name = uc $name;
60670872179ms7087214.5ms $name = "LOG_$name" unless $name =~ /^LOG_/;
# spent 14.5ms making 70872 calls to Sys::Syslog::CORE:match, avg 204ns/call
607
608 # ExtUtils::Constant 0.20 introduced a new way to implement
609 # constants, called ProxySubs. When it was used to generate
610 # the C code, the constant() function no longer returns the
611 # correct value. Therefore, we first try a direct call to
612 # constant(), and if the value is an error we try to call the
613 # constant by its full name.
61470872250ms7087274.1ms my $value = constant($name);
# spent 74.1ms making 70872 calls to Sys::Syslog::constant, avg 1µs/call
615
6167087231.5ms if (index($value, "not a valid") >= 0) {
6177087211.9ms $name = "Sys::Syslog::$name";
618141744285ms7087293.6ms $value = eval { no strict "refs"; &$name };
# spent 53.1ms making 35433 calls to Sys::Syslog::LOG_DEBUG, avg 1µs/call # spent 40.4ms making 35436 calls to Sys::Syslog::LOG_LOCAL1, avg 1µs/call # spent 55µs making 3 calls to Sys::Syslog::LOG_NOTICE, avg 18µs/call
6197087212.5ms $value = $@ unless defined $value;
620 }
621
6227087219.8ms $value = -1 if index($value, "not a valid") >= 0;
623
62470872144ms return defined $value ? $value : -1;
625}
626
627
628# connect_log()
629# -----------
630# This function acts as a kind of front-end: it tries to connect to
631# a syslog service using the selected methods, trying each one in the
632# selected order.
633#
634sub connect_log {
635 @fallbackMethods = @connectMethods unless scalar @fallbackMethods;
636
637 if ($transmit_ok && $current_proto) {
638 # Retry what we were on, because it has worked in the past.
639 unshift(@fallbackMethods, $current_proto);
640 }
641
642 $connected = 0;
643 my @errs = ();
644 my $proto = undef;
645
646 while ($proto = shift @fallbackMethods) {
647 no strict 'refs';
648 my $fn = "connect_$proto";
649 $connected = &$fn(\@errs) if defined &$fn;
650 last if $connected;
651 }
652
653 $transmit_ok = 0;
654 if ($connected) {
655 $current_proto = $proto;
656 my ($old) = select(SYSLOG); $| = 1; select($old);
657 } else {
658 @fallbackMethods = ();
659 $err_sub->(join "\n\t- ", "no connection to syslog available", @errs);
660 return undef;
661 }
662}
663
664sub connect_tcp {
665 my ($errs) = @_;
666
667 my $port = $sock_port
668 || eval { local $SIG{__DIE__}; getservbyname('syslog', 'tcp') }
669 || eval { local $SIG{__DIE__}; getservbyname('syslogng', 'tcp') };
670 if (!defined $port) {
671 push @$errs, "getservbyname failed for syslog/tcp and syslogng/tcp";
672 return 0;
673 }
674
675 my $addr;
676 if (defined $host) {
677 $addr = inet_aton($host);
678 if (!$addr) {
679 push @$errs, "can't lookup $host";
680 return 0;
681 }
682 } else {
683 $addr = INADDR_LOOPBACK;
684 }
685 $addr = sockaddr_in($port, $addr);
686
687 if (!socket(SYSLOG, AF_INET, SOCK_STREAM, SOCKET_IPPROTO_TCP)) {
688 push @$errs, "tcp socket: $!";
689 return 0;
690 }
691
692 setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
693 setsockopt(SYSLOG, SOCKET_IPPROTO_TCP, SOCKET_TCP_NODELAY, 1);
694
695 if (!connect(SYSLOG, $addr)) {
696 push @$errs, "tcp connect: $!";
697 return 0;
698 }
699
700 $syslog_send = \&_syslog_send_socket;
701
702 return 1;
703}
704
705sub connect_udp {
706 my ($errs) = @_;
707
708 my $port = $sock_port
709 || eval { local $SIG{__DIE__}; getservbyname('syslog', 'udp') };
710 if (!defined $port) {
711 push @$errs, "getservbyname failed for syslog/udp";
712 return 0;
713 }
714
715 my $addr;
716 if (defined $host) {
717 $addr = inet_aton($host);
718 if (!$addr) {
719 push @$errs, "can't lookup $host";
720 return 0;
721 }
722 } else {
723 $addr = INADDR_LOOPBACK;
724 }
725 $addr = sockaddr_in($port, $addr);
726
727 if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, SOCKET_IPPROTO_UDP)) {
728 push @$errs, "udp socket: $!";
729 return 0;
730 }
731 if (!connect(SYSLOG, $addr)) {
732 push @$errs, "udp connect: $!";
733 return 0;
734 }
735
736 # We want to check that the UDP connect worked. However the only
737 # way to do that is to send a message and see if an ICMP is returned
738 _syslog_send_socket("");
739 if (!connection_ok()) {
740 push @$errs, "udp connect: nobody listening";
741 return 0;
742 }
743
744 $syslog_send = \&_syslog_send_socket;
745
746 return 1;
747}
748
749sub connect_stream {
750 my ($errs) = @_;
751 # might want syslog_path to be variable based on syslog.h (if only
752 # it were in there!)
753 $syslog_path = '/dev/conslog' unless defined $syslog_path;
754
755 if (!-w $syslog_path) {
756 push @$errs, "stream $syslog_path is not writable";
757 return 0;
758 }
759
760 require Fcntl;
761
762 if (!sysopen(SYSLOG, $syslog_path, Fcntl::O_WRONLY(), 0400)) {
763 push @$errs, "stream can't open $syslog_path: $!";
764 return 0;
765 }
766
767 $syslog_send = \&_syslog_send_stream;
768
769 return 1;
770}
771
772sub connect_pipe {
773 my ($errs) = @_;
774
775 $syslog_path ||= &_PATH_LOG || "/dev/log";
776
777 if (not -w $syslog_path) {
778 push @$errs, "$syslog_path is not writable";
779 return 0;
780 }
781
782 if (not open(SYSLOG, ">$syslog_path")) {
783 push @$errs, "can't write to $syslog_path: $!";
784 return 0;
785 }
786
787 $syslog_send = \&_syslog_send_pipe;
788
789 return 1;
790}
791
792sub connect_unix {
793 my ($errs) = @_;
794
795 $syslog_path ||= _PATH_LOG() if length _PATH_LOG();
796
797 if (not defined $syslog_path) {
798 push @$errs, "_PATH_LOG not available in syslog.h and no user-supplied socket path";
799 return 0;
800 }
801
802 if (not (-S $syslog_path or -c _)) {
803 push @$errs, "$syslog_path is not a socket";
804 return 0;
805 }
806
807 my $addr = sockaddr_un($syslog_path);
808 if (!$addr) {
809 push @$errs, "can't locate $syslog_path";
810 return 0;
811 }
812 if (!socket(SYSLOG, AF_UNIX, SOCK_STREAM, 0)) {
813 push @$errs, "unix stream socket: $!";
814 return 0;
815 }
816
817 if (!connect(SYSLOG, $addr)) {
818 if (!socket(SYSLOG, AF_UNIX, SOCK_DGRAM, 0)) {
819 push @$errs, "unix dgram socket: $!";
820 return 0;
821 }
822 if (!connect(SYSLOG, $addr)) {
823 push @$errs, "unix dgram connect: $!";
824 return 0;
825 }
826 }
827
828 $syslog_send = \&_syslog_send_socket;
829
830 return 1;
831}
832
833sub connect_native {
834 my ($errs) = @_;
835 my $logopt = 0;
836
837 # reconstruct the numeric equivalent of the options
838 for my $opt (keys %options) {
839 $logopt += xlate($opt) if $options{$opt}
840 }
841
842 openlog_xs($ident, $logopt, xlate($facility));
843 $syslog_send = \&_syslog_send_native;
844
845 return 1;
846}
847
848sub connect_eventlog {
849 my ($errs) = @_;
850
851 $syslog_xobj = Sys::Syslog::Win32::_install();
852 $syslog_send = \&Sys::Syslog::Win32::_syslog_send;
853
854 return 1;
855}
856
857sub connect_console {
858 my ($errs) = @_;
859 if (!-w '/dev/console') {
860 push @$errs, "console is not writable";
861 return 0;
862 }
863 $syslog_send = \&_syslog_send_console;
864 return 1;
865}
866
867# To test if the connection is still good, we need to check if any
868# errors are present on the connection. The errors will not be raised
869# by a write. Instead, sockets are made readable and the next read
870# would cause the error to be returned. Unfortunately the syslog
871# 'protocol' never provides anything for us to read. But with
872# judicious use of select(), we can see if it would be readable...
873
# spent 257ms (207+50.4) within Sys::Syslog::connection_ok which was called 35436 times, avg 7µs/call: # 35436 times (207ms+50.4ms) by Sys::Syslog::syslog at line 515, avg 7µs/call
sub connection_ok {
8743543614.4ms return 1 if defined $current_proto and (
875 $current_proto eq 'native' or $current_proto eq 'console'
876 or $current_proto eq 'eventlog'
877 );
878
879354368.82ms my $rin = '';
8803543650.6ms vec($rin, fileno(SYSLOG), 1) = 1;
88135436154ms3543650.4ms my $ret = select $rin, undef, $rin, $sock_timeout;
# spent 50.4ms making 35436 calls to Sys::Syslog::CORE:sselect, avg 1µs/call
8823543682.7ms return ($ret ? 0 : 1);
883}
884
885sub disconnect_log {
886 $connected = 0;
887 $syslog_send = undef;
888
889 if (defined $current_proto and $current_proto eq 'native') {
890 closelog_xs();
891 unshift @fallbackMethods, $current_proto;
892 $current_proto = undef;
893 return 1;
894 }
895 elsif (defined $current_proto and $current_proto eq 'eventlog') {
896 $syslog_xobj->Close();
897 unshift @fallbackMethods, $current_proto;
898 $current_proto = undef;
899 return 1;
900 }
901
902 return close SYSLOG;
903}
904
905
906#
907# Wrappers around eval() that makes sure that nobody, ever knows that
908# we wanted to poke & test if something was here or not. This is needed
909# because some applications are trying to be too smart, install their
910# own __DIE__ handler, and mysteriously, things are starting to fail
911# when they shouldn't. SpamAssassin among them.
912#
913sub silent_eval (&) {
914 local($SIG{__DIE__}, $SIG{__WARN__}, $@);
915 return eval { $_[0]->() }
916}
917
918sub can_load_sys_syslog_win32 {
919 my ($verbose) = @_;
920 local($SIG{__DIE__}, $SIG{__WARN__}, $@);
921 (my $module_path = __FILE__) =~ s:Syslog.pm$:Syslog/Win32.pm:;
922 my $loaded = eval { require $module_path } ? 1 : 0;
923 warn $@ if not $loaded and $verbose;
924 return $loaded
925}
926
927
928"Eighth Rule: read the documentation."
929
930__END__
 
# spent 100ms within Sys::Syslog::CORE:match which was called 248052 times, avg 405ns/call: # 70872 times (38.5ms+0s) by Sys::Syslog::syslog at line 395, avg 544ns/call # 70872 times (38.0ms+0s) by Sys::Syslog::xlate at line 604, avg 537ns/call # 70872 times (14.5ms+0s) by Sys::Syslog::xlate at line 606, avg 204ns/call # 35436 times (9.37ms+0s) by Sys::Syslog::syslog at line 445, avg 264ns/call
sub Sys::Syslog::CORE:match; # opcode
# spent 50.4ms within Sys::Syslog::CORE:sselect which was called 35436 times, avg 1µs/call: # 35436 times (50.4ms+0s) by Sys::Syslog::connection_ok at line 881, avg 1µs/call
sub Sys::Syslog::CORE:sselect; # opcode
# spent 110ms within Sys::Syslog::CORE:syswrite which was called 35436 times, avg 3µs/call: # 35436 times (110ms+0s) by Sys::Syslog::_syslog_send_socket at line 586, avg 3µs/call
sub Sys::Syslog::CORE:syswrite; # opcode
# spent 53.1ms within Sys::Syslog::LOG_DEBUG which was called 35433 times, avg 1µs/call: # 35433 times (53.1ms+0s) by Sys::Syslog::xlate at line 618, avg 1µs/call
sub Sys::Syslog::LOG_DEBUG; # xsub
# spent 40.4ms within Sys::Syslog::LOG_LOCAL1 which was called 35436 times, avg 1µs/call: # 35436 times (40.4ms+0s) by Sys::Syslog::xlate at line 618, avg 1µs/call
sub Sys::Syslog::LOG_LOCAL1; # xsub
# spent 15.1ms within Sys::Syslog::LOG_MASK which was called 35436 times, avg 425ns/call: # 35436 times (15.1ms+0s) by Sys::Syslog::syslog at line 436, avg 425ns/call
sub Sys::Syslog::LOG_MASK; # xsub
# spent 55µs within Sys::Syslog::LOG_NOTICE which was called 3 times, avg 18µs/call: # 3 times (55µs+0s) by Sys::Syslog::xlate at line 618, avg 18µs/call
sub Sys::Syslog::LOG_NOTICE; # xsub
# spent 13.8ms within Sys::Syslog::LOG_PRIMASK which was called 35436 times, avg 389ns/call: # 35436 times (13.8ms+0s) by Sys::Syslog::syslog at line 413, avg 389ns/call
sub Sys::Syslog::LOG_PRIMASK; # xsub
# spent 74.1ms within Sys::Syslog::constant which was called 70872 times, avg 1µs/call: # 70872 times (74.1ms+0s) by Sys::Syslog::xlate at line 614, avg 1µs/call
sub Sys::Syslog::constant; # xsub