From: Sébastien Aperghis-Tramoni Date: Fri, 14 Sep 2007 01:18:04 +0000 (+0200) Subject: Fwd: CPAN Upload: S/SA/SAPER/Sys-Syslog-0.21.tar.gz X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d329efa20817c5be059265c848fe2d22504f1b7e;p=p5sagit%2Fp5-mst-13.2.git Fwd: CPAN Upload: S/SA/SAPER/Sys-Syslog-0.21.tar.gz Message-Id: <92AB5E7F-F8E1-4DEE-805C-B257A569CB62@free.fr> p4raw-id: //depot/perl@31866 --- diff --git a/ext/Sys/Syslog/Changes b/ext/Sys/Syslog/Changes index 8018b81..870a2e9 100644 --- a/ext/Sys/Syslog/Changes +++ b/ext/Sys/Syslog/Changes @@ -1,5 +1,12 @@ Revision history for Sys-Syslog +0.21 -- 2007.09.14 -- Sebastien Aperghis-Tramoni (SAPER) + [BUGFIX] setlogsock(eventlog) returned true even when it shouldn't have. + [BUGFIX] Added workaround for Mac OS X syslogd. + [FEATURE] Added "pipe" mechanism in order to support HP-UX named pipe. + Thanks to H.Merijn Brand and PROCURA. + [CODE] Sys::Syslog works again on Perl 5.005, thanks to Nicholas Clark. + 0.20 -- 2007.09.05 -- Sebastien Aperghis-Tramoni (SAPER) [DOC] Added README.win32 which was missing in MANIFEST. @@ -24,6 +31,7 @@ Revision history for Sys-Syslog [TESTS] Merged change blead@29176: suppress taint mode from t/constants.t [TESTS] Added regression tests for CPAN-RT#21866 and #25488. [EG] Added example script eg/syslog.pl + [DOC] CPAN-RT#26097: man pages were not installed. [DOC] Added the Sys::Syslog Rules. 0.18 -- 2006.08.28 -- Sebastien Aperghis-Tramoni (SAPER) diff --git a/ext/Sys/Syslog/Makefile.PL b/ext/Sys/Syslog/Makefile.PL index 511eba0..2c60688 100644 --- a/ext/Sys/Syslog/Makefile.PL +++ b/ext/Sys/Syslog/Makefile.PL @@ -5,7 +5,7 @@ eval 'use ExtUtils::MakeMaker::Coverage'; use File::Copy; use File::Path; use File::Spec; -require 5.006; +require 5.005; # create a typemap for Perl 5.6 @@ -16,7 +16,7 @@ if ($] < 5.008) { } # create a lib/ dir in order to avoid warnings in Test::Distribution -mkdir "lib"; +mkdir "lib", 0755; # virtual paths given to EU::MM my %virtual_path = ( 'Syslog.pm' => '$(INST_LIBDIR)/Syslog.pm' ); @@ -104,6 +104,10 @@ elsif (-S "/var/run/syslog" and -w _) { # Mac OS X puts it at a different path. $_PATH_LOG = "/var/run/syslog"; } +elsif (-p "/dev/log" and -w _) { + # On HP-UX, /dev/log isn't a unix domain socket but a named pipe. + $_PATH_LOG = "/dev/log"; +} elsif (-S "/dev/log" and -w _) { # Most unixes have a unix domain socket /dev/log. $_PATH_LOG = "/dev/log"; diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index b401d48..4a5a985 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -6,11 +6,11 @@ use Fcntl qw(O_WRONLY); use File::Basename; use POSIX qw(strftime setlocale LC_TIME); use Socket ':all'; -require 5.006; +require 5.005; require Exporter; { no strict 'vars'; - $VERSION = '0.20'; + $VERSION = '0.21'; @ISA = qw(Exporter); %EXPORT_TAGS = ( @@ -98,8 +98,8 @@ my %options = ( ); # Default is now to first use the native mechanism, so Perl programs -# behave like other normal C programs, then try other mechanisms. -my @connectMethods = qw(native tcp udp unix stream console); +# behave like other normal Unix programs, then try other mechanisms. +my @connectMethods = qw(native tcp udp unix pipe stream console); if ($^O =~ /^(freebsd|linux)$/) { @connectMethods = grep { $_ ne 'udp' } @connectMethods; } @@ -212,6 +212,20 @@ sub setlogsock { return undef; } + } elsif (lc $setsock eq 'pipe') { + for my $path ($syslog_path, &_PATH_LOG, "/dev/log") { + next unless defined $path and length $path and -w $path; + $syslog_path = $path; + last + } + + if (not $syslog_path) { + warnings::warnif "pipe passed to setlogsock, but path not available"; + return undef + } + + @connectMethods = qw(pipe); + } elsif (lc $setsock eq 'native') { @connectMethods = qw(native); @@ -219,7 +233,8 @@ sub setlogsock { if (eval "use Win32::EventLog; 1") { @connectMethods = qw(eventlog); } else { - warnings::warnif "eventlog passed to setlogsock, but operating system isn't Win32-compatible" + warnings::warnif "eventlog passed to setlogsock, but operating system isn't Win32-compatible"; + return undef; } } elsif (lc $setsock eq 'tcp') { @@ -245,7 +260,8 @@ sub setlogsock { @connectMethods = qw(console); } else { - croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'native', 'eventlog', 'tcp', 'udp' or 'inet'" + croak "Invalid argument passed to setlogsock; must be 'stream', 'pipe', ", + "'unix', 'native', 'eventlog', 'tcp', 'udp' or 'inet'" } return 1; @@ -309,7 +325,10 @@ sub syslog { $mask .= "\n" unless $mask =~ /\n$/; $message = @_ ? sprintf($mask, @_) : $mask; - if($current_proto eq 'native') { + # See CPAN-RT#24431. Opened on Apple Radar as bug #4944407 on 2007.01.21 + chomp $message if $^O =~ /darwin/; + + if ($current_proto eq 'native') { $buf = $message; } @@ -405,6 +424,11 @@ sub _syslog_send_stream { return syswrite(SYSLOG, $buf, length($buf)); } +sub _syslog_send_pipe { + my ($buf) = @_; + return print SYSLOG $buf; +} + sub _syslog_send_socket { my ($buf) = @_; return syswrite(SYSLOG, $buf, length($buf)); @@ -504,7 +528,10 @@ sub connect_tcp { } setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1); - setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1); + if (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; @@ -581,6 +608,26 @@ sub connect_stream { return 1; } +sub connect_pipe { + my ($errs) = @_; + + $syslog_path ||= &_PATH_LOG || "/dev/log"; + + if (not -w $syslog_path) { + push @$errs, "$syslog_path is not writable"; + return 0; + } + + if (not open(SYSLOG, ">$syslog_path")) { + push @$errs, "can't write to $syslog_path: $!"; + return 0; + } + + $syslog_send = \&_syslog_send_pipe; + + return 1; +} + sub connect_unix { my ($errs) = @_; @@ -705,7 +752,7 @@ Sys::Syslog - Perl interface to the UNIX syslog(3) calls =head1 VERSION -Version 0.20 +Version 0.21 =head1 SYNOPSIS @@ -907,6 +954,11 @@ C<"native"> - use the native C functions from your C library =item * +C<"eventlog"> - send messages to the Win32 events logger (Win32 only; +added in C 0.19). + +=item * + C<"tcp"> - connect to a TCP socket, on the C or C service. @@ -934,13 +986,15 @@ For example Solaris and IRIX system may prefer C<"stream"> instead of C<"unix">. =item * -C<"console"> - send messages directly to the console, as for the C<"cons"> -option of C. +C<"pipe"> - connect to the named pipe indicated by the pathname provided as +the optional second parameter, or, if omitted, to the value returned by +the C<_PATH_LOG> macro (if your system defines it), or F +(added in C 0.21). =item * -C<"eventlog"> - send messages to the Win32 events logger (Win32 only; -added in C 0.19). +C<"console"> - send messages directly to the console, as for the C<"cons"> +option of C. =back @@ -949,6 +1003,8 @@ 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, C, C, C, C, C. +Under Win32 systems, C will be added as the first mechanism to try +if C is available. Giving an invalid value for C<$sock_type> will C. @@ -1268,7 +1324,7 @@ IRIX 6.4 documentation on syslog, L AIX 5L 5.3 documentation on syslog, -L +L HP-UX 11i documentation on syslog, L @@ -1430,4 +1486,17 @@ of a bug in Sys::Syslog back then? - L + +Links +----- +II12021: SYSLOGD HOWTO TCPIPINFO (z/OS, OS/390, MVS) +- L + +Getting the most out of the Event Viewer +- L + +Log events to the Windows NT Event Log with JNI +- L + =end comment + diff --git a/ext/Sys/Syslog/Syslog.xs b/ext/Sys/Syslog/Syslog.xs index 7d72c64..c9d63d5 100644 --- a/ext/Sys/Syslog/Syslog.xs +++ b/ext/Sys/Syslog/Syslog.xs @@ -9,7 +9,7 @@ #define HAVE_SYSLOG 1 #endif -#ifdef I_SYSLOG +#if defined(I_SYSLOG) || PATCHLEVEL < 6 #include #endif diff --git a/ext/Sys/Syslog/t/syslog.t b/ext/Sys/Syslog/t/syslog.t index d8a4f8f..19610f1 100755 --- a/ext/Sys/Syslog/t/syslog.t +++ b/ext/Sys/Syslog/t/syslog.t @@ -111,13 +111,13 @@ SKIP: { } -BEGIN { $tests += 20 * 7 } +BEGIN { $tests += 20 * 8 } # try to open a syslog using all the available connection methods my @passed = (); -for my $sock_type (qw(native eventlog unix stream inet tcp udp)) { +for my $sock_type (qw(native eventlog unix pipe stream inet tcp udp)) { SKIP: { - skip "the 'unix' mechanism works, so the tests will likely fail with the 'stream' mechanism", 20 - if $sock_type eq 'stream' and grep {/unix/} @passed; + skip "the 'stream' mechanism because a previous mechanism with similar interface succeeded", 20 + if $sock_type eq 'stream' and grep {/pipe|unix/} @passed; # setlogsock() called with an arrayref $r = eval { setlogsock([$sock_type]) } || 0;