From: Steve Peters Date: Fri, 26 May 2006 14:45:01 +0000 (+0000) Subject: Upgrade to Sys-Syslog-0.14 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6e4ef77763b5ee73f945f0e8dfaf84b3a0a7402b;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Sys-Syslog-0.14 p4raw-id: //depot/perl@28312 --- diff --git a/ext/Sys/Syslog/Changes b/ext/Sys/Syslog/Changes index 0a0e15e..3d5954c 100644 --- a/ext/Sys/Syslog/Changes +++ b/ext/Sys/Syslog/Changes @@ -1,6 +1,19 @@ Revision history for Sys-Syslog -0.13 2006.01.11 +0.14 -- 2006.05.25 -- Sebastien Aperghis-Tramoni (SAPER) + [BUGFIX] RT#19259, RT#17518: Now allowing all levels and facilities. + [CODE] Removed useless "&". + [CODE] Improved readability by adding empty lines and reworking the + code here and there. + [CODE] Added new macros from Mac OS X. + [TESTS] Added more tests in order to increase coverage. + [DOC] RT#19085: Corrected errors in the documentation for setlogmask(). + [DOC] Added several links to online manual pages, RFCs and articles. + [DOC] Corrected minor things in Changes. + +0.13 -- 2006.01.11 -- Sebastien Aperghis-Tramoni (SAPER) + [CODE] Applied Gisle Aas patch for a better handling of error messages, + then optimized it. [CODE] Merged blead@26768: If getservbyname fails tell what service the lookup attempt tried to use. [CODE] Merged blead@26769: suppress Sys::Hostname usage and directly @@ -9,37 +22,35 @@ Revision history for Sys-Syslog [CODE] Merged blead@26773: check that $syslog_path is a socket. [TESTS] RT#16980 (Alan Burlison): Sys::Syslog blows up rather spectacularly on Solaris. Corrected by previous patches. - [TESTS] Applied Gisle Aas patch for a better handling of error messages, - then optimized it. [TESTS] RT#16974: Failed test in t/podspell. This test is now skipped. -0.12 2006.01.07 - [CODE] Merged some modifications from bleadperl. +0.12 -- 2006.01.07 -- Sebastien Aperghis-Tramoni (SAPER) [DOC] Added a link to an article about Sys::Syslog. + [TESTS] Merged some modifications from bleadperl. [TESTS] Removed optional dependency on Test::Exception. [TESTS] Improved t/constant.t [TESTS] Rewrote t/constants.t because future versions of ExtUtils::Constant will prevent the constant() function from being directly called. -0.11 2005.12.28 +0.11 -- 2005.12.28 -- Sebastien Aperghis-Tramoni (SAPER) [BUGFIX] setlogmask() now behaves like its C counterpart. - [CODE] Can now export and use the macros. - [CODE] Support for three Exporter tags. - [CODE] XSLoader is now optional. + [FEATURE] Can now export and use the macros. + [FEATURE] Support for three Exporter tags. + [FEATURE] XSLoader is now optional. [CODE] No longer "use"s Sys::Hostname as it was "require"d where needed. [CODE] RT#16604: Use local timestamp. - [DIST] Merged change from blead@26343 + [DIST] Merged blead@26343: Fix realclean target. [DOC] Improved documentation. [TESTS] Added more tests to t/syslog.t in order to increase code coverage. -0.10 2005.12.08 +0.10 -- 2005.12.08 -- Sebastien Aperghis-Tramoni (SAPER) [DOC] Improved documentation. [TESTS] Added -T to t/syslog.t [TESTS] Added t/constants.t to check the macros. [TESTS] Added t/distchk.t, t/podspell.t, t/podcover.t, t/portfs.t -0.09 2005.12.06 +0.09 -- 2005.12.06 -- Sebastien Aperghis-Tramoni (SAPER) [CODE] Now setlogsock() really croak(), as documented. [DIST] CPANized from blead@26281. [DIST] Modified Makefile.PL so that ExtUtils::Constant is conditionaly diff --git a/ext/Sys/Syslog/Makefile.PL b/ext/Sys/Syslog/Makefile.PL index 2fa924c..966b011 100644 --- a/ext/Sys/Syslog/Makefile.PL +++ b/ext/Sys/Syslog/Makefile.PL @@ -1,9 +1,11 @@ +use strict; use ExtUtils::MakeMaker; eval 'use ExtUtils::MakeMaker::Coverage'; require 5.006; WriteMakefile( NAME => 'Sys::Syslog', + LICENSE => 'perl', VERSION_FROM => 'Syslog.pm', ABSTRACT_FROM => 'Syslog.pm', INSTALLDIRS => 'perl', @@ -11,7 +13,7 @@ WriteMakefile( XSPROTOARG => '-noprototypes', PREREQ_PM => { 'Test::More' => 0, - 'XSLoader' => 0, + 'XSLoader' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Sys-Syslog-*' }, @@ -20,10 +22,10 @@ WriteMakefile( my $_PATH_LOG; -if (-S "/dev/log" && -w "/dev/log") { +if (-S "/dev/log" and -w "/dev/log") { # Most unixes have a unix domain socket /dev/log. $_PATH_LOG = "/dev/log"; -} elsif (-c "/dev/conslog" && -w "/dev/conslog") { +} elsif (-c "/dev/conslog" and -w "/dev/conslog") { # SunOS 5.8 has a worldwritable /dev/conslog STREAMS log driver. # The /dev/log STREAMS log driver on this platform has permissions # and ownership `crw-r----- root sys'. /dev/conslog has more liberal @@ -55,10 +57,10 @@ if(eval {require ExtUtils::Constant; 1}) { close(MACROS); } else { - use File::Copy; - use File::Spec; + require File::Copy; + require File::Spec; foreach my $file ('const-c.inc', 'const-xs.inc') { my $fallback = File::Spec->catfile('fallback', $file); - copy ($fallback, $file) or die "Can't copy $fallback to $ $!"; + File::Copy::copy($fallback, $file) or die "Can't copy $fallback to $ $!"; } } diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index 40b158e..2c3e6a5 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -1,10 +1,12 @@ package Sys::Syslog; use strict; use Carp; +use POSIX qw(strftime setlocale LC_TIME); +use Socket ':all'; require 5.006; require Exporter; -our $VERSION = '0.13'; +our $VERSION = '0.14'; our @ISA = qw(Exporter); our %EXPORT_TAGS = ( @@ -18,6 +20,7 @@ our %EXPORT_TAGS = ( LOG_MAIL LOG_NDELAY LOG_NEWS LOG_NFACILITIES LOG_NOTICE LOG_NOWAIT LOG_ODELAY LOG_PERROR LOG_PID LOG_PRIMASK LOG_SYSLOG LOG_USER LOG_UUCP LOG_WARNING + LOG_MASK LOG_UPTO )], ); @@ -44,8 +47,6 @@ my $failed = undef; my $fail_time = undef; our ($connected, @fallbackMethods, $syslog_send, $host); -use Socket ':all'; -use POSIX qw(strftime setlocale LC_TIME); =head1 NAME @@ -53,7 +54,7 @@ Sys::Syslog - Perl interface to the UNIX syslog(3) calls =head1 VERSION -Version 0.13 +Version 0.14 =head1 SYNOPSIS @@ -96,7 +97,8 @@ C<:extended> exports the Perl specific functions for C: =item * C<:macros> exports the symbols corresponding to most of your C -macros. See L<"CONSTANTS"> for the supported constants and their meaning. +macros and the C and C functions. +See L<"CONSTANTS"> for the supported constants and their meaning. =back @@ -199,16 +201,26 @@ might show up if $message contains tainted data. Sets the log mask for the current process to C<$mask_priority> and returns the old mask. If the mask argument is 0, the current log mask is not modified. See L<"Levels"> for the list of available levels. +You can use the C function to allow all levels up to a +given priority (but it only accept the numeric macros as arguments). B Only log errors: - setlogmask(LOG_ERR); + setlogmask( LOG_MASK(LOG_ERR) ); + +Log everything except informational messages: + + setlogmask( ~(LOG_MASK(LOG_INFO)) ); Log critical messages, errors and warnings: - setlogmask(LOG_CRIT|LOG_ERR|LOG_WARNING); + setlogmask( LOG_MASK(LOG_CRIT) | LOG_MASK(LOG_ERR) | LOG_MASK(LOG_WARNING) ); + +Log all messages up to debug: + + setlogmask( LOG_UPTO(LOG_DEBUG) ); =item B @@ -226,8 +238,8 @@ whatever is writable. A value of 'stream' will connect to the stream indicated by the pathname provided as the optional second parameter. (For example Solaris and IRIX require C<"stream"> instead of C<"unix">.) A value of C<"inet"> will connect to an INET socket (either C or C, -tried in that order) returned by C. C<"tcp"> and C<"udp"> can -also be given as values. The value C<"console"> will send messages +tried in that order) returned by C. C<"tcp"> and C<"udp"> +can also be given as values. The value C<"console"> will send messages directly to the console, as for the C<"cons"> option in the logopts in C. @@ -262,9 +274,10 @@ Closes the log file and return true on success. setlogsock('inet'); $! = 55; - syslog('info', 'problem was %m'); # %m == $! in syslog(3) + syslog('info', 'problem was %m'); # %m == $! in syslog(3) + +Log to UDP port on C<$remotehost> instead of logging locally: - # Log to UDP port on $remotehost instead of logging locally setlogsock('udp'); $Sys::Syslog::host = $remotehost; openlog($program, 'ndelay', 'user'); @@ -404,8 +417,7 @@ B<(F)> You forgot to give C the indicated argument. =item syslog: invalid level/facility: %s -B<(F)> You specified an invalid level or facility, like C -(which is reserved to the kernel). +B<(F)> You specified an invalid level or facility. =item syslog: too many levels given: %s @@ -436,10 +448,37 @@ was unable to find an appropriate an appropriate device. L +SUSv3 issue 6, IEEE Std 1003.1, 2004 edition, +L + +GNU C Library documentation on syslog, +L + +Solaris 10 documentation on syslog, +L + +AIX 5L 5.3 documentation on syslog, +L + +HP-UX 11i documentation on syslog, +L + +Tru64 5.1 documentation on syslog, +L + +Stratus VOS 15.1, +L + +I, L +-- Please note that this is an informational RFC, and therefore does not +specify a standard of any kind. + +I, L + I, L -=head1 AUTHOR +=head1 AUTHORS Tom Christiansen EFE and Larry Wall EFE. @@ -493,7 +532,15 @@ L =item * Search CPAN -L +L + +=item * Kobes' CPAN Search + +L + +=item * Perl Documentation + +L =back @@ -511,7 +558,7 @@ sub AUTOLOAD { my $constname; our $AUTOLOAD; ($constname = $AUTOLOAD) =~ s/.*:://; - croak "&Sys::Syslog::constant not defined" if $constname eq 'constant'; + croak "Sys::Syslog::constant() not defined" if $constname eq 'constant'; my ($error, $val) = constant($constname); croak $error if $error; no strict 'refs'; @@ -529,7 +576,7 @@ eval { bootstrap Sys::Syslog $VERSION; }; -our $maskpri = &LOG_UPTO(&LOG_DEBUG); +our $maskpri = LOG_UPTO(&LOG_DEBUG); sub openlog { our ($ident, $logopt, $facility) = @_; # package vars @@ -537,12 +584,12 @@ sub openlog { our $lo_ndelay = $logopt =~ /\bndelay\b/; our $lo_nowait = $logopt =~ /\bnowait\b/; return 1 unless $lo_ndelay; - &connect; + connect_log(); } sub closelog { our $facility = our $ident = ''; - &disconnect; + disconnect_log(); } sub setlogmask { @@ -554,12 +601,14 @@ sub setlogmask { sub setlogsock { my $setsock = shift; $syslog_path = shift; - &disconnect if $connected; + disconnect_log() if $connected; $transmit_ok = 0; @fallbackMethods = (); @connectMethods = @defaultMethods; + if (ref $setsock eq 'ARRAY') { @connectMethods = @$setsock; + } elsif (lc($setsock) eq 'stream') { unless (defined $syslog_path) { my @try = qw(/dev/log /dev/conslog); @@ -581,6 +630,7 @@ sub setlogsock { } else { @connectMethods = ( 'stream' ); } + } elsif (lc($setsock) eq 'unix') { if (length _PATH_LOG() && !defined $syslog_path) { $syslog_path = _PATH_LOG(); @@ -589,6 +639,7 @@ sub setlogsock { carp 'unix passed to setlogsock, but path not available'; return undef; } + } elsif (lc($setsock) eq 'tcp') { if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) { @connectMethods = ( 'tcp' ); @@ -596,6 +647,7 @@ sub setlogsock { carp "tcp passed to setlogsock, but tcp service unavailable"; return undef; } + } elsif (lc($setsock) eq 'udp') { if (getservbyname('syslog', 'udp')) { @connectMethods = ( 'udp' ); @@ -603,13 +655,17 @@ sub setlogsock { carp "udp passed to setlogsock, but udp service unavailable"; return undef; } + } elsif (lc($setsock) eq 'inet') { @connectMethods = ( 'tcp', 'udp' ); + } elsif (lc($setsock) eq 'console') { @connectMethods = ( 'console' ); + } else { croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'" } + return 1; } @@ -627,15 +683,16 @@ sub syslog { @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". undef $numpri; undef $numfac; + foreach (@words) { - $num = &xlate($_); # Translate word to number. - if ($_ eq 'kern' || $num <= 0) { + $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; + return 0 unless LOG_MASK($numpri) & $maskpri; } else { croak "syslog: too many facilities given: $_" if defined($numfac); @@ -648,10 +705,10 @@ sub syslog { if (!defined($numfac)) { # Facility not specified in this call. $facility = 'user' unless $facility; - $numfac = &xlate($facility); + $numfac = xlate($facility); } - &connect unless $connected; + connect_log() unless $connected; $whoami = our $ident; @@ -661,9 +718,7 @@ sub syslog { } unless ($whoami) { - ($whoami = getlogin) || - ($whoami = getpwuid($<)) || - ($whoami = 'syslog'); + $whoami = getlogin() || getpwuid($<) || 'syslog'; } $whoami .= "[$$]" if our $lo_pid; @@ -695,26 +750,29 @@ sub syslog { if ($failed && (time - $fail_time) > 60) { # it's been a while... maybe things have been fixed @fallbackMethods = (); - disconnect(); + disconnect_log(); $transmit_ok = 0; # make it look like a fresh attempt - &connect; + connect_log(); } + if ($connected && !connection_ok()) { # Something was OK, but has now broken. Remember coz we'll # want to go back to what used to be OK. $failed = $current_proto unless $failed; $fail_time = time; - disconnect(); + disconnect_log(); } - &connect unless $connected; + + connect_log() unless $connected; $failed = undef if ($current_proto && $failed && $current_proto eq $failed); + if ($syslog_send) { - if (&{$syslog_send}($buf)) { + if ($syslog_send->($buf)) { $transmit_ok++; return 1; } # typically doesn't happen, since errors are rare from write(). - disconnect(); + disconnect_log(); } } # could not send, could not fallback onto a working @@ -766,6 +824,10 @@ sub _syslog_send_socket { #return send(SYSLOG, $buf, 0); } +# xlate() +# ----- +# private function to translate names to numeric values +# sub xlate { my($name) = @_; return $name+0 if $name =~ /^\s*\d+\s*$/; @@ -777,7 +839,7 @@ sub xlate { defined $value ? $value : -1; } -sub connect { +sub connect_log { @fallbackMethods = @connectMethods unless (scalar @fallbackMethods); if ($transmit_ok && $current_proto) { # Retry what we were on, because it's worked in the past. @@ -836,7 +898,7 @@ sub connect_tcp { } setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1); setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1); - if (!CORE::connect(SYSLOG,$that)) { + if (!connect(SYSLOG,$that)) { push(@{$errs}, "tcp connect: $!"); return 0; } @@ -873,7 +935,7 @@ sub connect_udp { push(@{$errs}, "udp socket: $!"); return 0; } - if (!CORE::connect(SYSLOG,$that)) { + if (!connect(SYSLOG,$that)) { push(@{$errs}, "udp connect: $!"); return 0; } @@ -926,12 +988,12 @@ sub connect_unix { push(@{$errs}, "unix stream socket: $!"); return 0; } - if (!CORE::connect(SYSLOG,$that)) { + if (!connect(SYSLOG,$that)) { if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) { push(@{$errs}, "unix dgram socket: $!"); return 0; } - if (!CORE::connect(SYSLOG,$that)) { + if (!connect(SYSLOG,$that)) { push(@{$errs}, "unix dgram connect: $!"); return 0; } @@ -964,7 +1026,7 @@ sub connection_ok { return ($ret ? 0 : 1); } -sub disconnect { +sub disconnect_log { $connected = 0; $syslog_send = undef; return close SYSLOG; diff --git a/ext/Sys/Syslog/fallback/const-c.inc b/ext/Sys/Syslog/fallback/const-c.inc index b0a08bd..b0bd772 100644 --- a/ext/Sys/Syslog/fallback/const-c.inc +++ b/ext/Sys/Syslog/fallback/const-c.inc @@ -24,7 +24,7 @@ static int constant_7 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - LOG_ERR LOG_FTP LOG_LPR LOG_PID */ + LOG_ERR LOG_FTP LOG_LPR LOG_PID LOG_RAS */ /* Offset 4 gives the best switch position. */ switch (name[4]) { case 'E': @@ -71,6 +71,17 @@ constant_7 (pTHX_ const char *name, IV *iv_return) { #endif } break; + case 'R': + if (memEQ(name, "LOG_RAS", 7)) { + /* ^ */ +#ifdef LOG_RAS + *iv_return = LOG_RAS; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; } return PERL_constant_NOTFOUND; } @@ -253,7 +264,7 @@ constant_9 (pTHX_ const char *name, IV *iv_return, const char **pv_return) { *pv_return = _PATH_LOG; return PERL_constant_ISPV; #else - *pv_return = "/dev/log"; + *pv_return = ""; return PERL_constant_ISPV; #endif } @@ -442,12 +453,12 @@ static int constant_11 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - LOG_FACMASK LOG_PRIMASK LOG_WARNING */ - /* Offset 6 gives the best switch position. */ - switch (name[6]) { - case 'C': + LOG_FACMASK LOG_INSTALL LOG_LAUNCHD LOG_NETINFO LOG_PRIMASK LOG_WARNING */ + /* Offset 4 gives the best switch position. */ + switch (name[4]) { + case 'F': if (memEQ(name, "LOG_FACMASK", 11)) { - /* ^ */ + /* ^ */ #ifdef LOG_FACMASK *iv_return = LOG_FACMASK; return PERL_constant_ISIV; @@ -457,8 +468,41 @@ constant_11 (pTHX_ const char *name, IV *iv_return) { } break; case 'I': + if (memEQ(name, "LOG_INSTALL", 11)) { + /* ^ */ +#ifdef LOG_INSTALL + *iv_return = LOG_INSTALL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "LOG_LAUNCHD", 11)) { + /* ^ */ +#ifdef LOG_LAUNCHD + *iv_return = LOG_LAUNCHD; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'N': + if (memEQ(name, "LOG_NETINFO", 11)) { + /* ^ */ +#ifdef LOG_NETINFO + *iv_return = LOG_NETINFO; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'P': if (memEQ(name, "LOG_PRIMASK", 11)) { - /* ^ */ + /* ^ */ #ifdef LOG_PRIMASK *iv_return = LOG_PRIMASK; return PERL_constant_ISIV; @@ -467,9 +511,9 @@ constant_11 (pTHX_ const char *name, IV *iv_return) { #endif } break; - case 'R': + case 'W': if (memEQ(name, "LOG_WARNING", 11)) { - /* ^ */ + /* ^ */ #ifdef LOG_WARNING *iv_return = LOG_WARNING; return PERL_constant_ISIV; @@ -495,18 +539,19 @@ constant (pTHX_ const char *name, STRLEN len, IV *iv_return, const char **pv_ret Regenerate these constant functions by feeding this entire source file to perl -x -#!/usr/bin/perl5.8.5 -w +#!perl -w use ExtUtils::Constant qw (constant_types C_constant XS_constant); my $types = {map {($_, 1)} qw(IV PV)}; my @names = (qw(LOG_ALERT LOG_AUTH LOG_AUTHPRIV LOG_CONS LOG_CRIT LOG_CRON LOG_DAEMON LOG_DEBUG LOG_EMERG LOG_ERR LOG_FACMASK LOG_FTP - LOG_INFO LOG_KERN LOG_LFMT LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2 - LOG_LOCAL3 LOG_LOCAL4 LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR - LOG_MAIL LOG_NDELAY LOG_NEWS LOG_NFACILITIES LOG_NOTICE - LOG_NOWAIT LOG_ODELAY LOG_PERROR LOG_PID LOG_PRIMASK LOG_SYSLOG + LOG_INFO LOG_INSTALL LOG_KERN LOG_LAUNCHD LOG_LFMT LOG_LOCAL0 + LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4 LOG_LOCAL5 + LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NDELAY LOG_NETINFO + LOG_NEWS LOG_NFACILITIES LOG_NOTICE LOG_NOWAIT LOG_ODELAY + LOG_PERROR LOG_PID LOG_PRIMASK LOG_RAS LOG_REMOTEAUTH LOG_SYSLOG LOG_USER LOG_UUCP LOG_WARNING), - {name=>"_PATH_LOG", type=>"PV", default=>["PV", "\"/dev/log\""]}); + {name=>"_PATH_LOG", type=>"PV", default=>["PV", "\"\""]}); print constant_types(); # macro defs foreach (C_constant ("Sys::Syslog", 'constant', 'IV', $types, undef, 3, @names) ) { @@ -543,6 +588,16 @@ __END__ #endif } break; + case 14: + if (memEQ(name, "LOG_REMOTEAUTH", 14)) { +#ifdef LOG_REMOTEAUTH + *iv_return = LOG_REMOTEAUTH; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; case 15: if (memEQ(name, "LOG_NFACILITIES", 15)) { #ifdef LOG_NFACILITIES diff --git a/ext/Sys/Syslog/t/constants.t b/ext/Sys/Syslog/t/constants.t index d7c7b0c..b5d4ecb 100644 --- a/ext/Sys/Syslog/t/constants.t +++ b/ext/Sys/Syslog/t/constants.t @@ -27,7 +27,7 @@ if(@names) { $name = $1; my $v = eval "${callpack}::$name()"; - if(defined($v) && $v =~ /^\d+$/) { + if(defined $v and $v =~ /^\d+$/) { is( $@, '', "calling the constant $name as a function" ); like( $v, '/^\d+$/', "checking that $name is a number ($v)" ); diff --git a/ext/Sys/Syslog/t/syslog.t b/ext/Sys/Syslog/t/syslog.t index 1886a1e..9d090a2 100755 --- a/ext/Sys/Syslog/t/syslog.t +++ b/ext/Sys/Syslog/t/syslog.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -T +#!/usr/bin/perl -Tw BEGIN { if( $ENV{PERL_CORE} ) { @@ -20,32 +20,50 @@ plan skip_all => "Sys::Syslog was not build" plan skip_all => "Socket was not build" unless $Config{'extensions'} =~ /\bSocket\b/; -BEGIN { - plan tests => 119; +my $tests; +plan tests => $tests; - # ok, now loads them - eval 'use Socket'; - use_ok('Sys::Syslog', ':standard', ':extended', ':macros'); -} +BEGIN { $tests = 1 } +# ok, now loads them +eval 'use Socket'; +use_ok('Sys::Syslog', ':standard', ':extended', ':macros'); +BEGIN { $tests += 1 } # check that the documented functions are correctly provided can_ok( 'Sys::Syslog' => qw(openlog syslog syslog setlogmask setlogsock closelog) ); +BEGIN { $tests += 1 } # check the diagnostics # setlogsock() eval { setlogsock() }; like( $@, qr/^Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'/, "calling setlogsock() with no argument" ); +BEGIN { $tests += 3 } # syslog() eval { syslog() }; like( $@, qr/^syslog: expecting argument \$priority/, "calling syslog() with no argument" ); +eval { syslog(undef) }; +like( $@, qr/^syslog: expecting argument \$priority/, + "calling syslog() with one undef argument" ); + +eval { syslog('') }; +like( $@, qr/^syslog: expecting argument \$format/, + "calling syslog() with one empty argument" ); + +BEGIN { $tests += 1 } +# setlogsock() +eval { setlogsock() }; +like( $@, qr/^Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'/, + "calling setlogsock() with no argument" ); + my $test_string = "uid $< is testing Perl $] syslog(3) capabilities"; my $r = 0; +BEGIN { $tests += 8 } # try to open a syslog using a Unix or stream socket SKIP: { skip "can't connect to Unix socket: _PATH_LOG unavailable", 8 @@ -82,46 +100,69 @@ SKIP: { } } + +BEGIN { $tests += 20 * 6 } # try to open a syslog using all the available connection methods for my $sock_type (qw(stream unix inet tcp udp console)) { SKIP: { - # setlogsock() + # setlogsock() called with an arrayref $r = eval { setlogsock([$sock_type]) } || 0; - skip "can't use '$sock_type' socket", 16 unless $r; + skip "can't use '$sock_type' socket", 20 unless $r; + is( $@, '', "setlogsock() called with ['$sock_type']" ); + ok( $r, "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; is( $@, '', "setlogsock() called with '$sock_type'" ); ok( $r, "setlogsock() should return true: '$r'" ); # openlog() without option NDELAY $r = eval { openlog('perl', '', '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( $@, '', "openlog() called with facility 'local0' and without option 'ndelay'" ); ok( $r, "openlog() should return true: '$r'" ); # openlog() with the option NDELAY $r = eval { openlog('perl', 'ndelay', 'local0') } || 0; - skip "can't connect to syslog", 12 if $@ =~ /^no connection to syslog available/; + skip "can't connect to syslog", 14 if $@ =~ /^no connection to syslog available/; is( $@, '', "openlog() called with facility 'local0' with option 'ndelay'" ); ok( $r, "openlog() should return true: '$r'" ); + # syslog() with negative level, should fail + $r = eval { syslog(-1, "$test_string by connecting to a $sock_type socket") } || 0; + like( $@, '/^syslog: invalid level\/facility: /', "syslog() called with level -1" ); + ok( !$r, "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/', "syslog() called with level 'info,notice'" ); + ok( !$r, "syslog() should return false: '$r'" ); + + # syslog() with facilities "local0" and "local1" (as a strings), should fail + $r = eval { syslog('local0,local1', "$test_string by connecting to a $sock_type socket") } || 0; + like( $@, '/^syslog: too many facilities given: local1/', "syslog() called with level 'info,notice'" ); + ok( !$r, "syslog() should return false: '$r'" ); + # syslog() with level "info" (as a string), should pass - $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket") } || 0; - is( $@, '', "syslog() called with level 'info'" ); + $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket (errno=%m)") } || 0; + is( $@, '', "syslog() called with level 'info' (string)" ); ok( $r, "syslog() should return true: '$r'" ); # syslog() with level "info" (as a macro), should pass - $r = eval { syslog(LOG_INFO, "$test_string by connecting to a $sock_type socket") } || 0; - is( $@, '', "syslog() called with level 'info'" ); + $r = eval { syslog(LOG_INFO(), "$test_string by connecting to a $sock_type socket (errno=%m)") } || 0; + is( $@, '', "syslog() called with level 'info' (macro)" ); ok( $r, "syslog() should return true: '$r'" ); # syslog() with facility "kern" (as a string), should fail - $r = eval { syslog('kern', "$test_string by connecting to a $sock_type socket") } || 0; - like( $@, '/^syslog: invalid level/facility: kern/', "syslog() called with facility 'kern'" ); - ok( !$r, "syslog() should return false: '$r'" ); + #$r = eval { syslog('kern', "$test_string by connecting to a $sock_type socket") } || 0; + #like( $@, '/^syslog: invalid level/facility: kern/', "syslog() called with facility 'kern'" ); + #ok( !$r, "syslog() should return false: '$r'" ); # syslog() with facility "kern" (as a macro), should fail - $r = eval { syslog(LOG_KERN, "$test_string by connecting to a $sock_type socket") } || 0; - like( $@, '/^syslog: invalid level/facility: 0/', "syslog() called with facility 'kern'" ); - ok( !$r, "syslog() should return false: '$r'" ); + #$r = eval { syslog(LOG_KERN, "$test_string by connecting to a $sock_type socket") } || 0; + #like( $@, '/^syslog: invalid level/facility: 0/', "syslog() called with facility 'kern'" ); + #ok( !$r, "syslog() should return false: '$r'" ); SKIP: { skip "skipping closelog() tests for 'console'", 2 if $sock_type eq 'console'; @@ -133,6 +174,41 @@ for my $sock_type (qw(stream unix inet tcp udp console)) { } } + +BEGIN { $tests += 10 } +# setlogsock() with "stream" and an undef path +$r = eval { setlogsock("stream", undef ) } || ''; +is( $@, '', "setlogsock() called, with 'stream' and an undef path" ); +ok( $r, "setlogsock() should return true: '$r'" ); + +# setlogsock() with "stream" and an empty path +$r = eval { setlogsock("stream", '' ) } || ''; +is( $@, '', "setlogsock() called, with 'stream' and an empty path" ); +ok( !$r, "setlogsock() should return false: '$r'" ); + +# setlogsock() with "stream" and /dev/null +$r = eval { setlogsock("stream", '/dev/null' ) } || ''; +is( $@, '', "setlogsock() called, with 'stream' and '/dev/null'" ); +ok( $r, "setlogsock() should return true: '$r'" ); + +# setlogsock() with "stream" and a non-existing file +$r = eval { setlogsock("stream", 'test.log' ) } || ''; +is( $@, '', "setlogsock() called, with 'stream' and 'test.log' (file does not exist)" ); +ok( !$r, "setlogsock() should return false: '$r'" ); + +# setlogsock() with "stream" and a local file +SKIP: { + my $logfile = "test.log"; + open(LOG, ">$logfile") or skip "can't create file '$logfile': $!", 2; + close(LOG); + $r = eval { setlogsock("stream", $logfile ) } || ''; + is( $@, '', "setlogsock() called, with 'stream' and '$logfile' (file exists)" ); + ok( $r, "setlogsock() should return true: '$r'" ); + unlink($logfile); +} + + +BEGIN { $tests += 3 + 4 * 3 } # setlogmask() { my $oldmask = 0; @@ -143,7 +219,13 @@ for my $sock_type (qw(stream unix inet tcp udp console)) { is( $@, '', "setlogmask() called with a null mask (second time)" ); is( $r, $oldmask, "setlogmask() must return the same mask as previous call"); - for my $newmask ( LOG_ERR , LOG_CRIT|LOG_ERR|LOG_WARNING ) { + my @masks = ( + LOG_MASK(LOG_ERR()), + ~LOG_MASK(LOG_INFO()), + LOG_MASK(LOG_CRIT()) | LOG_MASK(LOG_ERR()) | LOG_MASK(LOG_WARNING()), + ); + + for my $newmask (@masks) { $r = eval { setlogmask($newmask) } || 0; is( $@, '', "setlogmask() called with a new mask" ); is( $r, $oldmask, "setlogmask() must return the same mask as previous call");