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