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