package Sys::Syslog;
use strict;
+use warnings;
use warnings::register;
use Carp;
+use Exporter ();
use Fcntl qw(O_WRONLY);
use File::Basename;
use POSIX qw(strftime setlocale LC_TIME);
use Socket ':all';
require 5.005;
-require Exporter;
{ no strict 'vars';
- $VERSION = '0.24';
+ $VERSION = '0.25';
@ISA = qw(Exporter);
%EXPORT_TAGS = (
#
use vars qw($host); # host to send syslog messages to (see notes at end)
+#
+# Prototypes
+#
+sub silent_eval (&);
+
#
# Global variables
#
my $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms
my $syslog_xobj = undef; # if defined, holds the external object used to send messages
my $transmit_ok = 0; # flag to indicate if the last message was transmited
+my $sock_timeout = 0; # socket timeout, see below
my $current_proto = undef; # current mechanism used to transmit messages
my $ident = ''; # identifiant prepended to each message
$facility = ''; # current facility
@connectMethods = grep { $_ ne 'udp' } @connectMethods;
}
+# And on Win32 systems, we try to use the native mechanism for this
+# platform, the events logger, available through Win32::EventLog.
EVENTLOG: {
- # use EventLog on Win32
my $is_Win32 = $^O =~ /Win32/i;
- # some applications are trying to be too smart
- # yes I'm speaking of YOU, SpamAssassin, grr..
- local($SIG{__DIE__}, $SIG{__WARN__}, $@);
-
- if (eval "use Sys::Syslog::Win32; 1") {
+ if (can_load("Sys::Syslog::Win32")) {
unshift @connectMethods, 'eventlog';
}
elsif ($is_Win32) {
my @defaultMethods = @connectMethods;
my @fallbackMethods = ();
+# The timeout in connection_ok() was pushed up to 0.25 sec in
+# Sys::Syslog v0.19 in order to address a heisenbug on MacOSX:
+# http://london.pm.org/pipermail/london.pm/Week-of-Mon-20061211/005961.html
+#
+# However, this also had the effect of slowing this test for
+# all other operating systems, which apparently impacted some
+# users (cf. CPAN-RT #34753). So, in order to make everybody
+# happy, the timeout is now zero by default on all systems
+# except on OSX where it is set to 250 msec, and can be set
+# with the infamous setlogsock() function.
+$sock_timeout = 0.25 if $^O =~ /darwin/;
+
# coderef for a nicer handling of errors
my $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
$options{$opt} = 1 if exists $options{$opt}
}
- $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
+ $err_sub = delete $options{nofatal} ? \&warnings::warnif : \&croak;
return 1 unless $options{ndelay};
connect_log();
}
}
sub setlogsock {
- my $setsock = shift;
- $syslog_path = shift;
+ my ($setsock, $setpath, $settime) = @_;
+
+ $syslog_path = $setpath if defined $setpath;
+ $sock_timeout = $settime if defined $settime;
+
disconnect_log() if $connected;
$transmit_ok = 0;
@fallbackMethods = ();
@connectMethods = qw(native);
} elsif (lc $setsock eq 'eventlog') {
- if (eval "use Win32::EventLog; 1") {
+ if (can_load("Win32::EventLog")) {
@connectMethods = qw(eventlog);
} else {
warnings::warnif "eventlog passed to setlogsock, but no Win32 API available";
} elsif (lc $setsock eq 'tcp') {
if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
@connectMethods = qw(tcp);
+ $host = $syslog_path;
} else {
warnings::warnif "tcp passed to setlogsock, but tcp service unavailable";
return undef;
} elsif (lc $setsock eq 'udp') {
if (getservbyname('syslog', 'udp')) {
@connectMethods = qw(udp);
+ $host = $syslog_path;
} else {
warnings::warnif "udp passed to setlogsock, but udp service unavailable";
return undef;
croak "syslog: expecting argument \$priority" unless defined $priority;
croak "syslog: expecting argument \$format" unless defined $mask;
+ croak "syslog: invalid level/facility: $priority" if $priority =~ /^-\d+$/;
@words = split(/\W+/, $priority, 2); # Allow "level" or "level|facility".
undef $numpri;
undef $numfac;
- foreach (@words) {
- $num = xlate($_); # Translate word to number.
- if ($num < 0) {
- croak "syslog: invalid level/facility: $_"
- }
- elsif ($num <= &LOG_PRIMASK) {
- croak "syslog: too many levels given: $_" if defined $numpri;
- $numpri = $num;
- return 0 unless LOG_MASK($numpri) & $maskpri;
- }
- else {
- croak "syslog: too many facilities given: $_" if defined $numfac;
- $facility = $_;
- $numfac = $num;
- }
+ for my $word (@words) {
+ next if length $word == 0;
+
+ $num = xlate($word); # Translate word to number.
+
+ if ($num < 0) {
+ croak "syslog: invalid level/facility: $word"
+ }
+ elsif ($num <= &LOG_PRIMASK) {
+ croak "syslog: too many levels given: $word" if defined $numpri;
+ $numpri = $num;
+ return 0 unless LOG_MASK($numpri) & $maskpri;
+ }
+ else {
+ croak "syslog: too many facilities given: $word" if defined $numfac;
+ $facility = $word;
+ $numfac = $num;
+ }
}
croak "syslog: level must be given" unless defined $numpri;
# private function to translate names to numeric values
#
sub xlate {
- my($name) = @_;
+ my ($name) = @_;
+
return $name+0 if $name =~ /^\s*\d+\s*$/;
$name = uc $name;
$name = "LOG_$name" unless $name =~ /^LOG_/;
- $name = "Sys::Syslog::$name";
- # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
- my $value = eval { no strict 'refs'; &$name };
- $@ = "";
+ my $value = constant($name);
+ $value = -1 if $value =~ /not a valid/;
+
return defined $value ? $value : -1;
}
}
setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
- if (eval { IPPROTO_TCP() }) {
+ if (silent_eval { IPPROTO_TCP() }) {
# These constants don't exist in 5.005. They were added in 1999
setsockopt(SYSLOG, IPPROTO_TCP(), TCP_NODELAY(), 1);
}
- $@ = "";
if (!connect(SYSLOG, $addr)) {
push @$errs, "tcp connect: $!";
return 0;
push @$errs, "stream $syslog_path is not writable";
return 0;
}
- if (!sysopen(SYSLOG, $syslog_path, 0400, O_WRONLY)) {
+ if (!sysopen(SYSLOG, $syslog_path, O_WRONLY, 0400)) {
push @$errs, "stream can't open $syslog_path: $!";
return 0;
}
$logopt += xlate($opt) if $options{$opt}
}
- eval { openlog_xs($ident, $logopt, xlate($facility)) };
- if ($@) {
- push @$errs, $@;
- return 0;
- }
-
+ openlog_xs($ident, $logopt, xlate($facility));
$syslog_send = \&_syslog_send_native;
return 1;
my $rin = '';
vec($rin, fileno(SYSLOG), 1) = 1;
- my $ret = select $rin, undef, $rin, 0.25;
+ my $ret = select $rin, undef, $rin, $sock_timeout;
return ($ret ? 0 : 1);
}
return close SYSLOG;
}
-1;
+
+#
+# Wrappers around eval() that makes sure that nobody, and I say NOBODY,
+# ever knows that I wanted to test if something was here or not.
+# It is needed because some applications are trying to be too smart,
+# do it wrong, and it ends up in EPIC FAIL.
+# Yes I'm speaking of YOU, SpamAssassin.
+#
+sub silent_eval (&) {
+ local($SIG{__DIE__}, $SIG{__WARN__}, $@);
+ return eval $_[0]
+}
+
+sub can_load {
+ local($SIG{__DIE__}, $SIG{__WARN__}, $@);
+ return eval "use $_[0]; 1"
+}
+
+
+"Eighth Rule: read the documentation."
__END__
=head1 VERSION
-Version 0.24
+Version 0.25
=head1 SYNOPSIS
=item B<setlogsock($sock_type, $stream_location)> (added in Perl 5.004_02)
+=item B<setlogsock($sock_type, $stream_location, $sock_timeout)> (added in 0.25)
+
Sets the socket type to be used for the next call to
C<openlog()> or C<syslog()> and returns true on success,
C<undef> on failure. The available mechanisms are:
=item *
C<"tcp"> - connect to a TCP socket, on the C<syslog/tcp> or C<syslogng/tcp>
-service.
+service. If defined, the second parameter is used as a hostname to connect to.
=item *
C<"udp"> - connect to a UDP socket, on the C<syslog/udp> service.
+If defined, the second parameter is used as a hostname to connect to,
+and the third parameter as the timeout used to check for UDP response.
=item *
-C<"inet"> - connect to an INET socket, either TCP or UDP, tried in that order.
+C<"inet"> - connect to an INET socket, either TCP or UDP, tried in that
+order. If defined, the second parameter is used as a hostname to connect to.
=item *
When this calling method is used, the array should contain a list of
mechanisms which are attempted in order.
-The default is to try C<native>, C<tcp>, C<udp>, C<unix>, C<stream>, C<console>.
+The default is to try C<native>, C<tcp>, C<udp>, C<unix>, C<pipe>, C<stream>,
+C<console>.
Under systems with the Win32 API, C<eventlog> will be added as the first
mechanism to try if C<Win32::EventLog> is available.
Log to UDP port on C<$remotehost> instead of logging locally:
- setlogsock('udp');
- $Sys::Syslog::host = $remotehost;
+ setlogsock("udp", $remotehost);
openlog($program, 'ndelay', 'user');
syslog('info', 'something happened over here');
L<http://www.gnu.org/software/libc/manual/html_node/Syslog.html>
Solaris 10 documentation on syslog,
-L<http://docs.sun.com/app/docs/doc/816-5168/6mbb3hruo?a=view>
+L<http://docs.sun.com/app/docs/doc/816-5168/syslog-3c?a=view>
+
+Mac OS X documentation on syslog,
+L<http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/syslog.3.html>
-IRIX 6.4 documentation on syslog,
-L<http://techpubs.sgi.com/library/tpl/cgi-bin/getdoc.cgi?coll=0640&db=man&fname=3c+syslog>
+IRIX 6.5 documentation on syslog,
+L<http://techpubs.sgi.com/library/tpl/cgi-bin/getdoc.cgi?coll=0650&db=man&fname=3c+syslog>
AIX 5L 5.3 documentation on syslog,
L<http://publib.boulder.ibm.com/infocenter/pseries/v5r3/index.jsp?topic=/com.ibm.aix.basetechref/doc/basetrf2/syslog.htm>
HP-UX 11i documentation on syslog,
-L<http://docs.hp.com/en/B9106-90010/syslog.3C.html>
+L<http://docs.hp.com/en/B2355-60130/syslog.3C.html>
Tru64 5.1 documentation on syslog,
L<http://h30097.www3.hp.com/docs/base_doc/DOCUMENTATION/V51_HTML/MAN/MAN3/0193____.HTM>
=head1 COPYRIGHT
-Copyright (C) 1990-2007 by Larry Wall and others.
+Copyright (C) 1990-2008 by Larry Wall and others.
=head1 LICENSE
Links
-----
+Linux Fast-STREAMS
+- L<http://www.openss7.org/streams.html>
+
II12021: SYSLOGD HOWTO TCPIPINFO (z/OS, OS/390, MVS)
- L<http://www-1.ibm.com/support/docview.wss?uid=isg1II12021>
}
-BEGIN { $tests += 20 * 8 }
+BEGIN { $tests += 22 * 8 }
# try to open a syslog using all the available connection methods
my @passed = ();
for my $sock_type (qw(native eventlog unix pipe stream inet tcp udp)) {
SKIP: {
- skip "the 'stream' mechanism because a previous mechanism with similar interface succeeded", 20
+ skip "the 'stream' mechanism because a previous mechanism with similar interface succeeded", 22
if $sock_type eq 'stream' and grep {/pipe|unix/} @passed;
# setlogsock() called with an arrayref
$r = eval { setlogsock([$sock_type]) } || 0;
- skip "can't use '$sock_type' socket", 20 unless $r;
+ skip "can't use '$sock_type' socket", 22 unless $r;
is( $@, '', "[$sock_type] setlogsock() called with ['$sock_type']" );
ok( $r, "[$sock_type] setlogsock() should return true: '$r'" );
# setlogsock() called with a single argument
$r = eval { setlogsock($sock_type) } || 0;
- skip "can't use '$sock_type' socket", 18 unless $r;
+ skip "can't use '$sock_type' socket", 20 unless $r;
is( $@, '', "[$sock_type] setlogsock() called with '$sock_type'" );
ok( $r, "[$sock_type] setlogsock() should return true: '$r'" );
# openlog() without option NDELAY
$r = eval { openlog('perl', '', 'local0') } || 0;
- skip "can't connect to syslog", 16 if $@ =~ /^no connection to syslog available/;
+ skip "can't connect to syslog", 18 if $@ =~ /^no connection to syslog available/;
is( $@, '', "[$sock_type] openlog() called with facility 'local0' and without option 'ndelay'" );
ok( $r, "[$sock_type] openlog() should return true: '$r'" );
# openlog() with the option NDELAY
$r = eval { openlog('perl', 'ndelay', 'local0') } || 0;
- skip "can't connect to syslog", 14 if $@ =~ /^no connection to syslog available/;
+ skip "can't connect to syslog", 16 if $@ =~ /^no connection to syslog available/;
is( $@, '', "[$sock_type] openlog() called with facility 'local0' with option 'ndelay'" );
ok( $r, "[$sock_type] openlog() should return true: '$r'" );
like( $@, '/^syslog: invalid level\/facility: /', "[$sock_type] syslog() called with level -1" );
ok( !$r, "[$sock_type] syslog() should return false: '$r'" );
+ # syslog() with invalid level, should fail
+ $r = eval { syslog("plonk", "$test_string by connecting to a $sock_type socket") } || 0;
+ like( $@, '/^syslog: invalid level\/facility: /', "[$sock_type] syslog() called with level plonk" );
+ ok( !$r, "[$sock_type] syslog() should return false: '$r'" );
+
# syslog() with levels "info" and "notice" (as a strings), should fail
$r = eval { syslog('info,notice', "$test_string by connecting to a $sock_type socket") } || 0;
like( $@, '/^syslog: too many levels given: notice/', "[$sock_type] syslog() called with level 'info,notice'" );
projects / p5sagit/p5-mst-13.2.git / commitdiff