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