From: Steve Peters Date: Wed, 28 Dec 2005 13:31:02 +0000 (+0000) Subject: Upgrade to Sys-Syslog-0.11 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=942974c1034df34ca33deb5d386c2329d1af2ba4;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Sys-Syslog-0.11 p4raw-id: //depot/perl@26515 --- diff --git a/ext/Sys/Syslog/Changes b/ext/Sys/Syslog/Changes index 65c6cb4..a2ee1f8 100644 --- a/ext/Sys/Syslog/Changes +++ b/ext/Sys/Syslog/Changes @@ -1,5 +1,16 @@ Revision history for Sys-Syslog +0.11 2005.12.28 + [BUGFIX] setlogmask() now behaves liek its C counterpart. + [CODE] Can now export and use the macros. + [CODE] Support for three Exporter tags. + [CODE] 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 + [DOC] Improved documentation. + [TESTS] Added more tests to t/syslog.t in order to increase code coverage. + 0.10 2005.12.08 [DOC] Improved documentation. [TESTS] Added -T to t/syslog.t diff --git a/ext/Sys/Syslog/README b/ext/Sys/Syslog/README index 4153683..2456652 100644 --- a/ext/Sys/Syslog/README +++ b/ext/Sys/Syslog/README @@ -37,6 +37,7 @@ INSTALLATION - Perl 5.6.1 i386-freebsd (custom build) - Perl 5.8.7 i386-freebsd (custom build) - Perl 5.6.0 darwin (vendor build) + - Perl 5.8.7 cygwin-thread-multi-64int (vendor build) See also the corresponding CPAN Testers page: http://testers.cpan.org/show/Net-Pcap.html diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index bb9b3ed..6bdb3b9 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -4,10 +4,31 @@ use Carp; require 5.006; require Exporter; +our $VERSION = '0.11'; our @ISA = qw(Exporter); -our @EXPORT = qw(openlog closelog setlogmask syslog); -our @EXPORT_OK = qw(setlogsock); -our $VERSION = '0.10'; + +our %EXPORT_TAGS = ( + standard => [qw(openlog syslog closelog setlogmask)], + extended => [qw(setlogsock)], + macros => [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_USER LOG_UUCP LOG_WARNING + )], +); + +our @EXPORT = ( + @{$EXPORT_TAGS{standard}}, +); + +our @EXPORT_OK = ( + @{$EXPORT_TAGS{extended}}, + @{$EXPORT_TAGS{macros}}, +); # it would be nice to try stream/unix first, since that will be # most efficient. However streams are dodgy - see _syslog_send_stream @@ -24,7 +45,7 @@ my $fail_time = undef; our ($connected, @fallbackMethods, $syslog_send, $host); use Socket ':all'; -use Sys::Hostname; +use POSIX qw(strftime setlocale LC_TIME); =head1 NAME @@ -32,12 +53,13 @@ Sys::Syslog - Perl interface to the UNIX syslog(3) calls =head1 VERSION -Version 0.10 +Version 0.11 =head1 SYNOPSIS use Sys::Syslog; # all except setlogsock(), or: use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock() + use Sys::Syslog qw(:standard :macros); # standard functions, plus macros setlogsock $sock_type; openlog $ident, $logopt, $facility; # don't forget this @@ -55,12 +77,30 @@ just like C. =head1 EXPORTS -By default, C exports the following symbols: +C exports the following C tags: + +=over 4 + +=item * + +C<:standard> exports the standard C functions: openlog closelog setlogmask syslog -as well as the symbols corresponding to most of your C macros. -The symbol C can be exported on demand. +=item * + +C<:extended> exports the Perl specific functions for C: + + setlogsock + +=item * + +C<:macros> exports the symbols corresponding to most of your C +macros. See L<"CONSTANTS"> for the supported constants and their meaning. + +=back + +By default, C exports the symbols from the C<:standard> tag. =head1 FUNCTIONS @@ -76,36 +116,100 @@ ignored, since the failover mechanism will drop down to the console automatically if all other media fail. C<$facility> specifies the part of the system to report about, for example C or C: see your C documentation for the facilities available in -your system. This function will croak if it can't connect to the syslog -daemon. +your system. Facility can be given as a string or a numeric macro. + +This function will croak if it can't connect to the syslog daemon. Note that C now takes three arguments, just like C. B +B + +=over 4 + +=item * + +C - Open the connection immediately (normally, the connection is +opened when the first message is logged). + +=item * + +C - Don't wait for child processes that may have been created +while logging the message. (The GNU C library does not create a child +process, so this option has no effect on Linux.) + +=item * + +C - Include PID with each message. + +=back + +B + +Open the syslog with options C and C, and with facility C: + + openlog($name, "ndelay,pid", "local0"); + +Same thing, but this time using the macro corresponding to C: + + openlog($name, "ndelay,pid", LOG_LOCAL0); + + =item B =item B If C<$priority> permits, logs C<$message> or C -with the addition that C<%m> in $message or $format is replaced with -C<"$!"> (the latest error message). +with the addition that C<%m> in $message or C<$format> is replaced with +C<"$!"> (the latest error message). -If you didn't use C before using C, syslog will +C<$priority> can specify a level, or a level and a facility. Levels and +facilities can be given as strings or as macros. + +If you didn't use C before using C, C will try to guess the C<$ident> by extracting the shortest prefix of C<$format> that ends in a C<":">. -Note that C version v0.07 and older passed the C<$message> -as the formatting string to C even when no formatting arguments -were provided. If the code calling C might execute with older -versions of this module, make sure to call the function as +B + + syslog("info", $message); # informational level + syslog(LOG_INFO, $message); # informational level + + syslog("info|local0", $message); # information level, Local0 facility + syslog(LOG_INFO|LOG_LOCAL0, $message); # information level, Local0 facility + +=over 4 + +=item B + +C version v0.07 and older passed the C<$message> as the +formatting string to C even when no formatting arguments +were provided. If the code calling C might execute with +older versions of this module, make sure to call the function as C instead of C. This protects against hostile formatting sequences that might show up if $message contains tainted data. +=back + + =item B -Sets log mask C<$mask_priority> and returns the old mask. +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. + +B + +Only log errors: + + setlogmask(LOG_ERR); + +Log critical messages, errors and warnings: + + setlogmask(LOG_CRIT|LOG_ERR|LOG_WARNING); + =item B @@ -135,9 +239,10 @@ The default is to try C, C, C, C, C. Giving an invalid value for C<$sock_type> will croak. + =item B -Closes the log file. +Closes the log file and return true on success. =back @@ -245,7 +350,7 @@ C - critical conditions =item * -C<-LOG_ERR> - error conditions +C - error conditions =item * @@ -280,17 +385,17 @@ B<(F)> C failed to connect to the specified socket. =item stream passed to setlogsock, but %s is not writable -B<(F)> You asked C to use a stream socket, but the given +B<(W)> You asked C to use a stream socket, but the given path is not writable. =item stream passed to setlogsock, but could not find any device -B<(F)> You asked C to use a stream socket, but didn't +B<(W)> You asked C to use a stream socket, but didn't provide a path, and C was unable to find an appropriate one. =item tcp passed to setlogsock, but tcp service unavailable -B<(F)> You asked C to use a TCP socket, but the service +B<(W)> You asked C to use a TCP socket, but the service is not available on the system. =item syslog: expecting argument %s @@ -316,12 +421,12 @@ B<(F)> You forgot to specify a level. =item udp passed to setlogsock, but udp service unavailable -B<(F)> You asked C to use a UDP socket, but the service +B<(W)> You asked C to use a UDP socket, but the service is not available on the system. =item unix passed to setlogsock, but path not available -B<(F)> You asked C to use a UNIX socket, but C +B<(W)> You asked C to use a UNIX socket, but C was unable to find an appropriate an appropriate device. =back @@ -401,22 +506,26 @@ under the same terms as Perl itself. sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. - my $constname; our $AUTOLOAD; ($constname = $AUTOLOAD) =~ s/.*:://; croak "&Sys::Syslog::constant not defined" if $constname eq 'constant'; my ($error, $val) = constant($constname); - if ($error) { - croak $error; - } + croak $error if $error; no strict 'refs'; *$AUTOLOAD = sub { $val }; goto &$AUTOLOAD; } -require XSLoader; -XSLoader::load('Sys::Syslog', $VERSION); +eval { + require XSLoader; + XSLoader::load('Sys::Syslog', $VERSION); + 1 +} or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap Sys::Syslog $VERSION; +}; our $maskpri = &LOG_UPTO(&LOG_DEBUG); @@ -436,7 +545,7 @@ sub closelog { sub setlogmask { my $oldmask = $maskpri; - $maskpri = shift; + $maskpri = shift unless $_[0] == 0; $oldmask; } @@ -461,11 +570,11 @@ sub setlogsock { last; } } - croak "stream passed to setlogsock, but could not find any device" - unless defined $syslog_path; + carp "stream passed to setlogsock, but could not find any device" + unless defined $syslog_path } unless (-w $syslog_path) { - croak "stream passed to setlogsock, but $syslog_path is not writable"; + carp "stream passed to setlogsock, but $syslog_path is not writable"; return undef; } else { @connectMethods = ( 'stream' ); @@ -475,21 +584,21 @@ sub setlogsock { $syslog_path = _PATH_LOG(); @connectMethods = ( 'unix' ); } else { - croak 'unix passed to setlogsock, but path not available'; + 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' ); } else { - croak "tcp passed to setlogsock, but tcp service unavailable"; + carp "tcp passed to setlogsock, but tcp service unavailable"; return undef; } } elsif (lc($setsock) eq 'udp') { if (getservbyname('syslog', 'udp')) { @connectMethods = ( 'udp' ); } else { - croak "udp passed to setlogsock, but udp service unavailable"; + carp "udp passed to setlogsock, but udp service unavailable"; return undef; } } elsif (lc($setsock) eq 'inet') { @@ -497,7 +606,7 @@ sub setlogsock { } elsif (lc($setsock) eq 'console') { @connectMethods = ( 'console' ); } else { - croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'"; + croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'" } return 1; } @@ -510,16 +619,16 @@ sub syslog { our $facility; local($facility) = $facility; # may need to change temporarily. - croak "syslog: expecting argument \$priority" unless $priority; - croak "syslog: expecting argument \$format" unless $mask; + croak "syslog: expecting argument \$priority" unless defined $priority; + croak "syslog: expecting argument \$format" unless defined $mask; @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". undef $numpri; undef $numfac; foreach (@words) { $num = &xlate($_); # Translate word to number. - if (/^kern$/ || $num < 0) { - croak "syslog: invalid level/facility: $_"; + if ($_ eq 'kern' || $num <= 0) { + croak "syslog: invalid level/facility: $_" } elsif ($num <= &LOG_PRIMASK) { croak "syslog: too many levels given: $_" if defined($numpri); @@ -569,7 +678,11 @@ sub syslog { $message = @_ ? sprintf($mask, @_) : $mask; $sum = $numpri + $numfac; - my $buf = "<$sum>$whoami: $message\0"; + my $oldlocale = setlocale(LC_TIME); + setlocale(LC_TIME, 'C'); + my $timestamp = strftime "%b %e %T", localtime; + setlocale(LC_TIME, $oldlocale); + my $buf = "<$sum>$timestamp $whoami: $message\0"; # it's possible that we'll get an error from sending # (e.g. if method is UDP and there is no UDP listener, @@ -845,9 +958,9 @@ sub connection_ok { } sub disconnect { - close SYSLOG; $connected = 0; $syslog_send = undef; + return close SYSLOG; } 1; diff --git a/ext/Sys/Syslog/t/podspell.t b/ext/Sys/Syslog/t/podspell.t index 2120d41..25828a4 100644 --- a/ext/Sys/Syslog/t/podspell.t +++ b/ext/Sys/Syslog/t/podspell.t @@ -53,3 +53,4 @@ Failover logopts pathname syslogd +logmask diff --git a/ext/Sys/Syslog/t/syslog.t b/ext/Sys/Syslog/t/syslog.t index 4f9ef8e..1886a1e 100755 --- a/ext/Sys/Syslog/t/syslog.t +++ b/ext/Sys/Syslog/t/syslog.t @@ -8,8 +8,9 @@ BEGIN { } use strict; -use Test::More; use Config; +use File::Spec; +use Test::More; # check that the module is at least available plan skip_all => "Sys::Syslog was not build" @@ -20,11 +21,11 @@ plan skip_all => "Socket was not build" unless $Config{'extensions'} =~ /\bSocket\b/; BEGIN { - plan tests => 16; + plan tests => 119; # ok, now loads them eval 'use Socket'; - use_ok('Sys::Syslog', ':DEFAULT', 'setlogsock'); + use_ok('Sys::Syslog', ':standard', ':extended', ':macros'); } # check that the documented functions are correctly provided @@ -45,9 +46,9 @@ like( $@, qr/^syslog: expecting argument \$priority/, my $test_string = "uid $< is testing Perl $] syslog(3) capabilities"; my $r = 0; -# try to test using a Unix socket +# try to open a syslog using a Unix or stream socket SKIP: { - skip "can't connect to Unix socket: _PATH_LOG unavailable", 6 + skip "can't connect to Unix socket: _PATH_LOG unavailable", 8 unless -e Sys::Syslog::_PATH_LOG(); # The only known $^O eq 'svr4' that needs this is NCR MP-RAS, @@ -58,37 +59,97 @@ SKIP: { is( $@, '', "setlogsock() called with '$sock_type'" ); TODO: { local $TODO = "minor bug"; - ok( $r, "setlogsock() should return true but returned '$r'" ); + ok( $r, "setlogsock() should return true: '$r'" ); } + # open syslog with a "local0" facility SKIP: { - $r = eval { openlog('perl', 'ndelay', 'local0') }; - skip "can't connect to syslog", 4 if $@ =~ /^no connection to syslog available/; - is( $@, '', "openlog()" ); - ok( $r, "openlog() should return true but returned '$r'" ); - - $r = eval { syslog('info', "$test_string by connecting to a Unix socket") }; - is( $@, '', "syslog()" ); - ok( $r, "syslog() should return true but returned '$r'" ); + # openlog() + $r = eval { openlog('perl', 'ndelay', 'local0') } || 0; + skip "can't connect to syslog", 6 if $@ =~ /^no connection to syslog available/; + is( $@, '', "openlog() called with facility 'local0'" ); + ok( $r, "openlog() should return true: '$r'" ); + + # syslog() + $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket") } || 0; + is( $@, '', "syslog() called with level 'info'" ); + ok( $r, "syslog() should return true: '$r'" ); + + # closelog() + $r = eval { closelog() } || 0; + is( $@, '', "closelog()" ); + ok( $r, "closelog() should return true: '$r'" ); } } -# try to test using a INET socket -SKIP: { - skip "assuming syslog doesn't accept inet connections", 6 if 1; - - my $sock_type = 'inet'; - - $r = eval { setlogsock('inet') }; - is( $@, '', "setlogsock() called with '$sock_type'" ); - ok( $r, "setlogsock() should return true but returned '$r'" ); - - $r = eval { openlog('perl', 'ndelay', 'local0') }; - is( $@, '', "openlog()" ); - ok( $r, " -> should return true but returned '$r'" ); - - $r = eval { syslog('info', "$test_string by connecting to a INET socket") }; - is( $@, '', "syslog()" ); - ok( $r, " -> should return true but returned '$r'" ); +# try to open a syslog using all the available connection methods +for my $sock_type (qw(stream unix inet tcp udp console)) { + SKIP: { + # setlogsock() + $r = eval { setlogsock([$sock_type]) } || 0; + skip "can't use '$sock_type' socket", 16 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/; + 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/; + is( $@, '', "openlog() called with facility 'local0' with option 'ndelay'" ); + ok( $r, "openlog() should return true: '$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'" ); + 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'" ); + 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'" ); + + # 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'" ); + + SKIP: { + skip "skipping closelog() tests for 'console'", 2 if $sock_type eq 'console'; + # closelog() + $r = eval { closelog() } || 0; + is( $@, '', "closelog()" ); + ok( $r, "closelog() should return true: '$r'" ); + } + } } +# setlogmask() +{ + my $oldmask = 0; + + $oldmask = eval { setlogmask(0) } || 0; + is( $@, '', "setlogmask() called with a null mask" ); + $r = eval { setlogmask(0) } || 0; + 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 ) { + $r = eval { setlogmask($newmask) } || 0; + is( $@, '', "setlogmask() called with a new mask" ); + is( $r, $oldmask, "setlogmask() must return the same mask as previous call"); + $r = eval { setlogmask(0) } || 0; + is( $@, '', "setlogmask() called with a null mask" ); + is( $r, $newmask, "setlogmask() must return the new mask"); + setlogmask($oldmask); + } +}