This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
forked child may not exit correctly if it failed to open
[perl5.git] / ext / Sys / Syslog / Syslog.pm
1 package Sys::Syslog;
2 require 5.000;
3 require Exporter;
4 require DynaLoader;
5 use Carp;
6
7 @ISA = qw(Exporter DynaLoader);
8 @EXPORT = qw(openlog closelog setlogmask syslog);
9 @EXPORT_OK = qw(setlogsock);
10 $VERSION = '0.01';
11
12 use Socket;
13 use Sys::Hostname;
14
15 # adapted from syslog.pl
16 #
17 # Tom Christiansen <tchrist@convex.com>
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)
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
22 # Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu>
23
24 # Todo: enable connect to try all three types before failing (auto setlogsock)?
25
26 =head1 NAME
27
28 Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
29
30 =head1 SYNOPSIS
31
32     use Sys::Syslog;                          # all except setlogsock, or:
33     use Sys::Syslog qw(:DEFAULT setlogsock);  # default set, plus setlogsock
34
35     setlogsock $sock_type;
36     openlog $ident, $logopt, $facility;
37     syslog $priority, $format, @args;
38     $oldmask = setlogmask $mask_priority;
39     closelog;
40
41 =head1 DESCRIPTION
42
43 Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
44 Call C<syslog()> with a string priority and a list of C<printf()> args
45 just like C<syslog(3)>.
46
47 Syslog provides the functions:
48
49 =over
50
51 =item openlog $ident, $logopt, $facility
52
53 I<$ident> is prepended to every message.
54 I<$logopt> contains zero or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>.
55 I<$facility> specifies the part of the system
56
57 =item syslog $priority, $format, @args
58
59 If I<$priority> permits, logs I<($format, @args)>
60 printed as by C<printf(3V)>, with the addition that I<%m>
61 is replaced with C<"$!"> (the latest error message).
62
63 =item setlogmask $mask_priority
64
65 Sets log mask I<$mask_priority> and returns the old mask.
66
67 =item setlogsock $sock_type (added in 5.004_02)
68
69 Sets the socket type to be used for the next call to
70 C<openlog()> or C<syslog()> and returns TRUE on success,
71 undef on failure.
72
73 A value of 'unix' will connect to the UNIX domain socket returned by
74 C<_PATH_LOG> in F<syslog.ph>.  A value of 'inet' will connect to an
75 INET socket returned by getservbyname().  Any other value croaks.
76
77 The default is for the INET socket to be used.
78
79 =item closelog
80
81 Closes the log file.
82
83 =back
84
85 Note 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');
95
96     setlogsock('unix');
97     openlog("$program $$", 'ndelay', 'user');
98     syslog('notice', 'fooprogram: this is really done');
99
100     setlogsock('inet');
101     $! = 55;
102     syslog('info', 'problem was %m'); # %m == $! in syslog(3)
103
104 =head1 SEE ALSO
105
106 L<syslog(3)>
107
108 =head1 AUTHOR
109
110 Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>.
111 UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt>
112 with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list.
113 Dependency on F<syslog.ph> replaced with XS code bu Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
114
115 =cut
116
117 sub 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);
126     if ($! != 0) {
127         croak "Your vendor has not defined Sys::Syslog macro $constname";
128     }
129     *$AUTOLOAD = sub { $val };
130     goto &$AUTOLOAD;
131 }
132
133 bootstrap Sys::Syslog $VERSION;
134
135 $maskpri = &LOG_UPTO(&LOG_DEBUG);
136
137 sub 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/;
143     return 1 unless $lo_ndelay;
144     &connect;
145
146
147 sub closelog {
148     $facility = $ident = '';
149     &disconnect;
150
151
152 sub setlogmask {
153     local($oldmask) = $maskpri;
154     $maskpri = shift;
155     $oldmask;
156 }
157  
158 sub setlogsock {
159     local($setsock) = shift;
160     &disconnect if $connected;
161     if (lc($setsock) eq 'unix') {
162         if (defined &_PATH_LOG) {
163             $sock_type = 1;
164         } else {
165             return undef;
166         }
167     } elsif (lc($setsock) eq 'inet') {
168         if (getservbyname('syslog','udp')) {
169             undef($sock_type);
170         } else {
171             return undef;
172         }
173     } else {
174         croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'";
175     }
176     return 1;
177 }
178
179 sub 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
219     if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
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;
237     unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) {
238         if ($lo_cons) {
239             if ($pid = fork) {
240                 unless ($lo_nowait) {
241                     $died = waitpid($pid, 0);
242                 }
243             }
244             else {
245                 if (open(CONS,">/dev/console")) {
246                     print CONS "<$facility.$priority>$whoami: $message\r";
247                     close CONS;
248                 }
249                 exit if defined $pid;           # if fork failed, we're parent
250             }
251         }
252     }
253 }
254
255 sub xlate {
256     local($name) = @_;
257     $name = uc $name;
258     $name = "LOG_$name" unless $name =~ /^LOG_/;
259     $name = "Sys::Syslog::$name";
260     eval { &$name } || -1;
261 }
262
263 sub connect {
264     unless ($host) {
265         require Sys::Hostname;
266         my($host_uniq) = Sys::Hostname::hostname();
267         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
268     }
269     unless ( $sock_type ) {
270         my $udp = getprotobyname('udp');
271         my $syslog = getservbyname('syslog','udp');
272         my $this = sockaddr_in($syslog, INADDR_ANY);
273         my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
274         socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)           || croak "socket: $!";
275         connect(SYSLOG,$that)                            || croak "connect: $!";
276     } else {
277         my $syslog = _PATH_LOG()                         || croak "_PATH_LOG not found in syslog.ph";
278         my $that = sockaddr_un($syslog)                  || croak "Can't locate $syslog";
279         socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)             || croak "socket: $!";
280         if (!connect(SYSLOG,$that)) {
281             socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)          || croak "socket: $!";
282             connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)";
283         }
284     }
285     local($old) = select(SYSLOG); $| = 1; select($old);
286     $connected = 1;
287 }
288
289 sub disconnect {
290     close SYSLOG;
291     $connected = 0;
292 }
293
294 1;