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