Update Sys-Syslog to CPAN version 0.34
[perl.git] / cpan / Sys-Syslog / Syslog.pm
index 25164af..0cfc749 100644 (file)
@@ -3,15 +3,19 @@ use strict;
 use warnings;
 use warnings::register;
 use Carp;
-use Exporter        qw< import >;
+use Config;
+use Exporter        ();
 use File::Basename;
 use POSIX           qw< strftime setlocale LC_TIME >;
 use Socket          qw< :all >;
 require 5.005;
 
 
+*import = \&Exporter::import;
+
+
 {   no strict 'vars';
-    $VERSION = '0.33';
+    $VERSION = '0.34';
 
     %EXPORT_TAGS = (
         standard => [qw(openlog syslog closelog setlogmask)],
@@ -71,6 +75,29 @@ require 5.005;
 }
 
 
+#
+# Constants
+#
+use constant HAVE_GETPROTOBYNAME     => $Config::Config{d_getpbyname};
+use constant HAVE_GETPROTOBYNUMBER   => $Config::Config{d_getpbynumber};
+use constant HAVE_SETLOCALE          => $Config::Config{d_setlocale};
+use constant HAVE_IPPROTO_TCP        => defined &Socket::IPPROTO_TCP ? 1 : 0;
+use constant HAVE_IPPROTO_UDP        => defined &Socket::IPPROTO_UDP ? 1 : 0;
+use constant HAVE_TCP_NODELAY        => defined &Socket::TCP_NODELAY ? 1 : 0;
+
+use constant SOCKET_IPPROTO_TCP =>
+      HAVE_IPPROTO_TCP      ? Socket::IPPROTO_TCP
+    : HAVE_GETPROTOBYNAME   ? scalar getprotobyname("tcp")
+    : 6;
+
+use constant SOCKET_IPPROTO_UDP =>
+      HAVE_IPPROTO_UDP      ? Socket::IPPROTO_UDP
+    : HAVE_GETPROTOBYNAME   ? scalar getprotobyname("udp")
+    : 17;
+
+use constant SOCKET_TCP_NODELAY => HAVE_TCP_NODELAY ? Socket::TCP_NODELAY : 1;
+
+
 # 
 # Public variables
 # 
@@ -241,7 +268,9 @@ my %mechanism = (
         check   => sub {
             return 1 if defined $sock_port;
 
-            if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
+            if (eval { local $SIG{__DIE__};
+                getservbyname('syslog','tcp') || getservbyname('syslogng','tcp')
+            }) {
                 $host = $syslog_path;
                 return 1
             }
@@ -255,7 +284,7 @@ my %mechanism = (
         check   => sub {
             return 1 if defined $sock_port;
 
-            if (getservbyname('syslog', 'udp')) {
+            if (eval { local $SIG{__DIE__}; getservbyname('syslog', 'udp') }) {
                 $host = $syslog_path;
                 return 1
             }
@@ -366,6 +395,7 @@ sub syslog {
     if ($priority =~ /^\d+$/) {
         $numpri = LOG_PRI($priority);
         $numfac = LOG_FAC($priority) << 3;
+        undef $numfac if $numfac == 0;  # no facility given => use default
     }
     elsif ($priority =~ /^\w+/) {
         # Allow "level" or "level|facility".
@@ -419,7 +449,8 @@ sub syslog {
         $mask =~ s/(?<!%)((?:%%)*)%m/$1$error/g;
     }
 
-    $mask .= "\n" unless $mask =~ /\n$/;
+    # add (or not) a newline
+    $mask .= "\n" if !$options{noeol} and rindex($mask, "\n") == -1;
     $message = @args ? sprintf($mask, @args) : $mask;
 
     if ($current_proto eq 'native') {
@@ -433,17 +464,27 @@ sub syslog {
         $whoami .= "[$$]" if $options{pid};
 
         $sum = $numpri + $numfac;
-        my $oldlocale = setlocale(LC_TIME);
-        setlocale(LC_TIME, 'C');
-        my $timestamp = strftime "%b %d %H:%M:%S", localtime;
-        setlocale(LC_TIME, $oldlocale);
+
+        my $oldlocale;
+        if (HAVE_SETLOCALE) {
+            $oldlocale = setlocale(LC_TIME);
+            setlocale(LC_TIME, 'C');
+        }
+
+        # %e format isn't available on all systems (Win32, cf. CPAN RT #69310)
+        my $day = strftime "%e", localtime;
+
+        if (index($day, "%") == 0) {
+            $day = strftime "%d", localtime;
+            $day =~ s/^0/ /;
+        }
+
+        my $timestamp = strftime "%b $day %H:%M:%S", localtime;
+        setlocale(LC_TIME, $oldlocale) if HAVE_SETLOCALE;
 
         # construct the stream that will be transmitted
         $buf = "<$sum>$timestamp $whoami: $message";
 
-        # add (or not) a newline
-        $buf .= "\n" if !$options{noeol} and rindex($buf, "\n") == -1;
-
         # add (or not) a NUL character
         $buf .= "\0" if !$options{nonul};
     }
@@ -453,7 +494,8 @@ sub syslog {
     if ($options{perror} and $current_proto ne 'native') {
         my $whoami = $ident;
         $whoami .= "[$$]" if $options{pid};
-        print STDERR "$whoami: $message\n";
+        print STDERR "$whoami: $message";
+        print STDERR "\n" if rindex($message, "\n") == -1;
     }
 
     # it's possible that we'll get an error from sending
@@ -622,14 +664,9 @@ sub connect_log {
 sub connect_tcp {
     my ($errs) = @_;
 
-    my $proto = getprotobyname('tcp');
-    if (!defined $proto) {
-       push @$errs, "getprotobyname failed for tcp";
-       return 0;
-    }
-
-    my $port = $sock_port || getservbyname('syslog', 'tcp');
-    $port = getservbyname('syslogng', 'tcp') unless defined $port;
+    my $port = $sock_port
+            || eval { local $SIG{__DIE__}; getservbyname('syslog',   'tcp') }
+            || eval { local $SIG{__DIE__}; getservbyname('syslogng', 'tcp') };
     if (!defined $port) {
        push @$errs, "getservbyname failed for syslog/tcp and syslogng/tcp";
        return 0;
@@ -647,16 +684,14 @@ sub connect_tcp {
     }
     $addr = sockaddr_in($port, $addr);
 
-    if (!socket(SYSLOG, AF_INET, SOCK_STREAM, $proto)) {
+    if (!socket(SYSLOG, AF_INET, SOCK_STREAM, SOCKET_IPPROTO_TCP)) {
        push @$errs, "tcp socket: $!";
        return 0;
     }
 
     setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
-    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);
-    }
+    setsockopt(SYSLOG, SOCKET_IPPROTO_TCP, SOCKET_TCP_NODELAY, 1);
+
     if (!connect(SYSLOG, $addr)) {
        push @$errs, "tcp connect: $!";
        return 0;
@@ -670,13 +705,8 @@ sub connect_tcp {
 sub connect_udp {
     my ($errs) = @_;
 
-    my $proto = getprotobyname('udp');
-    if (!defined $proto) {
-       push @$errs, "getprotobyname failed for udp";
-       return 0;
-    }
-
-    my $port = $sock_port || getservbyname('syslog', 'udp');
+    my $port = $sock_port
+            || eval { local $SIG{__DIE__}; getservbyname('syslog', 'udp') };
     if (!defined $port) {
        push @$errs, "getservbyname failed for syslog/udp";
        return 0;
@@ -694,7 +724,7 @@ sub connect_udp {
     }
     $addr = sockaddr_in($port, $addr);
 
-    if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, $proto)) {
+    if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, SOCKET_IPPROTO_UDP)) {
        push @$errs, "udp socket: $!";
        return 0;
     }
@@ -904,7 +934,7 @@ Sys::Syslog - Perl interface to the UNIX syslog(3) calls
 
 =head1 VERSION
 
-This is the documentation of version 0.33
+This is the documentation of version 0.34
 
 =head1 SYNOPSIS
 
@@ -1665,34 +1695,37 @@ You can find documentation for this module with the perldoc command.
 
 You can also look for information at:
 
-=over 4
-
-=item * AnnoCPAN: Annotated CPAN documentation
-
-L<http://annocpan.org/dist/Sys-Syslog>
+=over
 
-=item * CPAN Ratings
+=item * Perl Documentation
 
-L<http://cpanratings.perl.org/d/Sys-Syslog>
+L<http://perldoc.perl.org/Sys/Syslog.html>
 
-=item * RT: CPAN's request tracker
+=item * MetaCPAN
 
-L<http://rt.cpan.org/Dist/Display.html?Queue=Sys-Syslog>
+L<https://metacpan.org/module/Sys::Syslog>
 
 =item * Search CPAN
 
 L<http://search.cpan.org/dist/Sys-Syslog/>
 
-=item * MetaCPAN
+=item * AnnoCPAN: Annotated CPAN documentation
 
-L<https://metacpan.org/module/Sys::Syslog>
+L<http://annocpan.org/dist/Sys-Syslog>
 
-=item * Perl Documentation
+=item * CPAN Ratings
 
-L<http://perldoc.perl.org/Sys/Syslog.html>
+L<http://cpanratings.perl.org/d/Sys-Syslog>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/Dist/Display.html?Queue=Sys-Syslog>
 
 =back
 
+The source code is available on Git Hub:
+L<https://github.com/maddingue/Sys-Syslog/>
+
 
 =head1 COPYRIGHT