← Index
NYTProf Performance Profile   « block view • line view • sub view »
For mentat.storage.mongo.pl
  Run on Tue Jun 24 10:04:38 2014
Reported on Tue Jun 24 10:05:22 2014

Filename/usr/lib/perl/5.14/Sys/Syslog.pm
StatementsExecuted 77 statements in 4.02ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11152µs86µsSys::Syslog::::can_loadSys::Syslog::can_load
11113µs16µsSys::Syslog::::BEGIN@2Sys::Syslog::BEGIN@2
1119µs20µsSys::Syslog::::BEGIN@517Sys::Syslog::BEGIN@517
1118µs1.78msSys::Syslog::::BEGIN@10Sys::Syslog::BEGIN@10
1117µs25µsSys::Syslog::::BEGIN@78Sys::Syslog::BEGIN@78
1117µs17µsSys::Syslog::::BEGIN@153Sys::Syslog::BEGIN@153
1117µs16µsSys::Syslog::::BEGIN@546Sys::Syslog::BEGIN@546
1117µs17µsSys::Syslog::::BEGIN@13Sys::Syslog::BEGIN@13
1117µs38µsSys::Syslog::::BEGIN@8Sys::Syslog::BEGIN@8
1117µs75µsSys::Syslog::::BEGIN@4Sys::Syslog::BEGIN@4
3316µs6µsSys::Syslog::::CORE:matchSys::Syslog::CORE:match (opcode)
1116µs11µsSys::Syslog::::BEGIN@3Sys::Syslog::BEGIN@3
1116µs15µsSys::Syslog::::BEGIN@159Sys::Syslog::BEGIN@159
1116µs38µsSys::Syslog::::BEGIN@5Sys::Syslog::BEGIN@5
1116µs21µsSys::Syslog::::BEGIN@88Sys::Syslog::BEGIN@88
1116µs29µsSys::Syslog::::BEGIN@7Sys::Syslog::BEGIN@7
1116µs50µsSys::Syslog::::BEGIN@9Sys::Syslog::BEGIN@9
1114µs4µsSys::Syslog::::BEGIN@6Sys::Syslog::BEGIN@6
1113µs3µsSys::Syslog::::LOG_UPTOSys::Syslog::LOG_UPTO (xsub)
1111µs1µsSys::Syslog::::LOG_DEBUGSys::Syslog::LOG_DEBUG (xsub)
0000s0sSys::Syslog::::AUTOLOADSys::Syslog::AUTOLOAD
0000s0sSys::Syslog::::__ANON__[:160]Sys::Syslog::__ANON__[:160]
0000s0sSys::Syslog::::__ANON__[:597]Sys::Syslog::__ANON__[:597]
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_socketSys::Syslog::_syslog_send_socket
0000s0sSys::Syslog::::_syslog_send_streamSys::Syslog::_syslog_send_stream
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::::connection_okSys::Syslog::connection_ok
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
0000s0sSys::Syslog::::syslogSys::Syslog::syslog
0000s0sSys::Syslog::::xlateSys::Syslog::xlate
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;
2228µs219µs
# spent 16µs (13+3) within Sys::Syslog::BEGIN@2 which was called: # once (13µs+3µs) by Log::Writer::Syslog::BEGIN@70 at line 2
use strict;
# spent 16µs making 1 call to Sys::Syslog::BEGIN@2 # spent 3µs making 1 call to strict::import
3218µs216µs
# spent 11µs (6+5) within Sys::Syslog::BEGIN@3 which was called: # once (6µs+5µs) by Log::Writer::Syslog::BEGIN@70 at line 3
use warnings;
# spent 11µs making 1 call to Sys::Syslog::BEGIN@3 # spent 5µs making 1 call to warnings::import
4222µs2144µs
# spent 75µs (7+69) within Sys::Syslog::BEGIN@4 which was called: # once (7µs+69µs) by Log::Writer::Syslog::BEGIN@70 at line 4
use warnings::register;
# spent 75µs making 1 call to Sys::Syslog::BEGIN@4 # spent 69µs making 1 call to warnings::register::import
5221µs269µs
# spent 38µs (6+31) within Sys::Syslog::BEGIN@5 which was called: # once (6µs+31µs) by Log::Writer::Syslog::BEGIN@70 at line 5
use Carp;
# spent 38µs making 1 call to Sys::Syslog::BEGIN@5 # spent 32µs making 1 call to Exporter::import
6219µs14µs
# spent 4µs within Sys::Syslog::BEGIN@6 which was called: # once (4µs+0s) by Log::Writer::Syslog::BEGIN@70 at line 6
use Exporter ();
# spent 4µs making 1 call to Sys::Syslog::BEGIN@6
7221µs253µs
# spent 29µs (6+24) within Sys::Syslog::BEGIN@7 which was called: # once (6µs+24µs) by Log::Writer::Syslog::BEGIN@70 at line 7
use Fcntl qw(O_WRONLY);
# spent 29µs making 1 call to Sys::Syslog::BEGIN@7 # spent 24µs making 1 call to Exporter::import
8223µs269µs
# spent 38µs (7+31) within Sys::Syslog::BEGIN@8 which was called: # once (7µs+31µs) by Log::Writer::Syslog::BEGIN@70 at line 8
use File::Basename;
# spent 38µs making 1 call to Sys::Syslog::BEGIN@8 # spent 31µs making 1 call to Exporter::import
9228µs294µs
# spent 50µs (6+44) within Sys::Syslog::BEGIN@9 which was called: # once (6µs+44µs) by Log::Writer::Syslog::BEGIN@70 at line 9
use POSIX qw(strftime setlocale LC_TIME);
# spent 50µs making 1 call to Sys::Syslog::BEGIN@9 # spent 44µs making 1 call to POSIX::import
10234µs23.56ms
# spent 1.78ms (8µs+1.78) within Sys::Syslog::BEGIN@10 which was called: # once (8µs+1.78ms) by Log::Writer::Syslog::BEGIN@70 at line 10
use Socket ':all';
# spent 1.78ms making 1 call to Sys::Syslog::BEGIN@10 # spent 1.78ms making 1 call to Exporter::import
11117µsrequire 5.005;
12
133180µs228µs
# spent 17µs (7+11) within Sys::Syslog::BEGIN@13 which was called: # once (7µs+11µs) by Log::Writer::Syslog::BEGIN@70 at line 13
{ no strict 'vars';
# spent 17µs making 1 call to Sys::Syslog::BEGIN@13 # spent 11µs making 1 call to strict::unimport
14623µs $VERSION = '0.27';
15 @ISA = qw(Exporter);
16
17 %EXPORT_TAGS = (
18 standard => [qw(openlog syslog closelog setlogmask)],
19 extended => [qw(setlogsock)],
20 macros => [
21 # levels
22 qw(
23 LOG_ALERT LOG_CRIT LOG_DEBUG LOG_EMERG LOG_ERR
24 LOG_INFO LOG_NOTICE LOG_WARNING
25 ),
26
27 # standard facilities
28 qw(
29 LOG_AUTH LOG_AUTHPRIV LOG_CRON LOG_DAEMON LOG_FTP LOG_KERN
30 LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4
31 LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NEWS
32 LOG_SYSLOG LOG_USER LOG_UUCP
33 ),
34 # Mac OS X specific facilities
35 qw( LOG_INSTALL LOG_LAUNCHD LOG_NETINFO LOG_RAS LOG_REMOTEAUTH ),
36 # modern BSD specific facilities
37 qw( LOG_CONSOLE LOG_NTP LOG_SECURITY ),
38 # IRIX specific facilities
39 qw( LOG_AUDIT LOG_LFMT ),
40
41 # options
42 qw(
43 LOG_CONS LOG_PID LOG_NDELAY LOG_NOWAIT LOG_ODELAY LOG_PERROR
44 ),
45
46 # others macros
47 qw(
48 LOG_FACMASK LOG_NFACILITIES LOG_PRIMASK
49 LOG_MASK LOG_UPTO
50 ),
51 ],
52 );
53
54 @EXPORT = (
551700ns @{$EXPORT_TAGS{standard}},
56 );
57
58 @EXPORT_OK = (
59 @{$EXPORT_TAGS{extended}},
602300ns @{$EXPORT_TAGS{macros}},
61 );
62
63 eval {
64 require XSLoader;
651178µs XSLoader::load('Sys::Syslog', $VERSION);
# spent 178µs making 1 call to XSLoader::load
66 1
673186µs } or do {
68 require DynaLoader;
69 push @ISA, 'DynaLoader';
70 bootstrap Sys::Syslog $VERSION;
71 };
72}
73
74
75#
76# Public variables
77#
78232µs244µs
# spent 25µs (7+18) within Sys::Syslog::BEGIN@78 which was called: # once (7µs+18µs) by Log::Writer::Syslog::BEGIN@70 at line 78
use vars qw($host); # host to send syslog messages to (see notes at end)
# spent 25µs making 1 call to Sys::Syslog::BEGIN@78 # spent 18µs making 1 call to vars::import
79
80#
81# Prototypes
82#
83sub silent_eval (&);
84
85#
86# Global variables
87#
882243µs236µs
# spent 21µs (6+15) within Sys::Syslog::BEGIN@88 which was called: # once (6µs+15µs) by Log::Writer::Syslog::BEGIN@70 at line 88
use vars qw($facility);
# spent 21µs making 1 call to Sys::Syslog::BEGIN@88 # spent 15µs making 1 call to vars::import
891300nsmy $connected = 0; # flag to indicate if we're connected or not
901100nsmy $syslog_send; # coderef of the function used to send messages
911200nsmy $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms
921100nsmy $syslog_xobj = undef; # if defined, holds the external object used to send messages
931100nsmy $transmit_ok = 0; # flag to indicate if the last message was transmited
941100nsmy $sock_timeout = 0; # socket timeout, see below
951100nsmy $current_proto = undef; # current mechanism used to transmit messages
961400nsmy $ident = ''; # identifiant prepended to each message
971200ns$facility = ''; # current facility
98114µs24µsmy $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask
# spent 3µs making 1 call to Sys::Syslog::LOG_UPTO # spent 1µs making 1 call to Sys::Syslog::LOG_DEBUG
99
10012µsmy %options = (
101 ndelay => 0,
102 nofatal => 0,
103 nowait => 0,
104 perror => 0,
105 pid => 0,
106);
107
108# Default is now to first use the native mechanism, so Perl programs
109# behave like other normal Unix programs, then try other mechanisms.
11011µsmy @connectMethods = qw(native tcp udp unix pipe stream console);
111212µs14µsif ($^O =~ /^(freebsd|linux)$/) {
# spent 4µs making 1 call to Sys::Syslog::CORE:match
11271µs @connectMethods = grep { $_ ne 'udp' } @connectMethods;
113}
114
115# And on Win32 systems, we try to use the native mechanism for this
116# platform, the events logger, available through Win32::EventLog.
117EVENTLOG: {
11836µs1900ns my $is_Win32 = $^O =~ /Win32/i;
# spent 900ns making 1 call to Sys::Syslog::CORE:match
119
120186µs if (can_load("Sys::Syslog::Win32")) {
# spent 86µs making 1 call to Sys::Syslog::can_load
121 unshift @connectMethods, 'eventlog';
122 }
123 elsif ($is_Win32) {
124 warn $@;
125 }
126}
127
12812µsmy @defaultMethods = @connectMethods;
1291300nsmy @fallbackMethods = ();
130
131# The timeout in connection_ok() was pushed up to 0.25 sec in
132# Sys::Syslog v0.19 in order to address a heisenbug on MacOSX:
133# http://london.pm.org/pipermail/london.pm/Week-of-Mon-20061211/005961.html
134#
135# However, this also had the effect of slowing this test for
136# all other operating systems, which apparently impacted some
137# users (cf. CPAN-RT #34753). So, in order to make everybody
138# happy, the timeout is now zero by default on all systems
139# except on OSX where it is set to 250 msec, and can be set
140# with the infamous setlogsock() function.
141#
142# Debian change: include Debian GNU/kFreeBSD, lower to 1ms
143# see [rt.cpan.org #69997]
14413µs1800ns$sock_timeout = 0.001 if $^O =~ /darwin|gnukfreebsd/;
# spent 800ns making 1 call to Sys::Syslog::CORE:match
145
146# coderef for a nicer handling of errors
14711µsmy $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
148
149
150sub AUTOLOAD {
151 # This AUTOLOAD is used to 'autoload' constants from the constant()
152 # XS function.
153270µs228µs
# spent 17µs (7+10) within Sys::Syslog::BEGIN@153 which was called: # once (7µs+10µs) by Log::Writer::Syslog::BEGIN@70 at line 153
no strict 'vars';
# spent 17µs making 1 call to Sys::Syslog::BEGIN@153 # spent 10µs making 1 call to strict::unimport
154 my $constname;
155 ($constname = $AUTOLOAD) =~ s/.*:://;
156 croak "Sys::Syslog::constant() not defined" if $constname eq 'constant';
157 my ($error, $val) = constant($constname);
158 croak $error if $error;
15921.56ms224µs
# spent 15µs (6+9) within Sys::Syslog::BEGIN@159 which was called: # once (6µs+9µs) by Log::Writer::Syslog::BEGIN@70 at line 159
no strict 'refs';
# spent 15µs making 1 call to Sys::Syslog::BEGIN@159 # spent 9µs making 1 call to strict::unimport
160 *$AUTOLOAD = sub { $val };
161 goto &$AUTOLOAD;
162}
163
164
165sub openlog {
166 ($ident, my $logopt, $facility) = @_;
167
168 # default values
169 $ident ||= basename($0) || getlogin() || getpwuid($<) || 'syslog';
170 $logopt ||= '';
171 $facility ||= LOG_USER();
172
173 for my $opt (split /\b/, $logopt) {
174 $options{$opt} = 1 if exists $options{$opt}
175 }
176
177 $err_sub = delete $options{nofatal} ? \&warnings::warnif : \&croak;
178 return 1 unless $options{ndelay};
179 connect_log();
180}
181
182sub closelog {
183 $facility = $ident = '';
184 disconnect_log();
185}
186
187sub setlogmask {
188 my $oldmask = $maskpri;
189 $maskpri = shift unless $_[0] == 0;
190 $oldmask;
191}
192
193sub setlogsock {
194 my ($setsock, $setpath, $settime) = @_;
195
196 # check arguments
197 my $diag_invalid_arg
198 = "Invalid argument passed to setlogsock; must be 'stream', 'pipe', "
199 . "'unix', 'native', 'eventlog', 'tcp', 'udp' or 'inet'";
200 croak $diag_invalid_arg unless defined $setsock;
201 croak "Invalid number of arguments" unless @_ >= 1 and @_ <= 3;
202
203 $syslog_path = $setpath if defined $setpath;
204 $sock_timeout = $settime if defined $settime;
205
206 disconnect_log() if $connected;
207 $transmit_ok = 0;
208 @fallbackMethods = ();
209 @connectMethods = @defaultMethods;
210
211 if (ref $setsock eq 'ARRAY') {
212 @connectMethods = @$setsock;
213
214 } elsif (lc $setsock eq 'stream') {
215 if (not defined $syslog_path) {
216 my @try = qw(/dev/log /dev/conslog);
217
218 if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
219 unshift @try, &_PATH_LOG;
220 }
221
222 for my $try (@try) {
223 if (-w $try) {
224 $syslog_path = $try;
225 last;
226 }
227 }
228
229 if (not defined $syslog_path) {
230 warnings::warnif "stream passed to setlogsock, but could not find any device";
231 return undef
232 }
233 }
234
235 if (not -w $syslog_path) {
236 warnings::warnif "stream passed to setlogsock, but $syslog_path is not writable";
237 return undef;
238 } else {
239 @connectMethods = qw(stream);
240 }
241
242 } elsif (lc $setsock eq 'unix') {
243 if (length _PATH_LOG() || (defined $syslog_path && -w $syslog_path)) {
244 $syslog_path = _PATH_LOG() unless defined $syslog_path;
245 @connectMethods = qw(unix);
246 } else {
247 warnings::warnif 'unix passed to setlogsock, but path not available';
248 return undef;
249 }
250
251 } elsif (lc $setsock eq 'pipe') {
252 for my $path ($syslog_path, &_PATH_LOG, "/dev/log") {
253 next unless defined $path and length $path and -p $path and -w _;
254 $syslog_path = $path;
255 last
256 }
257
258 if (not $syslog_path) {
259 warnings::warnif "pipe passed to setlogsock, but path not available";
260 return undef
261 }
262
263 @connectMethods = qw(pipe);
264
265 } elsif (lc $setsock eq 'native') {
266 @connectMethods = qw(native);
267
268 } elsif (lc $setsock eq 'eventlog') {
269 if (can_load("Win32::EventLog")) {
270 @connectMethods = qw(eventlog);
271 } else {
272 warnings::warnif "eventlog passed to setlogsock, but no Win32 API available";
273 $@ = "";
274 return undef;
275 }
276
277 } elsif (lc $setsock eq 'tcp') {
278 if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
279 @connectMethods = qw(tcp);
280 $host = $syslog_path;
281 } else {
282 warnings::warnif "tcp passed to setlogsock, but tcp service unavailable";
283 return undef;
284 }
285
286 } elsif (lc $setsock eq 'udp') {
287 if (getservbyname('syslog', 'udp')) {
288 @connectMethods = qw(udp);
289 $host = $syslog_path;
290 } else {
291 warnings::warnif "udp passed to setlogsock, but udp service unavailable";
292 return undef;
293 }
294
295 } elsif (lc $setsock eq 'inet') {
296 @connectMethods = ( 'tcp', 'udp' );
297
298 } elsif (lc $setsock eq 'console') {
299 @connectMethods = qw(console);
300
301 } else {
302 croak $diag_invalid_arg
303 }
304
305 return 1;
306}
307
308sub syslog {
309 my $priority = shift;
310 my $mask = shift;
311 my ($message, $buf);
312 my (@words, $num, $numpri, $numfac, $sum);
313 my $failed = undef;
314 my $fail_time = undef;
315 my $error = $!;
316
317 # if $ident is undefined, it means openlog() wasn't previously called
318 # so do it now in order to have sensible defaults
319 openlog() unless $ident;
320
321 local $facility = $facility; # may need to change temporarily.
322
323 croak "syslog: expecting argument \$priority" unless defined $priority;
324 croak "syslog: expecting argument \$format" unless defined $mask;
325
326 croak "syslog: invalid level/facility: $priority" if $priority =~ /^-\d+$/;
327 @words = split(/\W+/, $priority, 2); # Allow "level" or "level|facility".
328 undef $numpri;
329 undef $numfac;
330
331 for my $word (@words) {
332 next if length $word == 0;
333
334 $num = xlate($word); # Translate word to number.
335
336 if ($num < 0) {
337 croak "syslog: invalid level/facility: $word"
338 }
339 elsif ($num <= &LOG_PRIMASK) {
340 croak "syslog: too many levels given: $word" if defined $numpri;
341 $numpri = $num;
342 return 0 unless LOG_MASK($numpri) & $maskpri;
343 }
344 else {
345 croak "syslog: too many facilities given: $word" if defined $numfac;
346 $facility = $word;
347 $numfac = $num;
348 }
349 }
350
351 croak "syslog: level must be given" unless defined $numpri;
352
353 if (not defined $numfac) { # Facility not specified in this call.
354 $facility = 'user' unless $facility;
355 $numfac = xlate($facility);
356 }
357
358 connect_log() unless $connected;
359
360 if ($mask =~ /%m/) {
361 # escape percent signs for sprintf()
362 $error =~ s/%/%%/g if @_;
363 # replace %m with $error, if preceded by an even number of percent signs
364 $mask =~ s/(?<!%)((?:%%)*)%m/$1$error/g;
365 }
366
367 $mask .= "\n" unless $mask =~ /\n$/;
368 $message = @_ ? sprintf($mask, @_) : $mask;
369
370 # See CPAN-RT#24431. Opened on Apple Radar as bug #4944407 on 2007.01.21
371 # Supposedly resolved on Leopard.
372 chomp $message if $^O =~ /darwin/;
373
374 if ($current_proto eq 'native') {
375 $buf = $message;
376 }
377 elsif ($current_proto eq 'eventlog') {
378 $buf = $message;
379 }
380 else {
381 my $whoami = $ident;
382 $whoami .= "[$$]" if $options{pid};
383
384 $sum = $numpri + $numfac;
385 my $oldlocale = setlocale(LC_TIME);
386 setlocale(LC_TIME, 'C');
387 my $timestamp = strftime "%b %e %T", localtime;
388 setlocale(LC_TIME, $oldlocale);
389 $buf = "<$sum>$timestamp $whoami: $message\0";
390 }
391
392 # handle PERROR option
393 # "native" mechanism already handles it by itself
394 if ($options{perror} and $current_proto ne 'native') {
395 chomp $message;
396 my $whoami = $ident;
397 $whoami .= "[$$]" if $options{pid};
398 print STDERR "$whoami: $message\n";
399 }
400
401 # it's possible that we'll get an error from sending
402 # (e.g. if method is UDP and there is no UDP listener,
403 # then we'll get ECONNREFUSED on the send). So what we
404 # want to do at this point is to fallback onto a different
405 # connection method.
406 while (scalar @fallbackMethods || $syslog_send) {
407 if ($failed && (time - $fail_time) > 60) {
408 # it's been a while... maybe things have been fixed
409 @fallbackMethods = ();
410 disconnect_log();
411 $transmit_ok = 0; # make it look like a fresh attempt
412 connect_log();
413 }
414
415 if ($connected && !connection_ok()) {
416 # Something was OK, but has now broken. Remember coz we'll
417 # want to go back to what used to be OK.
418 $failed = $current_proto unless $failed;
419 $fail_time = time;
420 disconnect_log();
421 }
422
423 connect_log() unless $connected;
424 $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
425
426 if ($syslog_send) {
427 if ($syslog_send->($buf, $numpri, $numfac)) {
428 $transmit_ok++;
429 return 1;
430 }
431 # typically doesn't happen, since errors are rare from write().
432 disconnect_log();
433 }
434 }
435 # could not send, could not fallback onto a working
436 # connection method. Lose.
437 return 0;
438}
439
440sub _syslog_send_console {
441 my ($buf) = @_;
442 chop($buf); # delete the NUL from the end
443 # The console print is a method which could block
444 # so we do it in a child process and always return success
445 # to the caller.
446 if (my $pid = fork) {
447
448 if ($options{nowait}) {
449 return 1;
450 } else {
451 if (waitpid($pid, 0) >= 0) {
452 return ($? >> 8);
453 } else {
454 # it's possible that the caller has other
455 # plans for SIGCHLD, so let's not interfere
456 return 1;
457 }
458 }
459 } else {
460 if (open(CONS, ">/dev/console")) {
461 my $ret = print CONS $buf . "\r"; # XXX: should this be \x0A ?
462 exit $ret if defined $pid;
463 close CONS;
464 }
465 exit if defined $pid;
466 }
467}
468
469sub _syslog_send_stream {
470 my ($buf) = @_;
471 # XXX: this only works if the OS stream implementation makes a write
472 # look like a putmsg() with simple header. For instance it works on
473 # Solaris 8 but not Solaris 7.
474 # To be correct, it should use a STREAMS API, but perl doesn't have one.
475 return syswrite(SYSLOG, $buf, length($buf));
476}
477
478sub _syslog_send_pipe {
479 my ($buf) = @_;
480 return print SYSLOG $buf;
481}
482
483sub _syslog_send_socket {
484 my ($buf) = @_;
485 return syswrite(SYSLOG, $buf, length($buf));
486 #return send(SYSLOG, $buf, 0);
487}
488
489sub _syslog_send_native {
490 my ($buf, $numpri) = @_;
491 syslog_xs($numpri, $buf);
492 return 1;
493}
494
495
496# xlate()
497# -----
498# private function to translate names to numeric values
499#
500sub xlate {
501 my ($name) = @_;
502
503 return $name+0 if $name =~ /^\s*\d+\s*$/;
504 $name = uc $name;
505 $name = "LOG_$name" unless $name =~ /^LOG_/;
506
507 # ExtUtils::Constant 0.20 introduced a new way to implement
508 # constants, called ProxySubs. When it was used to generate
509 # the C code, the constant() function no longer returns the
510 # correct value. Therefore, we first try a direct call to
511 # constant(), and if the value is an error we try to call the
512 # constant by its full name.
513 my $value = constant($name);
514
515 if (index($value, "not a valid") >= 0) {
516 $name = "Sys::Syslog::$name";
5172114µs231µs
# spent 20µs (9+11) within Sys::Syslog::BEGIN@517 which was called: # once (9µs+11µs) by Log::Writer::Syslog::BEGIN@70 at line 517
$value = eval { no strict "refs"; &$name };
# spent 20µs making 1 call to Sys::Syslog::BEGIN@517 # spent 11µs making 1 call to strict::unimport
518 $value = $@ unless defined $value;
519 }
520
521 $value = -1 if index($value, "not a valid") >= 0;
522
523 return defined $value ? $value : -1;
524}
525
526
527# connect_log()
528# -----------
529# This function acts as a kind of front-end: it tries to connect to
530# a syslog service using the selected methods, trying each one in the
531# selected order.
532#
533sub connect_log {
534 @fallbackMethods = @connectMethods unless scalar @fallbackMethods;
535
536 if ($transmit_ok && $current_proto) {
537 # Retry what we were on, because it has worked in the past.
538 unshift(@fallbackMethods, $current_proto);
539 }
540
541 $connected = 0;
542 my @errs = ();
543 my $proto = undef;
544
545 while ($proto = shift @fallbackMethods) {
54621.27ms225µs
# spent 16µs (7+9) within Sys::Syslog::BEGIN@546 which was called: # once (7µs+9µs) by Log::Writer::Syslog::BEGIN@70 at line 546
no strict 'refs';
# spent 16µs making 1 call to Sys::Syslog::BEGIN@546 # spent 9µs making 1 call to strict::unimport
547 my $fn = "connect_$proto";
548 $connected = &$fn(\@errs) if defined &$fn;
549 last if $connected;
550 }
551
552 $transmit_ok = 0;
553 if ($connected) {
554 $current_proto = $proto;
555 my ($old) = select(SYSLOG); $| = 1; select($old);
556 } else {
557 @fallbackMethods = ();
558 $err_sub->(join "\n\t- ", "no connection to syslog available", @errs);
559 return undef;
560 }
561}
562
563sub connect_tcp {
564 my ($errs) = @_;
565
566 my $tcp = getprotobyname('tcp');
567 if (!defined $tcp) {
568 push @$errs, "getprotobyname failed for tcp";
569 return 0;
570 }
571
572 my $syslog = getservbyname('syslog', 'tcp');
573 $syslog = getservbyname('syslogng', 'tcp') unless defined $syslog;
574 if (!defined $syslog) {
575 push @$errs, "getservbyname failed for syslog/tcp and syslogng/tcp";
576 return 0;
577 }
578
579 my $addr;
580 if (defined $host) {
581 $addr = inet_aton($host);
582 if (!$addr) {
583 push @$errs, "can't lookup $host";
584 return 0;
585 }
586 } else {
587 $addr = INADDR_LOOPBACK;
588 }
589 $addr = sockaddr_in($syslog, $addr);
590
591 if (!socket(SYSLOG, AF_INET, SOCK_STREAM, $tcp)) {
592 push @$errs, "tcp socket: $!";
593 return 0;
594 }
595
596 setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
597 if (silent_eval { IPPROTO_TCP() }) {
598 # These constants don't exist in 5.005. They were added in 1999
599 setsockopt(SYSLOG, IPPROTO_TCP(), TCP_NODELAY(), 1);
600 }
601 if (!connect(SYSLOG, $addr)) {
602 push @$errs, "tcp connect: $!";
603 return 0;
604 }
605
606 $syslog_send = \&_syslog_send_socket;
607
608 return 1;
609}
610
611sub connect_udp {
612 my ($errs) = @_;
613
614 my $udp = getprotobyname('udp');
615 if (!defined $udp) {
616 push @$errs, "getprotobyname failed for udp";
617 return 0;
618 }
619
620 my $syslog = getservbyname('syslog', 'udp');
621 if (!defined $syslog) {
622 push @$errs, "getservbyname failed for syslog/udp";
623 return 0;
624 }
625
626 my $addr;
627 if (defined $host) {
628 $addr = inet_aton($host);
629 if (!$addr) {
630 push @$errs, "can't lookup $host";
631 return 0;
632 }
633 } else {
634 $addr = INADDR_LOOPBACK;
635 }
636 $addr = sockaddr_in($syslog, $addr);
637
638 if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, $udp)) {
639 push @$errs, "udp socket: $!";
640 return 0;
641 }
642 if (!connect(SYSLOG, $addr)) {
643 push @$errs, "udp connect: $!";
644 return 0;
645 }
646
647 # We want to check that the UDP connect worked. However the only
648 # way to do that is to send a message and see if an ICMP is returned
649 _syslog_send_socket("");
650 if (!connection_ok()) {
651 push @$errs, "udp connect: nobody listening";
652 return 0;
653 }
654
655 $syslog_send = \&_syslog_send_socket;
656
657 return 1;
658}
659
660sub connect_stream {
661 my ($errs) = @_;
662 # might want syslog_path to be variable based on syslog.h (if only
663 # it were in there!)
664 $syslog_path = '/dev/conslog' unless defined $syslog_path;
665 if (!-w $syslog_path) {
666 push @$errs, "stream $syslog_path is not writable";
667 return 0;
668 }
669 if (!sysopen(SYSLOG, $syslog_path, O_WRONLY, 0400)) {
670 push @$errs, "stream can't open $syslog_path: $!";
671 return 0;
672 }
673 $syslog_send = \&_syslog_send_stream;
674 return 1;
675}
676
677sub connect_pipe {
678 my ($errs) = @_;
679
680 $syslog_path ||= &_PATH_LOG || "/dev/log";
681
682 if (not -w $syslog_path) {
683 push @$errs, "$syslog_path is not writable";
684 return 0;
685 }
686
687 if (not open(SYSLOG, ">$syslog_path")) {
688 push @$errs, "can't write to $syslog_path: $!";
689 return 0;
690 }
691
692 $syslog_send = \&_syslog_send_pipe;
693
694 return 1;
695}
696
697sub connect_unix {
698 my ($errs) = @_;
699
700 $syslog_path ||= _PATH_LOG() if length _PATH_LOG();
701
702 if (not defined $syslog_path) {
703 push @$errs, "_PATH_LOG not available in syslog.h and no user-supplied socket path";
704 return 0;
705 }
706
707 if (not (-S $syslog_path or -c _)) {
708 push @$errs, "$syslog_path is not a socket";
709 return 0;
710 }
711
712 my $addr = sockaddr_un($syslog_path);
713 if (!$addr) {
714 push @$errs, "can't locate $syslog_path";
715 return 0;
716 }
717 if (!socket(SYSLOG, AF_UNIX, SOCK_STREAM, 0)) {
718 push @$errs, "unix stream socket: $!";
719 return 0;
720 }
721
722 if (!connect(SYSLOG, $addr)) {
723 if (!socket(SYSLOG, AF_UNIX, SOCK_DGRAM, 0)) {
724 push @$errs, "unix dgram socket: $!";
725 return 0;
726 }
727 if (!connect(SYSLOG, $addr)) {
728 push @$errs, "unix dgram connect: $!";
729 return 0;
730 }
731 }
732
733 $syslog_send = \&_syslog_send_socket;
734
735 return 1;
736}
737
738sub connect_native {
739 my ($errs) = @_;
740 my $logopt = 0;
741
742 # reconstruct the numeric equivalent of the options
743 for my $opt (keys %options) {
744 $logopt += xlate($opt) if $options{$opt}
745 }
746
747 openlog_xs($ident, $logopt, xlate($facility));
748 $syslog_send = \&_syslog_send_native;
749
750 return 1;
751}
752
753sub connect_eventlog {
754 my ($errs) = @_;
755
756 $syslog_xobj = Sys::Syslog::Win32::_install();
757 $syslog_send = \&Sys::Syslog::Win32::_syslog_send;
758
759 return 1;
760}
761
762sub connect_console {
763 my ($errs) = @_;
764 if (!-w '/dev/console') {
765 push @$errs, "console is not writable";
766 return 0;
767 }
768 $syslog_send = \&_syslog_send_console;
769 return 1;
770}
771
772# To test if the connection is still good, we need to check if any
773# errors are present on the connection. The errors will not be raised
774# by a write. Instead, sockets are made readable and the next read
775# would cause the error to be returned. Unfortunately the syslog
776# 'protocol' never provides anything for us to read. But with
777# judicious use of select(), we can see if it would be readable...
778sub connection_ok {
779 return 1 if defined $current_proto and (
780 $current_proto eq 'native' or $current_proto eq 'console'
781 or $current_proto eq 'eventlog'
782 );
783
784 my $rin = '';
785 vec($rin, fileno(SYSLOG), 1) = 1;
786 my $ret = select $rin, undef, $rin, $sock_timeout;
787 return ($ret ? 0 : 1);
788}
789
790sub disconnect_log {
791 $connected = 0;
792 $syslog_send = undef;
793
794 if (defined $current_proto and $current_proto eq 'native') {
795 closelog_xs();
796 return 1;
797 }
798 elsif (defined $current_proto and $current_proto eq 'eventlog') {
799 $syslog_xobj->Close();
800 return 1;
801 }
802
803 return close SYSLOG;
804}
805
806
807#
808# Wrappers around eval() that makes sure that nobody, and I say NOBODY,
809# ever knows that I wanted to test if something was here or not.
810# It is needed because some applications are trying to be too smart,
811# do it wrong, and it ends up in EPIC FAIL.
812# Yes I'm speaking of YOU, SpamAssassin.
813#
814sub silent_eval (&) {
815 local($SIG{__DIE__}, $SIG{__WARN__}, $@);
816 return eval { $_[0]->() }
817}
818
819
# spent 86µs (52+35) within Sys::Syslog::can_load which was called: # once (52µs+35µs) by Log::Writer::Syslog::BEGIN@70 at line 120
sub can_load {
820239µs local($SIG{__DIE__}, $SIG{__WARN__}, $@);
821 return eval "use $_[0]; 1"
# spent 49µs executing statements in string eval
# includes 34µs spent executing 1 call to 1 sub defined therein.
822}
823
824
825127µs"Eighth Rule: read the documentation."
826
827__END__
 
# spent 6µs within Sys::Syslog::CORE:match which was called 3 times, avg 2µs/call: # once (4µs+0s) by Log::Writer::Syslog::BEGIN@70 at line 111 # once (900ns+0s) by Log::Writer::Syslog::BEGIN@70 at line 118 # once (800ns+0s) by Log::Writer::Syslog::BEGIN@70 at line 144
sub Sys::Syslog::CORE:match; # opcode
# spent 1µs within Sys::Syslog::LOG_DEBUG which was called: # once (1µs+0s) by Log::Writer::Syslog::BEGIN@70 at line 98
sub Sys::Syslog::LOG_DEBUG; # xsub
# spent 3µs within Sys::Syslog::LOG_UPTO which was called: # once (3µs+0s) by Log::Writer::Syslog::BEGIN@70 at line 98
sub Sys::Syslog::LOG_UPTO; # xsub