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
  63 by C<_PATH_LOG> in F<syslog.ph>.  A value of 'inet' will connect
  64 to an INET socket returned by getservbyname().
  65 Any other value croaks.
  66
  67 The default is for the INET socket to be used.
  68
  69
  70 =item closelog
  71
  72 Closes the log file.
  73
  74 =back
  75
  76 Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
  77
  78 =head1 EXAMPLES
  79
  80     openlog($program, 'cons,pid', 'user');
  81     syslog('info', 'this is another test');
  82     syslog('mail|warning', 'this is a better test: %d', time);
  83     closelog();
  84
  85     syslog('debug', 'this is the last test');
  86
  87     setlogsock('unix');
  88     openlog("$program $$", 'ndelay', 'user');
  89     syslog('notice', 'fooprogram: this is really done');
  90
  91     setlogsock('inet');
  92     $! = 55;
  93     syslog('info', 'problem was %m'); # %m == $! in syslog(3)
  94
  95 =head1 DEPENDENCIES
  96
  97 B<Sys::Syslog> needs F<syslog.ph>, which can be created with C<h2ph>.
  98
  99 =head1 SEE ALSO
 100
 101 L<syslog(3)>
 102
 103 =head1 AUTHOR
 104
 105 Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>.
 106 UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt>
 107 with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list.
 108
 109 =cut
 110
 111 require 'syslog.ph';
 112
 113 $maskpri = &LOG_UPTO(&LOG_DEBUG);
 114
 115 sub openlog {
 116     ($ident, $logopt, $facility) = @_;  # package vars
 117     $lo_pid = $logopt =~ /\bpid\b/;
 118     $lo_ndelay = $logopt =~ /\bndelay\b/;
 119     $lo_cons = $logopt =~ /\bcons\b/;
 120     $lo_nowait = $logopt =~ /\bnowait\b/;
 121     &connect if $lo_ndelay;
 122 }
 123
 124 sub closelog {
 125     $facility = $ident = '';
 126     &disconnect;
 127 }
 128
 129 sub setlogmask {
 130     local($oldmask) = $maskpri;
 131     $maskpri = shift;
 132     $oldmask;
 133 }
 134
 135 sub setlogsock {
 136     local($setsock) = shift;
 137     if (lc($setsock) eq 'unix') {
 138         $sock_unix = 1;
 139     } elsif (lc($setsock) eq 'inet') {
 140         undef($sock_unix);
 141     } else {
 142         croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'";
 143     }
 144 }
 145
 146 sub syslog {
 147     local($priority) = shift;
 148     local($mask) = shift;
 149     local($message, $whoami);
 150     local(@words, $num, $numpri, $numfac, $sum);
 151     local($facility) = $facility;       # may need to change temporarily.
 152
 153     croak "syslog: expected both priority and mask" unless $mask && $priority;
 154
 155     @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
 156     undef $numpri;
 157     undef $numfac;
 158     foreach (@words) {
 159         $num = &xlate($_);              # Translate word to number.
 160         if (/^kern$/ || $num < 0) {
 161             croak "syslog: invalid level/facility: $_";
 162         }
 163         elsif ($num <= &LOG_PRIMASK) {
 164             croak "syslog: too many levels given: $_" if defined($numpri);
 165             $numpri = $num;
 166             return 0 unless &LOG_MASK($numpri) & $maskpri;
 167         }
 168         else {
 169             croak "syslog: too many facilities given: $_" if defined($numfac);
 170             $facility = $_;
 171             $numfac = $num;
 172         }
 173     }
 174
 175     croak "syslog: level must be given" unless defined($numpri);
 176
 177     if (!defined($numfac)) {    # Facility not specified in this call.
 178         $facility = 'user' unless $facility;
 179         $numfac = &xlate($facility);
 180     }
 181
 182     &connect unless $connected;
 183
 184     $whoami = $ident;
 185
 186     if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
 187         $whoami = $1;
 188         $mask = $2;
 189     }
 190
 191     unless ($whoami) {
 192         ($whoami = getlogin) ||
 193             ($whoami = getpwuid($<)) ||
 194                 ($whoami = 'syslog');
 195     }
 196
 197     $whoami .= "[$$]" if $lo_pid;
 198
 199     $mask =~ s/%m/$!/g;
 200     $mask .= "\n" unless $mask =~ /\n$/;
 201     $message = sprintf ($mask, @_);
 202
 203     $sum = $numpri + $numfac;
 204     unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) {
 205         if ($lo_cons) {
 206             if ($pid = fork) {
 207                 unless ($lo_nowait) {
 208                     $died = waitpid($pid, 0);
 209                 }
 210             }
 211             else {
 212                 open(CONS,">/dev/console");
 213                 print CONS "<$facility.$priority>$whoami: $message\r";
 214                 exit if defined $pid;           # if fork failed, we're parent
 215                 close CONS;
 216             }
 217         }
 218     }
 219 }
 220
 221 sub xlate {
 222     local($name) = @_;
 223     $name = uc $name;
 224     $name = "LOG_$name" unless $name =~ /^LOG_/;
 225     $name = "Sys::Syslog::$name";
 226     defined &$name ? &$name : -1;
 227 }
 228
 229 sub connect {
 230     unless ($host) {
 231         require Sys::Hostname;
 232         my($host_uniq) = Sys::Hostname::hostname();
 233         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
 234     }
 235     unless ( $sock_unix ) {
 236         my $udp = getprotobyname('udp');
 237         my $syslog = getservbyname('syslog','udp');
 238         my $this = sockaddr_in($syslog, INADDR_ANY);
 239         my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
 240         socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)           || croak "socket: $!";
 241         connect(SYSLOG,$that)                            || croak "connect: $!";
 242     } else {
 243         my $syslog = &_PATH_LOG                          || croak "_PATH_LOG not found in syslog.ph";
 244         my $that = sockaddr_un($syslog)                  || croak "Can't locate $syslog";
 245         socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)             || croak "open: $!";
 246         connect(SYSLOG,$that)                            || croak "connect: $!";
 247     }
 248     local($old) = select(SYSLOG); $| = 1; select($old);
 249     $connected = 1;
 250 }
 251
 252 sub disconnect {
 253     close SYSLOG;
 254     $connected = 0;
 255 }
 256
 257 1;