Filename | /usr/local/lib/perl5/5.24/mach/Sys/Syslog.pm |
Statements | Executed 82 statements in 11.5ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 154µs | 290µs | can_load | Sys::Syslog::
1 | 1 | 1 | 48µs | 57µs | BEGIN@2 | Sys::Syslog::
1 | 1 | 1 | 48µs | 111µs | BEGIN@163 | Sys::Syslog::
1 | 1 | 1 | 38µs | 93µs | BEGIN@13 | Sys::Syslog::
1 | 1 | 1 | 33µs | 102µs | BEGIN@576 | Sys::Syslog::
1 | 1 | 1 | 33µs | 111µs | BEGIN@77 | Sys::Syslog::
1 | 1 | 1 | 33µs | 87µs | BEGIN@87 | Sys::Syslog::
1 | 1 | 1 | 32µs | 80µs | BEGIN@605 | Sys::Syslog::
1 | 1 | 1 | 32µs | 800µs | BEGIN@4 | Sys::Syslog::
1 | 1 | 1 | 30µs | 11.0ms | BEGIN@9 | Sys::Syslog::
1 | 1 | 1 | 30µs | 66µs | BEGIN@3 | Sys::Syslog::
1 | 1 | 1 | 29µs | 87µs | BEGIN@169 | Sys::Syslog::
1 | 1 | 1 | 27µs | 274µs | BEGIN@7 | Sys::Syslog::
1 | 1 | 1 | 26µs | 286µs | BEGIN@8 | Sys::Syslog::
1 | 1 | 1 | 25µs | 247µs | BEGIN@5 | Sys::Syslog::
1 | 1 | 1 | 22µs | 57µs | BEGIN@6 | Sys::Syslog::
2 | 2 | 1 | 21µs | 21µs | CORE:match (opcode) | Sys::Syslog::
1 | 1 | 1 | 12µs | 12µs | LOG_DEBUG (xsub) | Sys::Syslog::
1 | 1 | 1 | 6µs | 6µs | LOG_UPTO (xsub) | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | AUTOLOAD | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:153] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:170] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:209] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:212] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:216] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:219] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:226] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:237] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:251] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:265] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:273] | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | __ANON__[:656] | 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_socket | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | _syslog_send_stream | 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 | connection_ok | 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::
0 | 0 | 0 | 0s | 0s | syslog | Sys::Syslog::
0 | 0 | 0 | 0s | 0s | xlate | Sys::Syslog::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Sys::Syslog; | ||||
2 | 2 | 87µs | 2 | 65µs | # spent 57µs (48+8) within Sys::Syslog::BEGIN@2 which was called:
# once (48µs+8µs) by Razor2::Logger::BEGIN@12 at line 2 # spent 57µs making 1 call to Sys::Syslog::BEGIN@2
# spent 8µs making 1 call to strict::import |
3 | 2 | 92µs | 2 | 102µs | # spent 66µs (30+36) within Sys::Syslog::BEGIN@3 which was called:
# once (30µs+36µs) by Razor2::Logger::BEGIN@12 at line 3 # spent 66µs making 1 call to Sys::Syslog::BEGIN@3
# spent 36µs making 1 call to warnings::import |
4 | 2 | 74µs | 2 | 1.57ms | # spent 800µs (32+768) within Sys::Syslog::BEGIN@4 which was called:
# once (32µs+768µs) by Razor2::Logger::BEGIN@12 at line 4 # spent 800µs making 1 call to Sys::Syslog::BEGIN@4
# spent 768µs making 1 call to warnings::register::import |
5 | 2 | 69µs | 2 | 468µs | # spent 247µs (25+221) within Sys::Syslog::BEGIN@5 which was called:
# once (25µs+221µs) by Razor2::Logger::BEGIN@12 at line 5 # spent 247µs making 1 call to Sys::Syslog::BEGIN@5
# spent 221µs making 1 call to Exporter::import |
6 | 2 | 65µs | 2 | 92µs | # spent 57µs (22+35) within Sys::Syslog::BEGIN@6 which was called:
# once (22µs+35µs) by Razor2::Logger::BEGIN@12 at line 6 # spent 57µs making 1 call to Sys::Syslog::BEGIN@6
# spent 35µs making 1 call to Exporter::import |
7 | 2 | 82µs | 2 | 522µs | # spent 274µs (27+248) within Sys::Syslog::BEGIN@7 which was called:
# once (27µs+248µs) by Razor2::Logger::BEGIN@12 at line 7 # spent 274µs making 1 call to Sys::Syslog::BEGIN@7
# spent 248µs making 1 call to Exporter::import |
8 | 2 | 114µs | 2 | 546µs | # spent 286µs (26+260) within Sys::Syslog::BEGIN@8 which was called:
# once (26µs+260µs) by Razor2::Logger::BEGIN@12 at line 8 # spent 286µs making 1 call to Sys::Syslog::BEGIN@8
# spent 260µs making 1 call to POSIX::import |
9 | 2 | 112µs | 2 | 21.9ms | # spent 11.0ms (30µs+10.9) within Sys::Syslog::BEGIN@9 which was called:
# once (30µs+10.9ms) by Razor2::Logger::BEGIN@12 at line 9 # spent 11.0ms making 1 call to Sys::Syslog::BEGIN@9
# spent 10.9ms making 1 call to Exporter::import |
10 | 1 | 34µs | require 5.005; | ||
11 | |||||
12 | |||||
13 | 3 | 424µs | 2 | 147µs | # spent 93µs (38+54) within Sys::Syslog::BEGIN@13 which was called:
# once (38µs+54µs) by Razor2::Logger::BEGIN@12 at line 13 # spent 93µs making 1 call to Sys::Syslog::BEGIN@13
# spent 54µs making 1 call to strict::unimport |
14 | 1 | 2µs | $VERSION = '0.33_01'; | ||
15 | |||||
16 | 1 | 18µ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 = ( | ||||
54 | 2 | 8µs | @{$EXPORT_TAGS{standard}}, | ||
55 | ); | ||||
56 | |||||
57 | @EXPORT_OK = ( | ||||
58 | 1 | 2µs | @{$EXPORT_TAGS{extended}}, | ||
59 | 2 | 24µs | @{$EXPORT_TAGS{macros}}, | ||
60 | ); | ||||
61 | |||||
62 | eval { | ||||
63 | 1 | 2µs | require XSLoader; | ||
64 | 1 | 539µs | 1 | 520µs | XSLoader::load('Sys::Syslog', $VERSION); # spent 520µs making 1 call to XSLoader::load |
65 | 1 | 3µs | 1 | ||
66 | 1 | 4µs | } or do { | ||
67 | require DynaLoader; | ||||
68 | push @ISA, 'DynaLoader'; | ||||
69 | bootstrap Sys::Syslog $VERSION; | ||||
70 | }; | ||||
71 | } | ||||
72 | |||||
73 | |||||
74 | # | ||||
75 | # Public variables | ||||
76 | # | ||||
77 | 2 | 123µs | 2 | 190µs | # spent 111µs (33+78) within Sys::Syslog::BEGIN@77 which was called:
# once (33µs+78µs) by Razor2::Logger::BEGIN@12 at line 77 # spent 111µs making 1 call to Sys::Syslog::BEGIN@77
# spent 78µs making 1 call to vars::import |
78 | |||||
79 | # | ||||
80 | # Prototypes | ||||
81 | # | ||||
82 | sub silent_eval (&); | ||||
83 | |||||
84 | # | ||||
85 | # Global variables | ||||
86 | # | ||||
87 | 2 | 633µs | 2 | 142µs | # spent 87µs (33+55) within Sys::Syslog::BEGIN@87 which was called:
# once (33µs+55µs) by Razor2::Logger::BEGIN@12 at line 87 # spent 87µs making 1 call to Sys::Syslog::BEGIN@87
# spent 55µs making 1 call to vars::import |
88 | 1 | 2µs | my $connected = 0; # flag to indicate if we're connected or not | ||
89 | 1 | 1µs | my $syslog_send; # coderef of the function used to send messages | ||
90 | 1 | 2µs | my $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms | ||
91 | 1 | 2µs | my $syslog_xobj = undef; # if defined, holds the external object used to send messages | ||
92 | 1 | 2µs | my $transmit_ok = 0; # flag to indicate if the last message was transmitted | ||
93 | 1 | 2µs | my $sock_port = undef; # socket port | ||
94 | 1 | 2µs | my $sock_timeout = 0; # socket timeout, see below | ||
95 | 1 | 2µs | my $current_proto = undef; # current mechanism used to transmit messages | ||
96 | 1 | 2µs | my $ident = ''; # identifiant prepended to each message | ||
97 | 1 | 2µs | $facility = ''; # current facility | ||
98 | 1 | 40µs | 2 | 18µs | my $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask # spent 12µs making 1 call to Sys::Syslog::LOG_DEBUG
# spent 6µs making 1 call to Sys::Syslog::LOG_UPTO |
99 | |||||
100 | 1 | 6µs | my %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. | ||||
112 | 1 | 8µs | my @connectMethods = qw(native tcp udp unix pipe stream console); | ||
113 | 1 | 12µs | if ($^O eq "freebsd" or $^O eq "linux") { | ||
114 | 8 | 44µ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. | ||||
119 | EVENTLOG: { | ||||
120 | 2 | 31µs | 1 | 15µs | my $is_Win32 = $^O =~ /Win32/i; # spent 15µs making 1 call to Sys::Syslog::CORE:match |
121 | |||||
122 | 1 | 10µs | 1 | 290µs | if (can_load("Sys::Syslog::Win32", $is_Win32)) { # spent 290µs making 1 call to Sys::Syslog::can_load |
123 | unshift @connectMethods, 'eventlog'; | ||||
124 | } | ||||
125 | } | ||||
126 | |||||
127 | 1 | 4µs | my @defaultMethods = @connectMethods; | ||
128 | 1 | 2µs | my @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 | |||||
146 | 1 | 14µs | 1 | 6µ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() | ||||
150 | 1 | 2µs | if (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 | ||||
157 | 1 | 3µs | my $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak; | ||
158 | |||||
159 | |||||
160 | sub AUTOLOAD { | ||||
161 | # This AUTOLOAD is used to 'autoload' constants from the constant() | ||||
162 | # XS function. | ||||
163 | 2 | 172µs | 2 | 173µs | # spent 111µs (48+62) within Sys::Syslog::BEGIN@163 which was called:
# once (48µs+62µs) by Razor2::Logger::BEGIN@12 at line 163 # spent 111µs making 1 call to Sys::Syslog::BEGIN@163
# spent 62µ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; | ||||
169 | 2 | 4.71ms | 2 | 145µs | # spent 87µs (29+58) within Sys::Syslog::BEGIN@169 which was called:
# once (29µs+58µs) by Razor2::Logger::BEGIN@12 at line 169 # spent 87µs making 1 call to Sys::Syslog::BEGIN@169
# spent 58µs making 1 call to strict::unimport |
170 | *$AUTOLOAD = sub { $val }; | ||||
171 | goto &$AUTOLOAD; | ||||
172 | } | ||||
173 | |||||
174 | |||||
175 | sub 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 | |||||
192 | sub closelog { | ||||
193 | disconnect_log() if $connected; | ||||
194 | $options{$_} = 0 for keys %options; | ||||
195 | $facility = $ident = ""; | ||||
196 | $connected = 0; | ||||
197 | return 1 | ||||
198 | } | ||||
199 | |||||
200 | sub setlogmask { | ||||
201 | my $oldmask = $maskpri; | ||||
202 | $maskpri = shift unless $_[0] == 0; | ||||
203 | $oldmask; | ||||
204 | } | ||||
205 | |||||
206 | |||||
207 | my %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 | }, | ||||
274 | 1 | 48µs | err_msg => "path not available", | ||
275 | }, | ||||
276 | ); | ||||
277 | |||||
278 | sub 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 | |||||
349 | sub 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 | |||||
498 | sub _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 | |||||
528 | sub _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 | |||||
537 | sub _syslog_send_pipe { | ||||
538 | my ($buf) = @_; | ||||
539 | return print SYSLOG $buf; | ||||
540 | } | ||||
541 | |||||
542 | sub _syslog_send_socket { | ||||
543 | my ($buf) = @_; | ||||
544 | return syswrite(SYSLOG, $buf, length($buf)); | ||||
545 | #return send(SYSLOG, $buf, 0); | ||||
546 | } | ||||
547 | |||||
548 | sub _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 | # | ||||
559 | sub 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"; | ||||
576 | 2 | 292µs | 2 | 171µs | # spent 102µs (33+69) within Sys::Syslog::BEGIN@576 which was called:
# once (33µs+69µs) by Razor2::Logger::BEGIN@12 at line 576 # spent 102µs making 1 call to Sys::Syslog::BEGIN@576
# spent 69µ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 | # | ||||
592 | sub 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) { | ||||
605 | 2 | 3.32ms | 2 | 127µs | # spent 80µs (32+47) within Sys::Syslog::BEGIN@605 which was called:
# once (32µs+47µs) by Razor2::Logger::BEGIN@12 at line 605 # spent 80µs making 1 call to Sys::Syslog::BEGIN@605
# spent 47µ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 | |||||
622 | sub 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 | |||||
670 | sub 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 | |||||
719 | sub 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 | |||||
742 | sub 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 | |||||
762 | sub 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 | |||||
803 | sub 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 | |||||
818 | sub 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 | |||||
827 | sub 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... | ||||
843 | sub 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 | |||||
855 | sub 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 | # | ||||
883 | sub silent_eval (&) { | ||||
884 | local($SIG{__DIE__}, $SIG{__WARN__}, $@); | ||||
885 | return eval { $_[0]->() } | ||||
886 | } | ||||
887 | |||||
888 | # spent 290µs (154+136) within Sys::Syslog::can_load which was called:
# once (154µs+136µs) by Razor2::Logger::BEGIN@12 at line 122 | ||||
889 | 1 | 7µs | my ($module, $verbose) = @_; | ||
890 | 1 | 10µs | local($SIG{__DIE__}, $SIG{__WARN__}, $@); | ||
891 | 1 | 5µs | local @INC = @INC; | ||
892 | 1 | 2µs | pop @INC if $INC[-1] eq '.'; | ||
893 | 1 | 89µs | my $loaded = eval "use $module; 1"; # spent 153µs executing statements in string eval # includes 136µs spent executing 1 call to 1 sub defined therein. | ||
894 | 1 | 2µs | warn $@ if not $loaded and $verbose; | ||
895 | 1 | 27µs | return $loaded | ||
896 | } | ||||
897 | |||||
898 | |||||
899 | 1 | 106µs | "Eighth Rule: read the documentation." | ||
900 | |||||
901 | __END__ | ||||
sub Sys::Syslog::CORE:match; # opcode | |||||
# spent 12µs within Sys::Syslog::LOG_DEBUG which was called:
# once (12µs+0s) by Razor2::Logger::BEGIN@12 at line 98 | |||||
# spent 6µs within Sys::Syslog::LOG_UPTO which was called:
# once (6µs+0s) by Razor2::Logger::BEGIN@12 at line 98 |