← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Tue Nov 7 05:38:10 2017
Reported on Tue Nov 7 06:16:03 2017

Filename/usr/local/lib/perl5/5.24/mach/Sys/Syslog.pm
StatementsExecuted 82 statements in 10.9ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111127µs248µsSys::Syslog::::can_loadSys::Syslog::can_load
11142µs59µsSys::Syslog::::BEGIN@2Sys::Syslog::BEGIN@2
11132µs81µsSys::Syslog::::BEGIN@605Sys::Syslog::BEGIN@605
11132µs97µsSys::Syslog::::BEGIN@576Sys::Syslog::BEGIN@576
11131µs78µsSys::Syslog::::BEGIN@163Sys::Syslog::BEGIN@163
11129µs296µsSys::Syslog::::BEGIN@7Sys::Syslog::BEGIN@7
11129µs714µsSys::Syslog::::BEGIN@4Sys::Syslog::BEGIN@4
11128µs82µsSys::Syslog::::BEGIN@13Sys::Syslog::BEGIN@13
11128µs89µsSys::Syslog::::BEGIN@87Sys::Syslog::BEGIN@87
11127µs249µsSys::Syslog::::BEGIN@5Sys::Syslog::BEGIN@5
11124µs12.1msSys::Syslog::::BEGIN@9Sys::Syslog::BEGIN@9
11124µs85µsSys::Syslog::::BEGIN@77Sys::Syslog::BEGIN@77
11124µs60µsSys::Syslog::::BEGIN@3Sys::Syslog::BEGIN@3
11122µs263µsSys::Syslog::::BEGIN@8Sys::Syslog::BEGIN@8
11122µs73µsSys::Syslog::::BEGIN@169Sys::Syslog::BEGIN@169
11120µs52µsSys::Syslog::::BEGIN@6Sys::Syslog::BEGIN@6
22111µs11µsSys::Syslog::::CORE:matchSys::Syslog::CORE:match (opcode)
1116µs6µsSys::Syslog::::LOG_UPTOSys::Syslog::LOG_UPTO (xsub)
1114µs4µsSys::Syslog::::LOG_DEBUGSys::Syslog::LOG_DEBUG (xsub)
0000s0sSys::Syslog::::AUTOLOADSys::Syslog::AUTOLOAD
0000s0sSys::Syslog::::__ANON__[:153]Sys::Syslog::__ANON__[:153]
0000s0sSys::Syslog::::__ANON__[:170]Sys::Syslog::__ANON__[:170]
0000s0sSys::Syslog::::__ANON__[:209]Sys::Syslog::__ANON__[:209]
0000s0sSys::Syslog::::__ANON__[:212]Sys::Syslog::__ANON__[:212]
0000s0sSys::Syslog::::__ANON__[:216]Sys::Syslog::__ANON__[:216]
0000s0sSys::Syslog::::__ANON__[:219]Sys::Syslog::__ANON__[:219]
0000s0sSys::Syslog::::__ANON__[:226]Sys::Syslog::__ANON__[:226]
0000s0sSys::Syslog::::__ANON__[:237]Sys::Syslog::__ANON__[:237]
0000s0sSys::Syslog::::__ANON__[:251]Sys::Syslog::__ANON__[:251]
0000s0sSys::Syslog::::__ANON__[:265]Sys::Syslog::__ANON__[:265]
0000s0sSys::Syslog::::__ANON__[:273]Sys::Syslog::__ANON__[:273]
0000s0sSys::Syslog::::__ANON__[:656]Sys::Syslog::__ANON__[:656]
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;
2272µs276µs
# spent 59µs (42+17) within Sys::Syslog::BEGIN@2 which was called: # once (42µs+17µs) by Razor2::Logger::BEGIN@12 at line 2
use strict;
# spent 59µs making 1 call to Sys::Syslog::BEGIN@2 # spent 17µs making 1 call to strict::import
3265µs296µs
# spent 60µs (24+36) within Sys::Syslog::BEGIN@3 which was called: # once (24µs+36µs) by Razor2::Logger::BEGIN@12 at line 3
use warnings;
# spent 60µs making 1 call to Sys::Syslog::BEGIN@3 # spent 36µs making 1 call to warnings::import
4270µs21.40ms
# spent 714µs (29+685) within Sys::Syslog::BEGIN@4 which was called: # once (29µs+685µs) by Razor2::Logger::BEGIN@12 at line 4
use warnings::register;
# spent 714µs making 1 call to Sys::Syslog::BEGIN@4 # spent 685µs making 1 call to warnings::register::import
5276µs2470µs
# spent 249µs (27+222) within Sys::Syslog::BEGIN@5 which was called: # once (27µs+222µs) by Razor2::Logger::BEGIN@12 at line 5
use Carp;
# spent 249µs making 1 call to Sys::Syslog::BEGIN@5 # spent 222µs making 1 call to Exporter::import
6268µs285µs
# spent 52µs (20+33) within Sys::Syslog::BEGIN@6 which was called: # once (20µs+33µs) by Razor2::Logger::BEGIN@12 at line 6
use Exporter qw< import >;
# spent 52µs making 1 call to Sys::Syslog::BEGIN@6 # spent 33µs making 1 call to Exporter::import
7289µs2564µs
# spent 296µs (29+268) within Sys::Syslog::BEGIN@7 which was called: # once (29µs+268µs) by Razor2::Logger::BEGIN@12 at line 7
use File::Basename;
# spent 296µs making 1 call to Sys::Syslog::BEGIN@7 # spent 268µs making 1 call to Exporter::import
8277µs2504µs
# spent 263µs (22+241) within Sys::Syslog::BEGIN@8 which was called: # once (22µs+241µs) by Razor2::Logger::BEGIN@12 at line 8
use POSIX qw< strftime setlocale LC_TIME >;
# spent 263µs making 1 call to Sys::Syslog::BEGIN@8 # spent 241µs making 1 call to POSIX::import
92111µs224.1ms
# spent 12.1ms (24µs+12.0) within Sys::Syslog::BEGIN@9 which was called: # once (24µs+12.0ms) by Razor2::Logger::BEGIN@12 at line 9
use Socket qw< :all >;
# spent 12.1ms making 1 call to Sys::Syslog::BEGIN@9 # spent 12.0ms making 1 call to Exporter::import
10132µsrequire 5.005;
11
12
133424µs2136µs
# spent 82µs (28+54) within Sys::Syslog::BEGIN@13 which was called: # once (28µs+54µs) by Razor2::Logger::BEGIN@12 at line 13
{ no strict 'vars';
# spent 82µs making 1 call to Sys::Syslog::BEGIN@13 # spent 54µs making 1 call to strict::unimport
1413µs $VERSION = '0.33_01';
15
16114µs %EXPORT_TAGS = (
17 standard => [qw(openlog syslog closelog setlogmask)],
18 extended => [qw(setlogsock)],
19 macros => [
20 # levels
21 qw(
22 LOG_ALERT LOG_CRIT LOG_DEBUG LOG_EMERG LOG_ERR
23 LOG_INFO LOG_NOTICE LOG_WARNING
24 ),
25
26 # standard facilities
27 qw(
28 LOG_AUTH LOG_AUTHPRIV LOG_CRON LOG_DAEMON LOG_FTP LOG_KERN
29 LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4
30 LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NEWS
31 LOG_SYSLOG LOG_USER LOG_UUCP
32 ),
33 # Mac OS X specific facilities
34 qw( LOG_INSTALL LOG_LAUNCHD LOG_NETINFO LOG_RAS LOG_REMOTEAUTH ),
35 # modern BSD specific facilities
36 qw( LOG_CONSOLE LOG_NTP LOG_SECURITY ),
37 # IRIX specific facilities
38 qw( LOG_AUDIT LOG_LFMT ),
39
40 # options
41 qw(
42 LOG_CONS LOG_PID LOG_NDELAY LOG_NOWAIT LOG_ODELAY LOG_PERROR
43 ),
44
45 # others macros
46 qw(
47 LOG_FACMASK LOG_NFACILITIES LOG_PRIMASK
48 LOG_MASK LOG_UPTO
49 ),
50 ],
51 );
52
53 @EXPORT = (
5428µs @{$EXPORT_TAGS{standard}},
55 );
56
57 @EXPORT_OK = (
5812µs @{$EXPORT_TAGS{extended}},
59214µs @{$EXPORT_TAGS{macros}},
60 );
61
62 eval {
6312µs require XSLoader;
641485µs1465µs XSLoader::load('Sys::Syslog', $VERSION);
# spent 465µs making 1 call to XSLoader::load
6513µs 1
6614µs } or do {
67 require DynaLoader;
68 push @ISA, 'DynaLoader';
69 bootstrap Sys::Syslog $VERSION;
70 };
71}
72
73
74#
75# Public variables
76#
772107µs2147µs
# spent 85µs (24+61) within Sys::Syslog::BEGIN@77 which was called: # once (24µs+61µs) by Razor2::Logger::BEGIN@12 at line 77
use vars qw($host); # host to send syslog messages to (see notes at end)
# spent 85µs making 1 call to Sys::Syslog::BEGIN@77 # spent 61µs making 1 call to vars::import
78
79#
80# Prototypes
81#
82sub silent_eval (&);
83
84#
85# Global variables
86#
872614µs2151µs
# spent 89µs (28+62) within Sys::Syslog::BEGIN@87 which was called: # once (28µs+62µs) by Razor2::Logger::BEGIN@12 at line 87
use vars qw($facility);
# spent 89µs making 1 call to Sys::Syslog::BEGIN@87 # spent 62µs making 1 call to vars::import
8812µsmy $connected = 0; # flag to indicate if we're connected or not
8911µsmy $syslog_send; # coderef of the function used to send messages
9012µsmy $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms
9112µsmy $syslog_xobj = undef; # if defined, holds the external object used to send messages
9212µsmy $transmit_ok = 0; # flag to indicate if the last message was transmitted
9312µsmy $sock_port = undef; # socket port
9411µsmy $sock_timeout = 0; # socket timeout, see below
9511µsmy $current_proto = undef; # current mechanism used to transmit messages
9612µsmy $ident = ''; # identifiant prepended to each message
9712µs$facility = ''; # current facility
98132µs29µsmy $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask
# spent 6µs making 1 call to Sys::Syslog::LOG_UPTO # spent 4µs making 1 call to Sys::Syslog::LOG_DEBUG
99
10016µsmy %options = (
101 ndelay => 0,
102 noeol => 0,
103 nofatal => 0,
104 nonul => 0,
105 nowait => 0,
106 perror => 0,
107 pid => 0,
108);
109
110# Default is now to first use the native mechanism, so Perl programs
111# behave like other normal Unix programs, then try other mechanisms.
11214µsmy @connectMethods = qw(native tcp udp unix pipe stream console);
11317µsif ($^O eq "freebsd" or $^O eq "linux") {
114834µs @connectMethods = grep { $_ ne 'udp' } @connectMethods;
115}
116
117# And on Win32 systems, we try to use the native mechanism for this
118# platform, the events logger, available through Win32::EventLog.
119EVENTLOG: {
120229µs15µs my $is_Win32 = $^O =~ /Win32/i;
# spent 5µs making 1 call to Sys::Syslog::CORE:match
121
12217µs1248µs if (can_load("Sys::Syslog::Win32", $is_Win32)) {
# spent 248µs making 1 call to Sys::Syslog::can_load
123 unshift @connectMethods, 'eventlog';
124 }
125}
126
12714µsmy @defaultMethods = @connectMethods;
12812µsmy @fallbackMethods = ();
129
130# The timeout in connection_ok() was pushed up to 0.25 sec in
131# Sys::Syslog v0.19 in order to address a heisenbug on MacOSX:
132# http://london.pm.org/pipermail/london.pm/Week-of-Mon-20061211/005961.html
133#
134# However, this also had the effect of slowing this test for
135# all other operating systems, which apparently impacted some
136# users (cf. CPAN-RT #34753). So, in order to make everybody
137# happy, the timeout is now zero by default on all systems
138# except on OSX where it is set to 250 msec, and can be set
139# with the infamous setlogsock() function.
140#
141# Update 2011-08: this issue is also been seen on multiprocessor
142# Debian GNU/kFreeBSD systems. See http://bugs.debian.org/627821
143# and https://rt.cpan.org/Ticket/Display.html?id=69997
144# Also, lowering the delay to 1 ms, which should be enough.
145
146113µs16µs$sock_timeout = 0.001 if $^O =~ /darwin|gnukfreebsd/;
# spent 6µs making 1 call to Sys::Syslog::CORE:match
147
148
149# Perl 5.6.0's warnings.pm doesn't have warnings::warnif()
15012µsif (not defined &warnings::warnif) {
151 *warnings::warnif = sub {
152 goto &warnings::warn if warnings::enabled(__PACKAGE__)
153 }
154}
155
156# coderef for a nicer handling of errors
15713µsmy $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
158
159
160sub AUTOLOAD {
161 # This AUTOLOAD is used to 'autoload' constants from the constant()
162 # XS function.
1632168µs2126µs
# spent 78µs (31+47) within Sys::Syslog::BEGIN@163 which was called: # once (31µs+47µs) by Razor2::Logger::BEGIN@12 at line 163
no strict 'vars';
# spent 78µs making 1 call to Sys::Syslog::BEGIN@163 # spent 47µs making 1 call to strict::unimport
164 my $constname;
165 ($constname = $AUTOLOAD) =~ s/.*:://;
166 croak "Sys::Syslog::constant() not defined" if $constname eq 'constant';
167 my ($error, $val) = constant($constname);
168 croak $error if $error;
16924.74ms2124µs
# spent 73µs (22+51) within Sys::Syslog::BEGIN@169 which was called: # once (22µs+51µs) by Razor2::Logger::BEGIN@12 at line 169
no strict 'refs';
# spent 73µs making 1 call to Sys::Syslog::BEGIN@169 # spent 51µs making 1 call to strict::unimport
170 *$AUTOLOAD = sub { $val };
171 goto &$AUTOLOAD;
172}
173
174
175sub openlog {
176 ($ident, my $logopt, $facility) = @_;
177
178 # default values
179 $ident ||= basename($0) || getlogin() || getpwuid($<) || 'syslog';
180 $logopt ||= '';
181 $facility ||= LOG_USER();
182
183 for my $opt (split /\b/, $logopt) {
184 $options{$opt} = 1 if exists $options{$opt}
185 }
186
187 $err_sub = delete $options{nofatal} ? \&warnings::warnif : \&croak;
188 return 1 unless $options{ndelay};
189 connect_log();
190}
191
192sub closelog {
193 disconnect_log() if $connected;
194 $options{$_} = 0 for keys %options;
195 $facility = $ident = "";
196 $connected = 0;
197 return 1
198}
199
200sub setlogmask {
201 my $oldmask = $maskpri;
202 $maskpri = shift unless $_[0] == 0;
203 $oldmask;
204}
205
206
207my %mechanism = (
208 console => {
209 check => sub { 1 },
210 },
211 eventlog => {
212 check => sub { return can_load("Win32::EventLog") },
213 err_msg => "no Win32 API available",
214 },
215 inet => {
216 check => sub { 1 },
217 },
218 native => {
219 check => sub { 1 },
220 },
221 pipe => {
222 check => sub {
223 ($syslog_path) = grep { defined && length && -p && -w _ }
224 $syslog_path, &_PATH_LOG, "/dev/log";
225 return $syslog_path ? 1 : 0
226 },
227 err_msg => "path not available",
228 },
229 stream => {
230 check => sub {
231 if (not defined $syslog_path) {
232 my @try = qw(/dev/log /dev/conslog);
233 unshift @try, &_PATH_LOG if length &_PATH_LOG;
234 ($syslog_path) = grep { -w } @try;
235 }
236 return defined $syslog_path && -w $syslog_path
237 },
238 err_msg => "could not find any writable device",
239 },
240 tcp => {
241 check => sub {
242 return 1 if defined $sock_port;
243
244 if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
245 $host = $syslog_path;
246 return 1
247 }
248 else {
249 return
250 }
251 },
252 err_msg => "TCP service unavailable",
253 },
254 udp => {
255 check => sub {
256 return 1 if defined $sock_port;
257
258 if (getservbyname('syslog', 'udp')) {
259 $host = $syslog_path;
260 return 1
261 }
262 else {
263 return
264 }
265 },
266 err_msg => "UDP service unavailable",
267 },
268 unix => {
269 check => sub {
270 my @try = ($syslog_path, &_PATH_LOG);
271 ($syslog_path) = grep { defined && length && -w } @try;
272 return defined $syslog_path && -w $syslog_path
273 },
274152µs err_msg => "path not available",
275 },
276);
277
278sub setlogsock {
279 my %opt;
280
281 # handle arguments
282 # - old API: setlogsock($sock_type, $sock_path, $sock_timeout)
283 # - new API: setlogsock(\%options)
284 croak "setlogsock(): Invalid number of arguments"
285 unless @_ >= 1 and @_ <= 3;
286
287 if (my $ref = ref $_[0]) {
288 if ($ref eq "HASH") {
289 %opt = %{ $_[0] };
290 croak "setlogsock(): No argument given" unless keys %opt;
291 }
292 elsif ($ref eq "ARRAY") {
293 @opt{qw< type path timeout >} = @_;
294 }
295 else {
296 croak "setlogsock(): Unexpected \L$ref\E reference"
297 }
298 }
299 else {
300 @opt{qw< type path timeout >} = @_;
301 }
302
303 # check socket type, remove invalid ones
304 my $diag_invalid_type = "setlogsock(): Invalid type%s; must be one of "
305 . join ", ", map { "'$_'" } sort keys %mechanism;
306 croak sprintf $diag_invalid_type, "" unless defined $opt{type};
307 my @sock_types = ref $opt{type} eq "ARRAY" ? @{$opt{type}} : ($opt{type});
308 my @tmp;
309
310 for my $sock_type (@sock_types) {
311 carp sprintf $diag_invalid_type, " '$sock_type'" and next
312 unless exists $mechanism{$sock_type};
313 push @tmp, "tcp", "udp" and next if $sock_type eq "inet";
314 push @tmp, $sock_type;
315 }
316
317 @sock_types = @tmp;
318
319 # set global options
320 $syslog_path = $opt{path} if defined $opt{path};
321 $host = $opt{host} if defined $opt{host};
322 $sock_timeout = $opt{timeout} if defined $opt{timeout};
323 $sock_port = $opt{port} if defined $opt{port};
324
325 disconnect_log() if $connected;
326 $transmit_ok = 0;
327 @fallbackMethods = ();
328 @connectMethods = ();
329 my $found = 0;
330
331 # check each given mechanism and test if it can be used on the current system
332 for my $sock_type (@sock_types) {
333 if ( $mechanism{$sock_type}{check}->() ) {
334 push @connectMethods, $sock_type;
335 $found = 1;
336 }
337 else {
338 warnings::warnif("setlogsock(): type='$sock_type': "
339 . $mechanism{$sock_type}{err_msg});
340 }
341 }
342
343 # if no mechanism worked from the given ones, use the default ones
344 @connectMethods = @defaultMethods unless @connectMethods;
345
346 return $found;
347}
348
349sub syslog {
350 my ($priority, $mask, @args) = @_;
351 my ($message, $buf);
352 my (@words, $num, $numpri, $numfac, $sum);
353 my $failed = undef;
354 my $fail_time = undef;
355 my $error = $!;
356
357 # if $ident is undefined, it means openlog() wasn't previously called
358 # so do it now in order to have sensible defaults
359 openlog() unless $ident;
360
361 local $facility = $facility; # may need to change temporarily.
362
363 croak "syslog: expecting argument \$priority" unless defined $priority;
364 croak "syslog: expecting argument \$format" unless defined $mask;
365
366 if ($priority =~ /^\d+$/) {
367 $numpri = LOG_PRI($priority);
368 $numfac = LOG_FAC($priority) << 3;
369 }
370 elsif ($priority =~ /^\w+/) {
371 # Allow "level" or "level|facility".
372 @words = split /\W+/, $priority, 2;
373
374 undef $numpri;
375 undef $numfac;
376
377 for my $word (@words) {
378 next if length $word == 0;
379
380 # Translate word to number.
381 $num = xlate($word);
382
383 if ($num < 0) {
384 croak "syslog: invalid level/facility: $word"
385 }
386 elsif ($num <= LOG_PRIMASK() and $word ne "kern") {
387 croak "syslog: too many levels given: $word"
388 if defined $numpri;
389 $numpri = $num;
390 }
391 else {
392 croak "syslog: too many facilities given: $word"
393 if defined $numfac;
394 $facility = $word if $word =~ /^[A-Za-z]/;
395 $numfac = $num;
396 }
397 }
398 }
399 else {
400 croak "syslog: invalid level/facility: $priority"
401 }
402
403 croak "syslog: level must be given" unless defined $numpri;
404
405 # don't log if priority is below mask level
406 return 0 unless LOG_MASK($numpri) & $maskpri;
407
408 if (not defined $numfac) { # Facility not specified in this call.
409 $facility = 'user' unless $facility;
410 $numfac = xlate($facility);
411 }
412
413 connect_log() unless $connected;
414
415 if ($mask =~ /%m/) {
416 # escape percent signs for sprintf()
417 $error =~ s/%/%%/g if @args;
418 # replace %m with $error, if preceded by an even number of percent signs
419 $mask =~ s/(?<!%)((?:%%)*)%m/$1$error/g;
420 }
421
422 $mask .= "\n" unless $mask =~ /\n$/;
423 $message = @args ? sprintf($mask, @args) : $mask;
424
425 if ($current_proto eq 'native') {
426 $buf = $message;
427 }
428 elsif ($current_proto eq 'eventlog') {
429 $buf = $message;
430 }
431 else {
432 my $whoami = $ident;
433 $whoami .= "[$$]" if $options{pid};
434
435 $sum = $numpri + $numfac;
436 my $oldlocale = setlocale(LC_TIME);
437 setlocale(LC_TIME, 'C');
438 my $timestamp = strftime "%b %d %H:%M:%S", localtime;
439 setlocale(LC_TIME, $oldlocale);
440
441 # construct the stream that will be transmitted
442 $buf = "<$sum>$timestamp $whoami: $message";
443
444 # add (or not) a newline
445 $buf .= "\n" if !$options{noeol} and rindex($buf, "\n") == -1;
446
447 # add (or not) a NUL character
448 $buf .= "\0" if !$options{nonul};
449 }
450
451 # handle PERROR option
452 # "native" mechanism already handles it by itself
453 if ($options{perror} and $current_proto ne 'native') {
454 my $whoami = $ident;
455 $whoami .= "[$$]" if $options{pid};
456 print STDERR "$whoami: $message\n";
457 }
458
459 # it's possible that we'll get an error from sending
460 # (e.g. if method is UDP and there is no UDP listener,
461 # then we'll get ECONNREFUSED on the send). So what we
462 # want to do at this point is to fallback onto a different
463 # connection method.
464 while (scalar @fallbackMethods || $syslog_send) {
465 if ($failed && (time - $fail_time) > 60) {
466 # it's been a while... maybe things have been fixed
467 @fallbackMethods = ();
468 disconnect_log();
469 $transmit_ok = 0; # make it look like a fresh attempt
470 connect_log();
471 }
472
473 if ($connected && !connection_ok()) {
474 # Something was OK, but has now broken. Remember coz we'll
475 # want to go back to what used to be OK.
476 $failed = $current_proto unless $failed;
477 $fail_time = time;
478 disconnect_log();
479 }
480
481 connect_log() unless $connected;
482 $failed = undef if ($current_proto && $failed && $current_proto eq $failed);
483
484 if ($syslog_send) {
485 if ($syslog_send->($buf, $numpri, $numfac)) {
486 $transmit_ok++;
487 return 1;
488 }
489 # typically doesn't happen, since errors are rare from write().
490 disconnect_log();
491 }
492 }
493 # could not send, could not fallback onto a working
494 # connection method. Lose.
495 return 0;
496}
497
498sub _syslog_send_console {
499 my ($buf) = @_;
500
501 # The console print is a method which could block
502 # so we do it in a child process and always return success
503 # to the caller.
504 if (my $pid = fork) {
505
506 if ($options{nowait}) {
507 return 1;
508 } else {
509 if (waitpid($pid, 0) >= 0) {
510 return ($? >> 8);
511 } else {
512 # it's possible that the caller has other
513 # plans for SIGCHLD, so let's not interfere
514 return 1;
515 }
516 }
517 } else {
518 if (open(CONS, ">/dev/console")) {
519 my $ret = print CONS $buf . "\r"; # XXX: should this be \x0A ?
520 POSIX::_exit($ret) if defined $pid;
521 close CONS;
522 }
523
524 POSIX::_exit(0) if defined $pid;
525 }
526}
527
528sub _syslog_send_stream {
529 my ($buf) = @_;
530 # XXX: this only works if the OS stream implementation makes a write
531 # look like a putmsg() with simple header. For instance it works on
532 # Solaris 8 but not Solaris 7.
533 # To be correct, it should use a STREAMS API, but perl doesn't have one.
534 return syswrite(SYSLOG, $buf, length($buf));
535}
536
537sub _syslog_send_pipe {
538 my ($buf) = @_;
539 return print SYSLOG $buf;
540}
541
542sub _syslog_send_socket {
543 my ($buf) = @_;
544 return syswrite(SYSLOG, $buf, length($buf));
545 #return send(SYSLOG, $buf, 0);
546}
547
548sub _syslog_send_native {
549 my ($buf, $numpri, $numfac) = @_;
550 syslog_xs($numpri|$numfac, $buf);
551 return 1;
552}
553
554
555# xlate()
556# -----
557# private function to translate names to numeric values
558#
559sub xlate {
560 my ($name) = @_;
561
562 return $name+0 if $name =~ /^\s*\d+\s*$/;
563 $name = uc $name;
564 $name = "LOG_$name" unless $name =~ /^LOG_/;
565
566 # ExtUtils::Constant 0.20 introduced a new way to implement
567 # constants, called ProxySubs. When it was used to generate
568 # the C code, the constant() function no longer returns the
569 # correct value. Therefore, we first try a direct call to
570 # constant(), and if the value is an error we try to call the
571 # constant by its full name.
572 my $value = constant($name);
573
574 if (index($value, "not a valid") >= 0) {
575 $name = "Sys::Syslog::$name";
5762294µs2163µs
# spent 97µs (32+65) within Sys::Syslog::BEGIN@576 which was called: # once (32µs+65µs) by Razor2::Logger::BEGIN@12 at line 576
$value = eval { no strict "refs"; &$name };
# spent 97µs making 1 call to Sys::Syslog::BEGIN@576 # spent 65µs making 1 call to strict::unimport
577 $value = $@ unless defined $value;
578 }
579
580 $value = -1 if index($value, "not a valid") >= 0;
581
582 return defined $value ? $value : -1;
583}
584
585
586# connect_log()
587# -----------
588# This function acts as a kind of front-end: it tries to connect to
589# a syslog service using the selected methods, trying each one in the
590# selected order.
591#
592sub connect_log {
593 @fallbackMethods = @connectMethods unless scalar @fallbackMethods;
594
595 if ($transmit_ok && $current_proto) {
596 # Retry what we were on, because it has worked in the past.
597 unshift(@fallbackMethods, $current_proto);
598 }
599
600 $connected = 0;
601 my @errs = ();
602 my $proto = undef;
603
604 while ($proto = shift @fallbackMethods) {
60522.96ms2130µs
# spent 81µs (32+49) within Sys::Syslog::BEGIN@605 which was called: # once (32µs+49µs) by Razor2::Logger::BEGIN@12 at line 605
no strict 'refs';
# spent 81µs making 1 call to Sys::Syslog::BEGIN@605 # spent 49µs making 1 call to strict::unimport
606 my $fn = "connect_$proto";
607 $connected = &$fn(\@errs) if defined &$fn;
608 last if $connected;
609 }
610
611 $transmit_ok = 0;
612 if ($connected) {
613 $current_proto = $proto;
614 my ($old) = select(SYSLOG); $| = 1; select($old);
615 } else {
616 @fallbackMethods = ();
617 $err_sub->(join "\n\t- ", "no connection to syslog available", @errs);
618 return undef;
619 }
620}
621
622sub connect_tcp {
623 my ($errs) = @_;
624
625 my $proto = getprotobyname('tcp');
626 if (!defined $proto) {
627 push @$errs, "getprotobyname failed for tcp";
628 return 0;
629 }
630
631 my $port = $sock_port || getservbyname('syslog', 'tcp');
632 $port = getservbyname('syslogng', 'tcp') unless defined $port;
633 if (!defined $port) {
634 push @$errs, "getservbyname failed for syslog/tcp and syslogng/tcp";
635 return 0;
636 }
637
638 my $addr;
639 if (defined $host) {
640 $addr = inet_aton($host);
641 if (!$addr) {
642 push @$errs, "can't lookup $host";
643 return 0;
644 }
645 } else {
646 $addr = INADDR_LOOPBACK;
647 }
648 $addr = sockaddr_in($port, $addr);
649
650 if (!socket(SYSLOG, AF_INET, SOCK_STREAM, $proto)) {
651 push @$errs, "tcp socket: $!";
652 return 0;
653 }
654
655 setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
656 if (silent_eval { IPPROTO_TCP() }) {
657 # These constants don't exist in 5.005. They were added in 1999
658 setsockopt(SYSLOG, IPPROTO_TCP(), TCP_NODELAY(), 1);
659 }
660 if (!connect(SYSLOG, $addr)) {
661 push @$errs, "tcp connect: $!";
662 return 0;
663 }
664
665 $syslog_send = \&_syslog_send_socket;
666
667 return 1;
668}
669
670sub connect_udp {
671 my ($errs) = @_;
672
673 my $proto = getprotobyname('udp');
674 if (!defined $proto) {
675 push @$errs, "getprotobyname failed for udp";
676 return 0;
677 }
678
679 my $port = $sock_port || getservbyname('syslog', 'udp');
680 if (!defined $port) {
681 push @$errs, "getservbyname failed for syslog/udp";
682 return 0;
683 }
684
685 my $addr;
686 if (defined $host) {
687 $addr = inet_aton($host);
688 if (!$addr) {
689 push @$errs, "can't lookup $host";
690 return 0;
691 }
692 } else {
693 $addr = INADDR_LOOPBACK;
694 }
695 $addr = sockaddr_in($port, $addr);
696
697 if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, $proto)) {
698 push @$errs, "udp socket: $!";
699 return 0;
700 }
701 if (!connect(SYSLOG, $addr)) {
702 push @$errs, "udp connect: $!";
703 return 0;
704 }
705
706 # We want to check that the UDP connect worked. However the only
707 # way to do that is to send a message and see if an ICMP is returned
708 _syslog_send_socket("");
709 if (!connection_ok()) {
710 push @$errs, "udp connect: nobody listening";
711 return 0;
712 }
713
714 $syslog_send = \&_syslog_send_socket;
715
716 return 1;
717}
718
719sub connect_stream {
720 my ($errs) = @_;
721 # might want syslog_path to be variable based on syslog.h (if only
722 # it were in there!)
723 $syslog_path = '/dev/conslog' unless defined $syslog_path;
724
725 if (!-w $syslog_path) {
726 push @$errs, "stream $syslog_path is not writable";
727 return 0;
728 }
729
730 require Fcntl;
731
732 if (!sysopen(SYSLOG, $syslog_path, Fcntl::O_WRONLY(), 0400)) {
733 push @$errs, "stream can't open $syslog_path: $!";
734 return 0;
735 }
736
737 $syslog_send = \&_syslog_send_stream;
738
739 return 1;
740}
741
742sub connect_pipe {
743 my ($errs) = @_;
744
745 $syslog_path ||= &_PATH_LOG || "/dev/log";
746
747 if (not -w $syslog_path) {
748 push @$errs, "$syslog_path is not writable";
749 return 0;
750 }
751
752 if (not open(SYSLOG, ">$syslog_path")) {
753 push @$errs, "can't write to $syslog_path: $!";
754 return 0;
755 }
756
757 $syslog_send = \&_syslog_send_pipe;
758
759 return 1;
760}
761
762sub connect_unix {
763 my ($errs) = @_;
764
765 $syslog_path ||= _PATH_LOG() if length _PATH_LOG();
766
767 if (not defined $syslog_path) {
768 push @$errs, "_PATH_LOG not available in syslog.h and no user-supplied socket path";
769 return 0;
770 }
771
772 if (not (-S $syslog_path or -c _)) {
773 push @$errs, "$syslog_path is not a socket";
774 return 0;
775 }
776
777 my $addr = sockaddr_un($syslog_path);
778 if (!$addr) {
779 push @$errs, "can't locate $syslog_path";
780 return 0;
781 }
782 if (!socket(SYSLOG, AF_UNIX, SOCK_STREAM, 0)) {
783 push @$errs, "unix stream socket: $!";
784 return 0;
785 }
786
787 if (!connect(SYSLOG, $addr)) {
788 if (!socket(SYSLOG, AF_UNIX, SOCK_DGRAM, 0)) {
789 push @$errs, "unix dgram socket: $!";
790 return 0;
791 }
792 if (!connect(SYSLOG, $addr)) {
793 push @$errs, "unix dgram connect: $!";
794 return 0;
795 }
796 }
797
798 $syslog_send = \&_syslog_send_socket;
799
800 return 1;
801}
802
803sub connect_native {
804 my ($errs) = @_;
805 my $logopt = 0;
806
807 # reconstruct the numeric equivalent of the options
808 for my $opt (keys %options) {
809 $logopt += xlate($opt) if $options{$opt}
810 }
811
812 openlog_xs($ident, $logopt, xlate($facility));
813 $syslog_send = \&_syslog_send_native;
814
815 return 1;
816}
817
818sub connect_eventlog {
819 my ($errs) = @_;
820
821 $syslog_xobj = Sys::Syslog::Win32::_install();
822 $syslog_send = \&Sys::Syslog::Win32::_syslog_send;
823
824 return 1;
825}
826
827sub connect_console {
828 my ($errs) = @_;
829 if (!-w '/dev/console') {
830 push @$errs, "console is not writable";
831 return 0;
832 }
833 $syslog_send = \&_syslog_send_console;
834 return 1;
835}
836
837# To test if the connection is still good, we need to check if any
838# errors are present on the connection. The errors will not be raised
839# by a write. Instead, sockets are made readable and the next read
840# would cause the error to be returned. Unfortunately the syslog
841# 'protocol' never provides anything for us to read. But with
842# judicious use of select(), we can see if it would be readable...
843sub connection_ok {
844 return 1 if defined $current_proto and (
845 $current_proto eq 'native' or $current_proto eq 'console'
846 or $current_proto eq 'eventlog'
847 );
848
849 my $rin = '';
850 vec($rin, fileno(SYSLOG), 1) = 1;
851 my $ret = select $rin, undef, $rin, $sock_timeout;
852 return ($ret ? 0 : 1);
853}
854
855sub disconnect_log {
856 $connected = 0;
857 $syslog_send = undef;
858
859 if (defined $current_proto and $current_proto eq 'native') {
860 closelog_xs();
861 unshift @fallbackMethods, $current_proto;
862 $current_proto = undef;
863 return 1;
864 }
865 elsif (defined $current_proto and $current_proto eq 'eventlog') {
866 $syslog_xobj->Close();
867 unshift @fallbackMethods, $current_proto;
868 $current_proto = undef;
869 return 1;
870 }
871
872 return close SYSLOG;
873}
874
875
876#
877# Wrappers around eval() that makes sure that nobody, and I say NOBODY,
878# ever knows that I wanted to test if something was here or not.
879# It is needed because some applications are trying to be too smart,
880# do it wrong, and it ends up in EPIC FAIL.
881# Yes I'm speaking of YOU, SpamAssassin.
882#
883sub silent_eval (&) {
884 local($SIG{__DIE__}, $SIG{__WARN__}, $@);
885 return eval { $_[0]->() }
886}
887
888
# spent 248µs (127+121) within Sys::Syslog::can_load which was called: # once (127µs+121µs) by Razor2::Logger::BEGIN@12 at line 122
sub can_load {
88913µs my ($module, $verbose) = @_;
89019µs local($SIG{__DIE__}, $SIG{__WARN__}, $@);
89116µs local @INC = @INC;
89212µs pop @INC if $INC[-1] eq '.';
893180µs my $loaded = eval "use $module; 1";
# spent 136µs executing statements in string eval
# includes 121µs spent executing 1 call to 1 sub defined therein.
89412µs warn $@ if not $loaded and $verbose;
895113µs return $loaded
896}
897
898
899178µs"Eighth Rule: read the documentation."
900
901__END__
 
# spent 11µs within Sys::Syslog::CORE:match which was called 2 times, avg 6µs/call: # once (6µs+0s) by Razor2::Logger::BEGIN@12 at line 146 # once (5µs+0s) by Razor2::Logger::BEGIN@12 at line 120
sub Sys::Syslog::CORE:match; # opcode
# spent 4µs within Sys::Syslog::LOG_DEBUG which was called: # once (4µs+0s) by Razor2::Logger::BEGIN@12 at line 98
sub Sys::Syslog::LOG_DEBUG; # xsub
# spent 6µs within Sys::Syslog::LOG_UPTO which was called: # once (6µs+0s) by Razor2::Logger::BEGIN@12 at line 98
sub Sys::Syslog::LOG_UPTO; # xsub
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.