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     return 1 unless $lo_ndelay;
 128     &connect;
 129 }
 130
 131 sub closelog {
 132     $facility = $ident = '';
 133     &disconnect;
 134 }
 135
 136 sub setlogmask {
 137     local($oldmask) = $maskpri;
 138     $maskpri = shift;
 139     $oldmask;
 140 }
 141
 142 sub setlogsock {
 143     local($setsock) = shift;
 144     &disconnect if $connected;
 145     if (lc($setsock) eq 'unix') {
 146         if (defined &_PATH_LOG) {
 147             $sock_type = 1;
 148         } else {
 149             return undef;
 150         }
 151     } elsif (lc($setsock) eq 'inet') {
 152         if (getservbyname('syslog','udp')) {
 153             undef($sock_type);
 154         } else {
 155             return undef;
 156         }
 157     } else {
 158         croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'";
 159     }
 160     return 1;
 161 }
 162
 163 sub syslog {
 164     local($priority) = shift;
 165     local($mask) = shift;
 166     local($message, $whoami);
 167     local(@words, $num, $numpri, $numfac, $sum);
 168     local($facility) = $facility;       # may need to change temporarily.
 169
 170     croak "syslog: expected both priority and mask" unless $mask && $priority;
 171
 172     @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
 173     undef $numpri;
 174     undef $numfac;
 175     foreach (@words) {
 176         $num = &xlate($_);              # Translate word to number.
 177         if (/^kern$/ || $num < 0) {
 178             croak "syslog: invalid level/facility: $_";
 179         }
 180         elsif ($num <= &LOG_PRIMASK) {
 181             croak "syslog: too many levels given: $_" if defined($numpri);
 182             $numpri = $num;
 183             return 0 unless &LOG_MASK($numpri) & $maskpri;
 184         }
 185         else {
 186             croak "syslog: too many facilities given: $_" if defined($numfac);
 187             $facility = $_;
 188             $numfac = $num;
 189         }
 190     }
 191
 192     croak "syslog: level must be given" unless defined($numpri);
 193
 194     if (!defined($numfac)) {    # Facility not specified in this call.
 195         $facility = 'user' unless $facility;
 196         $numfac = &xlate($facility);
 197     }
 198
 199     &connect unless $connected;
 200
 201     $whoami = $ident;
 202
 203     if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
 204         $whoami = $1;
 205         $mask = $2;
 206     }
 207
 208     unless ($whoami) {
 209         ($whoami = getlogin) ||
 210             ($whoami = getpwuid($<)) ||
 211                 ($whoami = 'syslog');
 212     }
 213
 214     $whoami .= "[$$]" if $lo_pid;
 215
 216     $mask =~ s/%m/$!/g;
 217     $mask .= "\n" unless $mask =~ /\n$/;
 218     $message = sprintf ($mask, @_);
 219
 220     $sum = $numpri + $numfac;
 221     unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) {
 222         if ($lo_cons) {
 223             if ($pid = fork) {
 224                 unless ($lo_nowait) {
 225                     $died = waitpid($pid, 0);
 226                 }
 227             }
 228             else {
 229                 open(CONS,">/dev/console");
 230                 print CONS "<$facility.$priority>$whoami: $message\r";
 231                 exit if defined $pid;           # if fork failed, we're parent
 232                 close CONS;
 233             }
 234         }
 235     }
 236 }
 237
 238 sub xlate {
 239     local($name) = @_;
 240     $name = uc $name;
 241     $name = "LOG_$name" unless $name =~ /^LOG_/;
 242     $name = "Sys::Syslog::$name";
 243     defined &$name ? &$name : -1;
 244 }
 245
 246 sub connect {
 247     unless ($host) {
 248         require Sys::Hostname;
 249         my($host_uniq) = Sys::Hostname::hostname();
 250         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
 251     }
 252     unless ( $sock_type ) {
 253         my $udp = getprotobyname('udp');
 254         my $syslog = getservbyname('syslog','udp');
 255         my $this = sockaddr_in($syslog, INADDR_ANY);
 256         my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
 257         socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)           || croak "socket: $!";
 258         connect(SYSLOG,$that)                            || croak "connect: $!";
 259     } else {
 260         my $syslog = &_PATH_LOG                          || croak "_PATH_LOG not found in syslog.ph";
 261         my $that = sockaddr_un($syslog)                  || croak "Can't locate $syslog";
 262         socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)             || croak "socket: $!";
 263         if (!connect(SYSLOG,$that)) {
 264             socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)          || croak "socket: $!";
 265             connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)";
 266         }
 267     }
 268     local($old) = select(SYSLOG); $| = 1; select($old);
 269     $connected = 1;
 270 }
 271
 272 sub disconnect {
 273     close SYSLOG;
 274     $connected = 0;
 275 }
 276
 277 1;