ext/Sys/Syslog/Syslog.pm

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