lib/Sys/Syslog.pm

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