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, @_ ? $_[0] : 0);
 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                 open(CONS,">/dev/console");
 246                 print CONS "<$facility.$priority>$whoami: $message\r";
 247                 exit if defined $pid;           # if fork failed, we're parent
 248                 close CONS;
 249             }
 250         }
 251     }
 252 }
 253
 254 sub xlate {
 255     local($name) = @_;
 256     $name = uc $name;
 257     $name = "LOG_$name" unless $name =~ /^LOG_/;
 258     $name = "Sys::Syslog::$name";
 259     eval { &$name } || -1;
 260 }
 261
 262 sub connect {
 263     unless ($host) {
 264         require Sys::Hostname;
 265         my($host_uniq) = Sys::Hostname::hostname();
 266         ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
 267     }
 268     unless ( $sock_type ) {
 269         my $udp = getprotobyname('udp');
 270         my $syslog = getservbyname('syslog','udp');
 271         my $this = sockaddr_in($syslog, INADDR_ANY);
 272         my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
 273         socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)           || croak "socket: $!";
 274         connect(SYSLOG,$that)                            || croak "connect: $!";
 275     } else {
 276         my $syslog = &_PATH_LOG                          || croak "_PATH_LOG not found in syslog.ph";
 277         my $that = sockaddr_un($syslog)                  || croak "Can't locate $syslog";
 278         socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)             || croak "socket: $!";
 279         if (!connect(SYSLOG,$that)) {
 280             socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)          || croak "socket: $!";
 281             connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)";
 282         }
 283     }
 284     local($old) = select(SYSLOG); $| = 1; select($old);
 285     $connected = 1;
 286 }
 287
 288 sub disconnect {
 289     close SYSLOG;
 290     $connected = 0;
 291 }
 292
 293 1;