This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
patchlevel up to 72, update Changes, minor tweaks to win32/config*
[perl5.git] / lib / Sys / Syslog.pm
CommitLineData
a0d0e21e
LW
1package Sys::Syslog;
2require 5.000;
3require Exporter;
4use Carp;
5
6@ISA = qw(Exporter);
7@EXPORT = qw(openlog closelog setlogmask syslog);
8
37120919 9use Socket;
55497cff 10use Sys::Hostname;
37120919 11
5be1dfc7 12# adapted from syslog.pl
a0d0e21e 13#
5be1dfc7 14# Tom Christiansen <tchrist@convex.com>
a0d0e21e
LW
15# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
16# NOTE: openlog now takes three arguments, just like openlog(3)
5be1dfc7
HF
17
18=head1 NAME
19
20Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
21
22=head1 SYNOPSIS
23
24 use Sys::Syslog;
25
26 openlog $ident, $logopt, $facility;
2eae817d 27 syslog $priority, $format, @args;
5be1dfc7
HF
28 $oldmask = setlogmask $mask_priority;
29 closelog;
30
31=head1 DESCRIPTION
32
33Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
34Call C<syslog()> with a string priority and a list of C<printf()> args
35just like C<syslog(3)>.
36
37Syslog provides the functions:
38
39=over
40
41=item openlog $ident, $logopt, $facility
42
43I<$ident> is prepended to every message.
44I<$logopt> contains one or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>.
45I<$facility> specifies the part of the system
46
2eae817d 47=item syslog $priority, $format, @args
5be1dfc7 48
2eae817d 49If I<$priority> permits, logs I<($format, @args)>
5be1dfc7
HF
50printed as by C<printf(3V)>, with the addition that I<%m>
51is replaced with C<"$!"> (the latest error message).
52
53=item setlogmask $mask_priority
54
55Sets log mask I<$mask_priority> and returns the old mask.
56
f8b75b0c 57=item setlogsock $sock_type (added in 5.004_03)
cb63fe9d
TB
58
59Sets the socket type to be used for the next call to
60C<openlog()> or C<syslog()>.
61
f8b75b0c
TB
62A value of 'unix' will connect to the UNIX domain socket returned by
63C<_PATH_LOG> in F<syslog.ph>. If F<syslog.ph> fails to define
64C<_PATH_LOG>, C<setlogsock> returns C<undef>; otherwise a true value is
65returned. A value of 'inet' will connect to an INET socket returned by
66getservbyname(). Any other value croaks.
cb63fe9d
TB
67
68The default is for the INET socket to be used.
69
70
5be1dfc7
HF
71=item closelog
72
73Closes the log file.
74
75=back
76
77Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
78
79=head1 EXAMPLES
80
81 openlog($program, 'cons,pid', 'user');
82 syslog('info', 'this is another test');
83 syslog('mail|warning', 'this is a better test: %d', time);
84 closelog();
85
86 syslog('debug', 'this is the last test');
cb63fe9d
TB
87
88 setlogsock('unix');
5be1dfc7
HF
89 openlog("$program $$", 'ndelay', 'user');
90 syslog('notice', 'fooprogram: this is really done');
91
cb63fe9d 92 setlogsock('inet');
5be1dfc7
HF
93 $! = 55;
94 syslog('info', 'problem was %m'); # %m == $! in syslog(3)
95
96=head1 DEPENDENCIES
97
98B<Sys::Syslog> needs F<syslog.ph>, which can be created with C<h2ph>.
99
100=head1 SEE ALSO
101
102L<syslog(3)>
103
104=head1 AUTHOR
105
cb63fe9d
TB
106Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>.
107UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt>
108with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list.
5be1dfc7
HF
109
110=cut
a0d0e21e 111
a0d0e21e
LW
112require 'syslog.ph';
113
114$maskpri = &LOG_UPTO(&LOG_DEBUG);
115
116sub openlog {
117 ($ident, $logopt, $facility) = @_; # package vars
118 $lo_pid = $logopt =~ /\bpid\b/;
119 $lo_ndelay = $logopt =~ /\bndelay\b/;
120 $lo_cons = $logopt =~ /\bcons\b/;
121 $lo_nowait = $logopt =~ /\bnowait\b/;
122 &connect if $lo_ndelay;
123}
124
125sub closelog {
126 $facility = $ident = '';
127 &disconnect;
128}
129
130sub setlogmask {
131 local($oldmask) = $maskpri;
132 $maskpri = shift;
133 $oldmask;
134}
135
cb63fe9d
TB
136sub setlogsock {
137 local($setsock) = shift;
138 if (lc($setsock) eq 'unix') {
f8b75b0c
TB
139 if (defined &_PATH_LOG) {
140 $sock_unix = 1;
141 } else {
142 return undef;
143 }
cb63fe9d
TB
144 } elsif (lc($setsock) eq 'inet') {
145 undef($sock_unix);
146 } else {
147 croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'";
148 }
f8b75b0c 149 return 1;
cb63fe9d
TB
150}
151
a0d0e21e
LW
152sub syslog {
153 local($priority) = shift;
154 local($mask) = shift;
155 local($message, $whoami);
156 local(@words, $num, $numpri, $numfac, $sum);
157 local($facility) = $facility; # may need to change temporarily.
158
159 croak "syslog: expected both priority and mask" unless $mask && $priority;
160
161 @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
162 undef $numpri;
163 undef $numfac;
164 foreach (@words) {
165 $num = &xlate($_); # Translate word to number.
166 if (/^kern$/ || $num < 0) {
167 croak "syslog: invalid level/facility: $_";
168 }
169 elsif ($num <= &LOG_PRIMASK) {
170 croak "syslog: too many levels given: $_" if defined($numpri);
171 $numpri = $num;
172 return 0 unless &LOG_MASK($numpri) & $maskpri;
173 }
174 else {
175 croak "syslog: too many facilities given: $_" if defined($numfac);
176 $facility = $_;
177 $numfac = $num;
178 }
179 }
180
181 croak "syslog: level must be given" unless defined($numpri);
182
183 if (!defined($numfac)) { # Facility not specified in this call.
184 $facility = 'user' unless $facility;
185 $numfac = &xlate($facility);
186 }
187
188 &connect unless $connected;
189
190 $whoami = $ident;
191
5dad0344 192 if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
a0d0e21e
LW
193 $whoami = $1;
194 $mask = $2;
195 }
196
197 unless ($whoami) {
198 ($whoami = getlogin) ||
199 ($whoami = getpwuid($<)) ||
200 ($whoami = 'syslog');
201 }
202
203 $whoami .= "[$$]" if $lo_pid;
204
205 $mask =~ s/%m/$!/g;
206 $mask .= "\n" unless $mask =~ /\n$/;
207 $message = sprintf ($mask, @_);
208
209 $sum = $numpri + $numfac;
cb63fe9d 210 unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) {
a0d0e21e
LW
211 if ($lo_cons) {
212 if ($pid = fork) {
213 unless ($lo_nowait) {
cb1a09d0 214 $died = waitpid($pid, 0);
a0d0e21e
LW
215 }
216 }
217 else {
218 open(CONS,">/dev/console");
219 print CONS "<$facility.$priority>$whoami: $message\r";
220 exit if defined $pid; # if fork failed, we're parent
221 close CONS;
222 }
223 }
224 }
225}
226
227sub xlate {
228 local($name) = @_;
55497cff 229 $name = uc $name;
a0d0e21e 230 $name = "LOG_$name" unless $name =~ /^LOG_/;
748a9306 231 $name = "Sys::Syslog::$name";
36477c24 232 defined &$name ? &$name : -1;
a0d0e21e
LW
233}
234
235sub connect {
4fc7577b
PP
236 unless ($host) {
237 require Sys::Hostname;
2eae817d 238 my($host_uniq) = Sys::Hostname::hostname();
3e3baf6d 239 ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
4fc7577b 240 }
cb63fe9d
TB
241 unless ( $sock_unix ) {
242 my $udp = getprotobyname('udp');
243 my $syslog = getservbyname('syslog','udp');
244 my $this = sockaddr_in($syslog, INADDR_ANY);
245 my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
246 socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!";
247 connect(SYSLOG,$that) || croak "connect: $!";
248 } else {
249 my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph";
250 my $that = sockaddr_un($syslog) || croak "Can't locate $syslog";
251 socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "open: $!";
252 connect(SYSLOG,$that) || croak "connect: $!";
253 }
a0d0e21e
LW
254 local($old) = select(SYSLOG); $| = 1; select($old);
255 $connected = 1;
256}
257
258sub disconnect {
259 close SYSLOG;
260 $connected = 0;
261}
262
2631;