lib/syslog.pl

   1 warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n";
   2
   3 #
   4 # syslog.pl
   5 #
   6 # $Log: syslog.pl,v $
   7 #
   8 # tom christiansen <tchrist@convex.com>
   9 # modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
  10 # NOTE: openlog now takes three arguments, just like openlog(3)
  11 #
  12 # call syslog() with a string priority and a list of printf() args
  13 # like syslog(3)
  14 #
  15 #  usage: require 'syslog.pl';
  16 #
  17 #  then (put these all in a script to test function)
  18 #
  19 #
  20 #       do openlog($program,'cons,pid','user');
  21 #       do syslog('info','this is another test');
  22 #       do syslog('mail|warning','this is a better test: %d', time);
  23 #       do closelog();
  24 #
  25 #       do syslog('debug','this is the last test');
  26 #       do openlog("$program $$",'ndelay','user');
  27 #       do syslog('notice','fooprogram: this is really done');
  28 #
  29 #       $! = 55;
  30 #       do syslog('info','problem was %m'); # %m == $! in syslog(3)
  31
  32 package syslog;
  33
  34 use warnings::register;
  35
  36 $host = 'localhost' unless $host;       # set $syslog'host to change
  37
  38 if ($] >= 5 && warnings::enabled()) {
  39     warnings::warn("You should 'use Sys::Syslog' instead; continuing");
  40 }
  41
  42 require 'syslog.ph';
  43
  44  eval 'use Socket; 1'                   ||
  45      eval { require "socket.ph" }       ||
  46      require "sys/socket.ph";
  47
  48 $maskpri = &LOG_UPTO(&LOG_DEBUG);
  49
  50 sub main'openlog {
  51     ($ident, $logopt, $facility) = @_;  # package vars
  52     $lo_pid = $logopt =~ /\bpid\b/;
  53     $lo_ndelay = $logopt =~ /\bndelay\b/;
  54     $lo_cons = $logopt =~ /\bcons\b/;
  55     $lo_nowait = $logopt =~ /\bnowait\b/;
  56     &connect if $lo_ndelay;
  57 }
  58
  59 sub main'closelog {
  60     $facility = $ident = '';
  61     &disconnect;
  62 }
  63
  64 sub main'setlogmask {
  65     local($oldmask) = $maskpri;
  66     $maskpri = shift;
  67     $oldmask;
  68 }
  69
  70 sub main'syslog {
  71     local($priority) = shift;
  72     local($mask) = shift;
  73     local($message, $whoami);
  74     local(@words, $num, $numpri, $numfac, $sum);
  75     local($facility) = $facility;       # may need to change temporarily.
  76
  77     die "syslog: expected both priority and mask" unless $mask && $priority;
  78
  79     @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
  80     undef $numpri;
  81     undef $numfac;
  82     foreach (@words) {
  83         $num = &xlate($_);              # Translate word to number.
  84         if (/^kern$/ || $num < 0) {
  85             die "syslog: invalid level/facility: $_\n";
  86         }
  87         elsif ($num <= &LOG_PRIMASK) {
  88             die "syslog: too many levels given: $_\n" if defined($numpri);
  89             $numpri = $num;
  90             return 0 unless &LOG_MASK($numpri) & $maskpri;
  91         }
  92         else {
  93             die "syslog: too many facilities given: $_\n" if defined($numfac);
  94             $facility = $_;
  95             $numfac = $num;
  96         }
  97     }
  98
  99     die "syslog: level must be given\n" unless defined($numpri);
 100
 101     if (!defined($numfac)) {    # Facility not specified in this call.
 102         $facility = 'user' unless $facility;
 103         $numfac = &xlate($facility);
 104     }
 105
 106     &connect unless $connected;
 107
 108     $whoami = $ident;
 109
 110     if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
 111         $whoami = $1;
 112         $mask = $2;
 113     }
 114
 115     unless ($whoami) {
 116         ($whoami = getlogin) ||
 117             ($whoami = getpwuid($<)) ||
 118                 ($whoami = 'syslog');
 119     }
 120
 121     $whoami .= "[$$]" if $lo_pid;
 122
 123     $mask =~ s/%m/$!/g;
 124     $mask .= "\n" unless $mask =~ /\n$/;
 125     $message = sprintf ($mask, @_);
 126
 127     $sum = $numpri + $numfac;
 128     unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
 129         if ($lo_cons) {
 130             if ($pid = fork) {
 131                 unless ($lo_nowait) {
 132                     do {$died = wait;} until $died == $pid || $died < 0;
 133                 }
 134             }
 135             else {
 136                 open(CONS,">/dev/console");
 137                 print CONS "<$facility.$priority>$whoami: $message\r";
 138                 exit if defined $pid;           # if fork failed, we're parent
 139                 close CONS;
 140             }
 141         }
 142     }
 143 }
 144
 145 sub xlate {
 146     local($name) = @_;
 147     $name = uc $name;
 148     $name = "LOG_$name" unless $name =~ /^LOG_/;
 149     $name = "syslog'$name";
 150     defined &$name ? &$name : -1;
 151 }
 152
 153 sub connect {
 154     $pat = 'S n C4 x8';
 155
 156     $af_unix = &AF_UNIX;
 157     $af_inet = &AF_INET;
 158
 159     $stream = &SOCK_STREAM;
 160     $datagram = &SOCK_DGRAM;
 161
 162     ($name,$aliases,$proto) = getprotobyname('udp');
 163     $udp = $proto;
 164
 165     ($name,$aliases,$port,$proto) = getservbyname('syslog','udp');
 166     $syslog = $port;
 167
 168     if (chop($myname = `hostname`)) {
 169         ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
 170         die "Can't lookup $myname\n" unless $name;
 171         @bytes = unpack("C4",$addrs[0]);
 172     }
 173     else {
 174         @bytes = (0,0,0,0);
 175     }
 176     $this = pack($pat, $af_inet, 0, @bytes);
 177
 178     if ($host =~ /^\d+\./) {
 179         @bytes = split(/\./,$host);
 180     }
 181     else {
 182         ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
 183         die "Can't lookup $host\n" unless $name;
 184         @bytes = unpack("C4",$addrs[0]);
 185     }
 186     $that = pack($pat,$af_inet,$syslog,@bytes);
 187
 188     socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
 189     bind(SYSLOG,$this) || die "bind: $!\n";
 190     connect(SYSLOG,$that) || die "connect: $!\n";
 191
 192     local($old) = select(SYSLOG); $| = 1; select($old);
 193     $connected = 1;
 194 }
 195
 196 sub disconnect {
 197     close SYSLOG;
 198     $connected = 0;
 199 }
 200
 201 1;