Filename | /usr/local/lib/perl5/5.32/mach/Sys/Syslog.pm |
Statements | Executed 2941188 statements in 4.96s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
35436 | 1 | 1 | 1.85s | 4.90s | syslog | Sys::Syslog::
70872 | 2 | 1 | 873ms | 1.09s | xlate | Sys::Syslog::
35436 | 1 | 1 | 207ms | 257ms | connection_ok | Sys::Syslog::
35436 | 1 | 1 | 140ms | 251ms | _syslog_send_socket | Sys::Syslog::
35436 | 1 | 1 | 110ms | 110ms | CORE:syswrite (opcode) | Sys::Syslog::
248052 | 4 | 1 | 100ms | 100ms | CORE:match (opcode) | Sys::Syslog::
70872 | 1 | 1 | 74.1ms | 74.1ms | constant (xsub) | Sys::Syslog::
35433 | 1 | 1 | 53.1ms | 53.1ms | LOG_DEBUG (xsub) | Sys::Syslog::
35436 | 1 | 1 | 50.4ms | 50.4ms | CORE:sselect (opcode) | Sys::Syslog::
35436 | 1 | 1 | 40.4ms | 40.4ms | LOG_LOCAL1 (xsub) | Sys::Syslog::
35436 | 1 | 1 | 15.1ms | 15.1ms | LOG_MASK (xsub) | Sys::Syslog::
35436 | 1 | 1 | 13.8ms | 13.8ms | LOG_PRIMASK (xsub) | Sys::Syslog::
3 | 1 | 1 | 55µs | 55µs | LOG_NOTICE (xsub) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | AUTOLOAD | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@10 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@104 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@114 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@17 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@190 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@196 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@2 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@3 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@4 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@5 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@6 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@618 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@647 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@7 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@8 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@81 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@82 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@83 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@84 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@85 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@86 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@88 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@9 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@93 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | BEGIN@98 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | CORE:connect (opcode) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | CORE:ftewrite (opcode) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | CORE:ftsock (opcode) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | CORE:select (opcode) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | CORE:socket (opcode) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | CORE:sort (opcode) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | CORE:subst (opcode) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | LOG_INFO (xsub) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | LOG_UPTO (xsub) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | _PATH_LOG (xsub) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:180] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:197] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:236] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:239] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:243] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:246] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:253] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:264] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:280] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:294] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:302] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | _syslog_send_console | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | _syslog_send_native | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | _syslog_send_pipe | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | _syslog_send_stream | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | can_load_sys_syslog_win32 | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | closelog | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_console | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_eventlog | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_log | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_native | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_pipe | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_stream | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_tcp | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_udp | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | connect_unix | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | disconnect_log | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | openlog | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | setlogmask | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | setlogsock | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | silent_eval | Sys::Syslog::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Sys::Syslog; | ||||
2 | use strict; | ||||
3 | use warnings; | ||||
4 | use warnings::register; | ||||
5 | use Carp; | ||||
6 | use Config; | ||||
7 | use Exporter (); | ||||
8 | use File::Basename; | ||||
9 | use POSIX qw< strftime setlocale LC_TIME >; | ||||
10 | use Socket qw< :all >; | ||||
11 | require 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 | # | ||||
81 | use constant HAVE_GETPROTOBYNAME => $Config::Config{d_getpbyname}; | ||||
82 | use constant HAVE_GETPROTOBYNUMBER => $Config::Config{d_getpbynumber}; | ||||
83 | use constant HAVE_SETLOCALE => $Config::Config{d_setlocale}; | ||||
84 | use constant HAVE_IPPROTO_TCP => defined &Socket::IPPROTO_TCP ? 1 : 0; | ||||
85 | use constant HAVE_IPPROTO_UDP => defined &Socket::IPPROTO_UDP ? 1 : 0; | ||||
86 | use constant HAVE_TCP_NODELAY => defined &Socket::TCP_NODELAY ? 1 : 0; | ||||
87 | |||||
88 | use constant SOCKET_IPPROTO_TCP => | ||||
89 | HAVE_IPPROTO_TCP ? Socket::IPPROTO_TCP | ||||
90 | : HAVE_GETPROTOBYNAME ? scalar getprotobyname("tcp") | ||||
91 | : 6; | ||||
92 | |||||
93 | use constant SOCKET_IPPROTO_UDP => | ||||
94 | HAVE_IPPROTO_UDP ? Socket::IPPROTO_UDP | ||||
95 | : HAVE_GETPROTOBYNAME ? scalar getprotobyname("udp") | ||||
96 | : 17; | ||||
97 | |||||
98 | use constant SOCKET_TCP_NODELAY => HAVE_TCP_NODELAY ? Socket::TCP_NODELAY : 1; | ||||
99 | |||||
100 | |||||
101 | # | ||||
102 | # Public variables | ||||
103 | # | ||||
104 | use vars qw($host); # host to send syslog messages to (see notes at end) | ||||
105 | |||||
106 | # | ||||
107 | # Prototypes | ||||
108 | # | ||||
109 | sub silent_eval (&); | ||||
110 | |||||
111 | # | ||||
112 | # Global variables | ||||
113 | # | ||||
114 | use vars qw($facility); | ||||
115 | my $connected = 0; # flag to indicate if we're connected or not | ||||
116 | my $syslog_send; # coderef of the function used to send messages | ||||
117 | my $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms | ||||
118 | my $syslog_xobj = undef; # if defined, holds the external object used to send messages | ||||
119 | my $transmit_ok = 0; # flag to indicate if the last message was transmitted | ||||
120 | my $sock_port = undef; # socket port | ||||
121 | my $sock_timeout = 0; # socket timeout, see below | ||||
122 | my $current_proto = undef; # current mechanism used to transmit messages | ||||
123 | my $ident = ''; # identifiant prepended to each message | ||||
124 | $facility = ''; # current facility | ||||
125 | my $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask | ||||
126 | |||||
127 | my %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. | ||||
139 | my @connectMethods = qw(native tcp udp unix pipe stream console); | ||||
140 | if ($^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. | ||||
146 | EVENTLOG: { | ||||
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 | |||||
154 | my @defaultMethods = @connectMethods; | ||||
155 | my @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() | ||||
177 | if (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 | ||||
184 | my $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak; | ||||
185 | |||||
186 | |||||
187 | sub 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 | |||||
202 | sub 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 | |||||
219 | sub closelog { | ||||
220 | disconnect_log() if $connected; | ||||
221 | $options{$_} = 0 for keys %options; | ||||
222 | $facility = $ident = ""; | ||||
223 | $connected = 0; | ||||
224 | return 1 | ||||
225 | } | ||||
226 | |||||
227 | sub setlogmask { | ||||
228 | my $oldmask = $maskpri; | ||||
229 | $maskpri = shift unless $_[0] == 0; | ||||
230 | $oldmask; | ||||
231 | } | ||||
232 | |||||
233 | |||||
234 | my %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 | |||||
307 | sub 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 | ||||
379 | 35436 | 22.1ms | my ($priority, $mask, @args) = @_; | ||
380 | 35436 | 5.16ms | my ($message, $buf); | ||
381 | my (@words, $num, $numpri, $numfac, $sum); | ||||
382 | 35436 | 7.15ms | my $failed = undef; | ||
383 | 35436 | 4.50ms | my $fail_time = undef; | ||
384 | 35436 | 143ms | 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 | ||||
388 | 35436 | 5.24ms | openlog() unless $ident; | ||
389 | |||||
390 | 35436 | 10.5ms | local $facility = $facility; # may need to change temporarily. | ||
391 | |||||
392 | 35436 | 5.69ms | croak "syslog: expecting argument \$priority" unless defined $priority; | ||
393 | 35436 | 4.08ms | croak "syslog: expecting argument \$format" unless defined $mask; | ||
394 | |||||
395 | 35436 | 190ms | 70872 | 38.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". | ||||
402 | 35436 | 34.9ms | @words = split /\W+/, $priority, 2; | ||
403 | |||||
404 | 35436 | 7.32ms | undef $numpri; | ||
405 | 35436 | 4.19ms | undef $numfac; | ||
406 | |||||
407 | 35436 | 13.7ms | for my $word (@words) { | ||
408 | 35436 | 7.69ms | next if length $word == 0; | ||
409 | |||||
410 | # Translate word to number. | ||||
411 | 35436 | 33.2ms | 35436 | 590ms | $num = xlate($word); # spent 590ms making 35436 calls to Sys::Syslog::xlate, avg 17µs/call |
412 | |||||
413 | 35436 | 131ms | 35436 | 13.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") { | ||||
417 | 35436 | 5.59ms | croak "syslog: too many levels given: $word" | ||
418 | if defined $numpri; | ||||
419 | 35436 | 9.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 | |||||
433 | 35436 | 5.49ms | croak "syslog: level must be given" unless defined $numpri; | ||
434 | |||||
435 | # don't log if priority is below mask level | ||||
436 | 35436 | 103ms | 35436 | 15.1ms | return 0 unless LOG_MASK($numpri) & $maskpri; # spent 15.1ms making 35436 calls to Sys::Syslog::LOG_MASK, avg 425ns/call |
437 | |||||
438 | 35436 | 11.4ms | if (not defined $numfac) { # Facility not specified in this call. | ||
439 | 35436 | 5.09ms | $facility = 'user' unless $facility; | ||
440 | 35436 | 32.1ms | 35436 | 503ms | $numfac = xlate($facility); # spent 503ms making 35436 calls to Sys::Syslog::xlate, avg 14µs/call |
441 | } | ||||
442 | |||||
443 | 35436 | 4.80ms | connect_log() unless $connected; | ||
444 | |||||
445 | 35436 | 78.0ms | 35436 | 9.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 | ||||
453 | 35436 | 20.6ms | $mask .= "\n" if !$options{noeol} and rindex($mask, "\n") == -1; | ||
454 | 35436 | 23.4ms | $message = @args ? sprintf($mask, @args) : $mask; | ||
455 | |||||
456 | 35436 | 14.6ms | if ($current_proto eq 'native') { | ||
457 | $buf = $message; | ||||
458 | } | ||||
459 | elsif ($current_proto eq 'eventlog') { | ||||
460 | $buf = $message; | ||||
461 | } | ||||
462 | else { | ||||
463 | 35436 | 7.04ms | my $whoami = $ident; | ||
464 | 35436 | 7.24ms | $whoami .= "[$$]" if $options{pid}; | ||
465 | |||||
466 | 35436 | 8.67ms | $sum = $numpri + $numfac; | ||
467 | |||||
468 | 35436 | 4.13ms | my $oldlocale; | ||
469 | 35436 | 7.07ms | if (HAVE_SETLOCALE) { | ||
470 | 35436 | 119ms | 35436 | 29.3ms | $oldlocale = setlocale(LC_TIME); # spent 29.3ms making 35436 calls to POSIX::setlocale, avg 828ns/call |
471 | 35436 | 189ms | 35436 | 103ms | 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) | ||||
475 | 35436 | 456ms | 35436 | 313ms | my $day = strftime "%e", localtime; # spent 313ms making 35436 calls to POSIX::strftime, avg 9µs/call |
476 | |||||
477 | 35436 | 11.3ms | if (index($day, "%") == 0) { | ||
478 | $day = strftime "%d", localtime; | ||||
479 | $day =~ s/^0/ /; | ||||
480 | } | ||||
481 | |||||
482 | 35436 | 362ms | 35436 | 261ms | my $timestamp = strftime "%b $day %H:%M:%S", localtime; # spent 261ms making 35436 calls to POSIX::strftime, avg 7µs/call |
483 | 35436 | 761ms | 35436 | 662ms | 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 | ||||
486 | 35436 | 19.2ms | $buf = "<$sum>$timestamp $whoami: $message"; | ||
487 | |||||
488 | # add (or not) a NUL character | ||||
489 | 35436 | 24.3ms | $buf .= "\0" if !$options{nonul}; | ||
490 | } | ||||
491 | |||||
492 | # handle PERROR option | ||||
493 | # "native" mechanism already handles it by itself | ||||
494 | 35436 | 6.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. | ||||
506 | 35436 | 10.3ms | while (scalar @fallbackMethods || $syslog_send) { | ||
507 | 35436 | 5.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 | |||||
515 | 35436 | 34.7ms | 35436 | 257ms | 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 | |||||
523 | 35436 | 4.26ms | connect_log() unless $connected; | ||
524 | 35436 | 6.92ms | $failed = undef if ($current_proto && $failed && $current_proto eq $failed); | ||
525 | |||||
526 | 35436 | 5.52ms | if ($syslog_send) { | ||
527 | 35436 | 32.8ms | 35436 | 251ms | if ($syslog_send->($buf, $numpri, $numfac)) { # spent 251ms making 35436 calls to Sys::Syslog::_syslog_send_socket, avg 7µs/call |
528 | 35436 | 5.39ms | $transmit_ok++; | ||
529 | 35436 | 128ms | 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 | |||||
540 | sub _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 | |||||
570 | sub _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 | |||||
579 | sub _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 | ||||
585 | 35436 | 12.1ms | my ($buf) = @_; | ||
586 | 35436 | 305ms | 35436 | 110ms | 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 | |||||
590 | sub _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 | sub xlate { | ||||
602 | 70872 | 18.6ms | my ($name) = @_; | ||
603 | |||||
604 | 70872 | 204ms | 70872 | 38.0ms | return $name+0 if $name =~ /^\s*\d+\s*$/; # spent 38.0ms making 70872 calls to Sys::Syslog::CORE:match, avg 537ns/call |
605 | 70872 | 21.3ms | $name = uc $name; | ||
606 | 70872 | 179ms | 70872 | 14.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. | ||||
614 | 70872 | 250ms | 70872 | 74.1ms | my $value = constant($name); # spent 74.1ms making 70872 calls to Sys::Syslog::constant, avg 1µs/call |
615 | |||||
616 | 70872 | 31.5ms | if (index($value, "not a valid") >= 0) { | ||
617 | 70872 | 11.9ms | $name = "Sys::Syslog::$name"; | ||
618 | 141744 | 285ms | 70872 | 93.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 |
619 | 70872 | 12.5ms | $value = $@ unless defined $value; | ||
620 | } | ||||
621 | |||||
622 | 70872 | 19.8ms | $value = -1 if index($value, "not a valid") >= 0; | ||
623 | |||||
624 | 70872 | 144ms | 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 | # | ||||
634 | sub 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 | |||||
664 | sub 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 | |||||
705 | sub 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 | |||||
749 | sub 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 | |||||
772 | sub 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 | |||||
792 | sub 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 | |||||
833 | sub 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 | |||||
848 | sub 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 | |||||
857 | sub 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 | ||||
874 | 35436 | 14.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 | |||||
879 | 35436 | 8.82ms | my $rin = ''; | ||
880 | 35436 | 50.6ms | vec($rin, fileno(SYSLOG), 1) = 1; | ||
881 | 35436 | 154ms | 35436 | 50.4ms | my $ret = select $rin, undef, $rin, $sock_timeout; # spent 50.4ms making 35436 calls to Sys::Syslog::CORE:sselect, avg 1µs/call |
882 | 35436 | 82.7ms | return ($ret ? 0 : 1); | ||
883 | } | ||||
884 | |||||
885 | sub 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 | # | ||||
913 | sub silent_eval (&) { | ||||
914 | local($SIG{__DIE__}, $SIG{__WARN__}, $@); | ||||
915 | return eval { $_[0]->() } | ||||
916 | } | ||||
917 | |||||
918 | sub 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 |