diff options
7 files changed, 1901 insertions, 440 deletions
diff --git a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Makefile.PL b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Makefile.PL index 0e4bdcd73a..790853ce8a 100644 --- a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Makefile.PL +++ b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Makefile.PL @@ -1,59 +1,196 @@ -# -# CDDL HEADER START -# -# The contents of this file are subject to the terms of the -# Common Development and Distribution License, Version 1.0 only -# (the "License"). You may not use this file except in compliance -# with the License. -# -# You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE -# or http://www.opensolaris.org/os/licensing. -# See the License for the specific language governing permissions -# and limitations under the License. -# -# When distributing Covered Code, include this CDDL HEADER in each -# file and include the License file at usr/src/OPENSOLARIS.LICENSE. -# If applicable, add the following below this CDDL HEADER, with the -# fields enclosed by brackets "[]" replaced with your own identifying -# information: Portions Copyright [yyyy] [name of copyright owner] -# -# CDDL HEADER END -# +use strict; +use Config; use ExtUtils::MakeMaker; -use ExtUtils::Constant 0.11 'WriteConstants'; +eval 'use ExtUtils::MakeMaker::Coverage'; +use File::Copy; +use File::Path; +use File::Spec; +require 5.005; + + +# create a typemap for Perl 5.6 +if ($] < 5.008) { + open(TYPEMAP, ">typemap") or die "fatal: can't write typemap: $!"; + print TYPEMAP "const char *\t\tT_PV\n"; + close(TYPEMAP); +} + +# create a lib/ dir in order to avoid warnings in Test::Distribution +mkdir "lib", 0755; + +# virtual paths given to EU::MM +my %virtual_path = ( 'Syslog.pm' => '$(INST_LIBDIR)/Syslog.pm' ); + +# detect when to use Win32::EvenLog +my (@extra_params, @extra_prereqs); +my $use_eventlog = eval "use Win32::EventLog; 1"; + +if ($use_eventlog) { + print " * Win32::EventLog detected.\n"; + my $name = "PerlLog"; + + push @extra_prereqs, + Win32 => 0, "Win32::TieRegistry" => 0, "Win32::EventLog" => 0; + + $virtual_path{'win32/Win32.pm' } = '$(INST_LIBDIR)/Syslog/Win32.pm'; + $virtual_path{'win32/PerlLog.dll'} = '$(INST_ARCHAUTODIR)/PerlLog.dll'; + + push @extra_params, CCFLAGS => "-Ifallback"; + + # recreate the DLL from its uuencoded form if it's not here + if (! -f File::Spec->catfile("win32", "$name.dll")) { + # read the uuencoded data + open(UU, '<' . File::Spec->catfile("win32", "$name\_dll.uu")) + or die "fatal: Can't read file '$name\_dll.uu': $!"; + my $uudata = do { local $/; <UU> }; + close(UU); + + # write the DLL + open(DLL, '>' . File::Spec->catfile("win32", "$name.dll")) + or die "fatal: Can't write DLL '$name.dll': $!"; + binmode(DLL); + print DLL unpack "u", $uudata; + close(DLL); + } +} +elsif ($^O =~ /Win32/) { + print <<"NOTICE" + *** You're running on a Win32 system, but you lack the Win32::EventLog\a + *** module, part of the libwin32 distribution. Although Sys::Syslog can + *** be used without Win32::EventLog, it won't be very useful except for + *** sending remote syslog messages. If you want to log messages on the + *** local host as well, please install libwin32 then Sys::Syslog again. +NOTICE +} + +# detect when being built in Perl core +if (grep { $_ eq 'PERL_CORE=1' } @ARGV) { + push @extra_params, + MAN3PODS => {}; # Pods will be built by installman. +} +else { + push @extra_params, + DEFINE => '-DUSE_PPPORT_H'; +} + +# on pre-5.6 Perls, add warnings::compat to the prereq modules +push @extra_prereqs, "warnings::compat" => "0.06" if $] < 5.006; WriteMakefile( - NAME => 'Sys::Syslog', - VERSION_FROM => 'Syslog.pm', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', - realclean => {FILES=> 'const-c.inc const-xs.inc'}, + NAME => 'Sys::Syslog', + LICENSE => 'perl', + AUTHOR => 'Sebastien Aperghis-Tramoni <sebastien@aperghis.net>', + VERSION_FROM => 'Syslog.pm', + ABSTRACT_FROM => 'Syslog.pm', + INSTALLDIRS => 'perl', + XSPROTOARG => '-noprototypes', + PM => \%virtual_path, + PREREQ_PM => { + # run prereqs + 'Carp' => 0, + 'Fcntl' => 0, + 'File::Basename' => 0, + 'File::Spec' => 0, + 'POSIX' => 0, + 'Socket' => 0, + 'XSLoader' => 0, + @extra_prereqs, + + # build/test prereqs + 'Test::More' => 0, + }, + PL_FILES => {}, + dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, + clean => { FILES => 'Sys-Syslog-*' }, + realclean => { FILES => 'lib const-c.inc const-xs.inc macros.all ' + .'PerlLog.h typemap *.bak *.bin *.rc win32/PerlLog_dll' }, + @extra_params ); + +# find a default value for _PATH_LOG my $_PATH_LOG; -if (-S "/dev/log" && -w "/dev/log") { - # Most unixes have a unix domain socket /dev/log. - $_PATH_LOG = "/dev/log"; -} elsif (-c "/dev/conslog" && -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 - # permissions. - $_PATH_LOG = "/dev/conslog"; -} else { - $_PATH_LOG = ""; -} - -WriteConstants( - NAME => 'Sys::Syslog', - 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_USER LOG_UUCP LOG_WARNING), - {name=>"_PATH_LOG", type=>"PV", default=>["PV",qq("$_PATH_LOG")]}, - ], -); +if (-c "/dev/conslog" and -w _) { + # 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 + # permissions. + $_PATH_LOG = "/dev/conslog"; +} +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" or -c _) and -w _) { + # Most unixes have a unix domain socket /dev/log. + $_PATH_LOG = "/dev/log"; +} +else { + $_PATH_LOG = ""; +} + + +# if possible, generate the code that handles the constants with +# ExtUtils::Constant, otherwise use cached copy in fallback/ +if(eval {require ExtUtils::Constant; 1}) { + my @levels = qw( + LOG_ALERT LOG_CRIT LOG_DEBUG LOG_EMERG LOG_ERR + LOG_INFO LOG_NOTICE LOG_WARNING + ); + + my @facilities = ( + # standard facilities + qw( + LOG_AUTH LOG_AUTHPRIV LOG_CRON LOG_DAEMON LOG_FTP LOG_KERN + LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4 + LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NEWS + LOG_SYSLOG LOG_USER LOG_UUCP + ), + # Mac OS X specific facilities + { name => "LOG_INSTALL", type => "IV", default => [ "IV", "LOG_USER" ] }, + { name => "LOG_LAUNCHD", type => "IV", default => [ "IV", "LOG_DAEMON"] }, + { name => "LOG_NETINFO", type => "IV", default => [ "IV", "LOG_DAEMON"] }, + { name => "LOG_RAS", type => "IV", default => [ "IV", "LOG_AUTH" ] }, + { name => "LOG_REMOTEAUTH", type => "IV", default => [ "IV", "LOG_AUTH" ] }, + # modern BSD specific facilities + { name => "LOG_CONSOLE", type => "IV", default => [ "IV", "LOG_USER" ] }, + { name => "LOG_NTP", type => "IV", default => [ "IV", "LOG_DAEMON"] }, + { name => "LOG_SECURITY", type => "IV", default => [ "IV", "LOG_AUTH" ] }, + # IRIX specific facilities + { name => "LOG_AUDIT", type => "IV", default => [ "IV", "LOG_AUTH" ] }, + { name => "LOG_LFMT", type => "IV", default => [ "IV", "LOG_USER" ] }, + ); + + my @options = qw( + LOG_CONS LOG_PID LOG_NDELAY LOG_NOWAIT LOG_ODELAY LOG_PERROR + ); + + my @others_macros = ( + qw(LOG_FACMASK), + { name => "_PATH_LOG", type => "PV", default => [ "PV", qq("$_PATH_LOG") ] }, + { name => "LOG_PRIMASK", type => "IV", default => [ "IV", 7] }, + { name => "LOG_NFACILITIES", type => "IV", default => [ "IV", scalar @facilities] }, + ); + + ExtUtils::Constant::WriteConstants( + NAME => 'Sys::Syslog', + NAMES => [ @levels, @facilities, @options, @others_macros ], + ($] > 5.009002 ? (PROXYSUBS => 1) : ()), + ); + + my @names = map { ref $_ ? $_->{name} : $_ } @levels, @facilities, @options; + open(MACROS, '>macros.all') or warn "warning: Can't write 'macros.all': $!\n"; + print MACROS join $/, @names; + close(MACROS); +} +else { + foreach my $file ('const-c.inc', 'const-xs.inc') { + my $fallback = File::Spec->catfile('fallback', $file); + copy($fallback, $file) or die "fatal: Can't copy $fallback to $file: $!"; + } +} diff --git a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Syslog.pm b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Syslog.pm index 244157f755..002e6e4f16 100644 --- a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Syslog.pm +++ b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Syslog.pm @@ -1,318 +1,399 @@ package Sys::Syslog; -require 5.000; -require Exporter; -require DynaLoader; +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; + +{ no strict 'vars'; + $VERSION = '0.27'; + @ISA = qw(Exporter); + + %EXPORT_TAGS = ( + standard => [qw(openlog syslog closelog setlogmask)], + extended => [qw(setlogsock)], + macros => [ + # levels + qw( + LOG_ALERT LOG_CRIT LOG_DEBUG LOG_EMERG LOG_ERR + LOG_INFO LOG_NOTICE LOG_WARNING + ), + + # standard facilities + qw( + LOG_AUTH LOG_AUTHPRIV LOG_CRON LOG_DAEMON LOG_FTP LOG_KERN + LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4 + LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NEWS + LOG_SYSLOG LOG_USER LOG_UUCP + ), + # Mac OS X specific facilities + qw( LOG_INSTALL LOG_LAUNCHD LOG_NETINFO LOG_RAS LOG_REMOTEAUTH ), + # modern BSD specific facilities + qw( LOG_CONSOLE LOG_NTP LOG_SECURITY ), + # IRIX specific facilities + qw( LOG_AUDIT LOG_LFMT ), + + # options + qw( + LOG_CONS LOG_PID LOG_NDELAY LOG_NOWAIT LOG_ODELAY LOG_PERROR + ), + + # others macros + qw( + LOG_FACMASK LOG_NFACILITIES LOG_PRIMASK + LOG_MASK LOG_UPTO + ), + ], + ); + + @EXPORT = ( + @{$EXPORT_TAGS{standard}}, + ); + + @EXPORT_OK = ( + @{$EXPORT_TAGS{extended}}, + @{$EXPORT_TAGS{macros}}, + ); + + eval { + require XSLoader; + XSLoader::load('Sys::Syslog', $VERSION); + 1 + } or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap Sys::Syslog $VERSION; + }; +} -@ISA = qw(Exporter DynaLoader); -@EXPORT = qw(openlog closelog setlogmask syslog); -@EXPORT_OK = qw(setlogsock); -$VERSION = '0.05'; -# it would be nice to try stream/unix first, since that will be -# most efficient. However streams are dodgy - see _syslog_send_stream -#my @connectMethods = ( 'stream', 'unix', 'tcp', 'udp' ); -my @connectMethods = ( 'tcp', 'udp', 'unix', 'stream', 'console' ); +# +# Public variables +# +use vars qw($host); # host to send syslog messages to (see notes at end) + +# +# Prototypes +# +sub silent_eval (&); + +# +# Global variables +# +use vars qw($facility); +my $connected = 0; # flag to indicate if we're connected or not +my $syslog_send; # coderef of the function used to send messages +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 +my $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask + +my %options = ( + ndelay => 0, + nofatal => 0, + nowait => 0, + perror => 0, + pid => 0, +); + +# Default is now to first use the native mechanism, so Perl programs +# 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; } -my @defaultMethods = @connectMethods; -my $syslog_path = undef; -my $transmit_ok = 0; -my $current_proto = undef; -my $failed = undef; -my $fail_time = undef; - -use Socket; -use Sys::Hostname; - -=head1 NAME - -Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls - -=head1 SYNOPSIS - - use Sys::Syslog; # all except setlogsock, or: - use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock - - setlogsock $sock_type; - openlog $ident, $logopt, $facility; # don't forget this - syslog $priority, $format, @args; - $oldmask = setlogmask $mask_priority; - closelog; - -=head1 DESCRIPTION - -Sys::Syslog is an interface to the UNIX C<syslog(3)> program. -Call C<syslog()> with a string priority and a list of C<printf()> args -just like C<syslog(3)>. - -Syslog provides the functions: - -=over 4 - -=item openlog $ident, $logopt, $facility - -I<$ident> is prepended to every message. I<$logopt> contains zero or -more of the words I<pid>, I<ndelay>, I<nowait>. The cons option is -ignored, since the failover mechanism will drop down to the console -automatically if all other media fail. I<$facility> specifies the -part of the system to report about, for example LOG_USER or LOG_LOCAL0: -see your C<syslog(3)> documentation for the facilities available in -your system. - -B<You should use openlog() before calling syslog().> - -=item syslog $priority, $format, @args - -If I<$priority> permits, logs I<($format, @args)> -printed as by C<printf(3V)>, with the addition that I<%m> -is replaced with C<"$!"> (the latest error message). - -If you didn't use openlog() before using syslog(), syslog will try to -guess the I<$ident> by extracting the shortest prefix of I<$format> -that ends in a ":". - -=item setlogmask $mask_priority - -Sets log mask I<$mask_priority> and returns the old mask. - -=item setlogsock $sock_type [$stream_location] (added in 5.004_02) - -Sets the socket type to be used for the next call to -C<openlog()> or C<syslog()> and returns TRUE on success, -undef on failure. - -A value of 'unix' will connect to the UNIX domain socket (in some -systems a character special device) returned by the C<_PATH_LOG> macro -(if your system defines it), or F</dev/log> or F</dev/conslog>, -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 'stream' instead of 'unix'.) -A value of 'inet' will connect to an INET socket (either tcp or udp, -tried in that order) returned by getservbyname(). 'tcp' and 'udp' can -also be given as values. The value 'console' will send messages -directly to the console, as for the 'cons' option in the logopts in -openlog(). - -A reference to an array can also be passed as the first parameter. -When this calling method is used, the array should contain a list of -sock_types which are attempted in order. - -The default is to try tcp, udp, unix, stream, console. -Giving an invalid value for sock_type will croak. +# And on Win32 systems, we try to use the native mechanism for this +# platform, the events logger, available through Win32::EventLog. +EVENTLOG: { + my $is_Win32 = $^O =~ /Win32/i; -=item closelog - -Closes the log file. - -=back - -Note that C<openlog> now takes three arguments, just like C<openlog(3)>. - -=head1 EXAMPLES - - openlog($program, 'cons,pid', 'user'); - syslog('info', 'this is another test'); - syslog('mail|warning', 'this is a better test: %d', time); - closelog(); - - syslog('debug', 'this is the last test'); - - setlogsock('unix'); - openlog("$program $$", 'ndelay', 'user'); - syslog('notice', 'fooprogram: this is really done'); - - setlogsock('inet'); - $! = 55; - syslog('info', 'problem was %m'); # %m == $! in syslog(3) - -=head1 SEE ALSO - -L<syslog(3)> - -=head1 AUTHOR - -Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall -E<lt>F<larry@wall.org>E<gt>. - -UNIX domain sockets added by Sean Robinson -E<lt>F<robinson_s@sc.maricopa.edu>E<gt> with support from Tim Bunce -E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list. + if (can_load("Sys::Syslog::Win32")) { + unshift @connectMethods, 'eventlog'; + } + elsif ($is_Win32) { + warn $@; + } +} -Dependency on F<syslog.ph> replaced with XS code by Tom Hughes -E<lt>F<tom@compton.nu>E<gt>. +my @defaultMethods = @connectMethods; +my @fallbackMethods = (); -Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>. +# 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/; -Failover to different communication modes by Nick Williams -E<lt>F<Nick.Williams@morganstanley.com>E<gt>. +# coderef for a nicer handling of errors +my $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak; -=cut sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. - + no strict 'vars'; 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); - if ($error) { - croak $error; - } + croak $error if $error; + no strict 'refs'; *$AUTOLOAD = sub { $val }; goto &$AUTOLOAD; } -bootstrap Sys::Syslog $VERSION; - -$maskpri = &LOG_UPTO(&LOG_DEBUG); sub openlog { - ($ident, $logopt, $facility) = @_; # package vars - $lo_pid = $logopt =~ /\bpid\b/; - $lo_ndelay = $logopt =~ /\bndelay\b/; - $lo_nowait = $logopt =~ /\bnowait\b/; - return 1 unless $lo_ndelay; - &connect; + ($ident, my $logopt, $facility) = @_; + + # default values + $ident ||= basename($0) || getlogin() || getpwuid($<) || 'syslog'; + $logopt ||= ''; + $facility ||= LOG_USER(); + + for my $opt (split /\b/, $logopt) { + $options{$opt} = 1 if exists $options{$opt} + } + + $err_sub = delete $options{nofatal} ? \&warnings::warnif : \&croak; + return 1 unless $options{ndelay}; + connect_log(); } sub closelog { $facility = $ident = ''; - &disconnect; + disconnect_log(); } sub setlogmask { - local($oldmask) = $maskpri; - $maskpri = shift; + my $oldmask = $maskpri; + $maskpri = shift unless $_[0] == 0; $oldmask; } sub setlogsock { - local($setsock) = shift; - $syslog_path = shift; - &disconnect if $connected; + my ($setsock, $setpath, $settime) = @_; + + # check arguments + my $diag_invalid_arg + = "Invalid argument passed to setlogsock; must be 'stream', 'pipe', " + . "'unix', 'native', 'eventlog', 'tcp', 'udp' or 'inet'"; + croak $diag_invalid_arg unless defined $setsock; + croak "Invalid number of arguments" unless @_ >= 1 and @_ <= 3; + + $syslog_path = $setpath if defined $setpath; + $sock_timeout = $settime if defined $settime; + + 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) { + + } elsif (lc $setsock eq 'stream') { + if (not defined $syslog_path) { my @try = qw(/dev/log /dev/conslog); - if (length &_PATH_LOG) { # Undefined _PATH_LOG is "". + + if (length &_PATH_LOG) { # Undefined _PATH_LOG is "". unshift @try, &_PATH_LOG; } + for my $try (@try) { if (-w $try) { $syslog_path = $try; last; } } - carp "stream passed to setlogsock, but could not find any device" - unless defined $syslog_path; + + if (not defined $syslog_path) { + warnings::warnif "stream passed to setlogsock, but could not find any device"; + return undef + } } - unless (-w $syslog_path) { - carp "stream passed to setlogsock, but $syslog_path is not writable"; + + if (not -w $syslog_path) { + warnings::warnif "stream passed to setlogsock, but $syslog_path is not writable"; return undef; } else { - @connectMethods = ( 'stream' ); + @connectMethods = qw(stream); } - } elsif (lc($setsock) eq 'unix') { - if (length _PATH_LOG() && !defined $syslog_path) { - $syslog_path = _PATH_LOG(); - @connectMethods = ( 'unix' ); + + } elsif (lc $setsock eq 'unix') { + if (length _PATH_LOG() || (defined $syslog_path && -w $syslog_path)) { + $syslog_path = _PATH_LOG() unless defined $syslog_path; + @connectMethods = qw(unix); } else { - carp 'unix passed to setlogsock, but path not available'; + warnings::warnif 'unix passed to setlogsock, but path not available'; return undef; } - } elsif (lc($setsock) eq 'tcp') { + + } elsif (lc $setsock eq 'pipe') { + for my $path ($syslog_path, &_PATH_LOG, "/dev/log") { + next unless defined $path and length $path and -p $path and -w _; + $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); + + } elsif (lc $setsock eq 'eventlog') { + if (can_load("Win32::EventLog")) { + @connectMethods = qw(eventlog); + } else { + warnings::warnif "eventlog passed to setlogsock, but no Win32 API available"; + $@ = ""; + return undef; + } + + } elsif (lc $setsock eq 'tcp') { if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) { - @connectMethods = ( 'tcp' ); + @connectMethods = qw(tcp); + $host = $syslog_path; } else { - carp "tcp passed to setlogsock, but tcp service unavailable"; + warnings::warnif "tcp passed to setlogsock, but tcp service unavailable"; return undef; } - } elsif (lc($setsock) eq 'udp') { + + } elsif (lc $setsock eq 'udp') { if (getservbyname('syslog', 'udp')) { - @connectMethods = ( 'udp' ); + @connectMethods = qw(udp); + $host = $syslog_path; } else { - carp "udp passed to setlogsock, but udp service unavailable"; + warnings::warnif "udp passed to setlogsock, but udp service unavailable"; return undef; } - } elsif (lc($setsock) eq 'inet') { + + } elsif (lc $setsock eq 'inet') { @connectMethods = ( 'tcp', 'udp' ); - } elsif (lc($setsock) eq 'console') { - @connectMethods = ( 'console' ); + + } elsif (lc $setsock eq 'console') { + @connectMethods = qw(console); + } else { - carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'"; + croak $diag_invalid_arg } + return 1; } sub syslog { - local($priority) = shift; - local($mask) = shift; - local($message, $whoami); - local(@words, $num, $numpri, $numfac, $sum); - local($facility) = $facility; # may need to change temporarily. + my $priority = shift; + my $mask = shift; + my ($message, $buf); + my (@words, $num, $numpri, $numfac, $sum); + my $failed = undef; + my $fail_time = undef; + my $error = $!; + + # if $ident is undefined, it means openlog() wasn't previously called + # so do it now in order to have sensible defaults + openlog() unless $ident; - croak "syslog: expecting argument \$priority" unless $priority; - croak "syslog: expecting argument \$format" unless $mask; + local $facility = $facility; # may need to change temporarily. - @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". + 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 (/^kern$/ || $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; - } - } - croak "syslog: level must be given" unless defined($numpri); + for my $word (@words) { + next if length $word == 0; - if (!defined($numfac)) { # Facility not specified in this call. - $facility = 'user' unless $facility; - $numfac = &xlate($facility); + $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; + } } - &connect unless $connected; + croak "syslog: level must be given" unless defined $numpri; - $whoami = $ident; + if (not defined $numfac) { # Facility not specified in this call. + $facility = 'user' unless $facility; + $numfac = xlate($facility); + } - if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) { - $whoami = $1; - $mask = $2; - } + connect_log() unless $connected; - unless ($whoami) { - ($whoami = getlogin) || - ($whoami = getpwuid($<)) || - ($whoami = 'syslog'); + if ($mask =~ /%m/) { + # escape percent signs for sprintf() + $error =~ s/%/%%/g if @_; + # replace %m with $error, if preceded by an even number of percent signs + $mask =~ s/(?<!%)((?:%%)*)%m/$1$error/g; } - $whoami .= "[$$]" if $lo_pid; - - $mask =~ s/%m/$!/g; $mask .= "\n" unless $mask =~ /\n$/; - $message = sprintf ($mask, @_); + $message = @_ ? sprintf($mask, @_) : $mask; + + # See CPAN-RT#24431. Opened on Apple Radar as bug #4944407 on 2007.01.21 + # Supposedly resolved on Leopard. + chomp $message if $^O =~ /darwin/; + + if ($current_proto eq 'native') { + $buf = $message; + } + elsif ($current_proto eq 'eventlog') { + $buf = $message; + } + else { + my $whoami = $ident; + $whoami .= "[$$]" if $options{pid}; + + $sum = $numpri + $numfac; + my $oldlocale = setlocale(LC_TIME); + setlocale(LC_TIME, 'C'); + my $timestamp = strftime "%b %e %T", localtime; + setlocale(LC_TIME, $oldlocale); + $buf = "<$sum>$timestamp $whoami: $message\0"; + } - $sum = $numpri + $numfac; - my $buf = "<$sum>$whoami: $message\0"; + # handle PERROR option + # "native" mechanism already handles it by itself + if ($options{perror} and $current_proto ne 'native') { + chomp $message; + my $whoami = $ident; + $whoami .= "[$$]" if $options{pid}; + print STDERR "$whoami: $message\n"; + } # it's possible that we'll get an error from sending # (e.g. if method is UDP and there is no UDP listener, @@ -323,26 +404,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, $numpri, $numfac)) { $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 @@ -357,7 +441,8 @@ sub _syslog_send_console { # so we do it in a child process and always return success # to the caller. if (my $pid = fork) { - if ($lo_nowait) { + + if ($options{nowait}) { return 1; } else { if (waitpid($pid, 0) >= 0) { @@ -370,8 +455,8 @@ sub _syslog_send_console { } } else { if (open(CONS, ">/dev/console")) { - my $ret = print CONS $buf . "\r"; - exit ($ret) if defined $pid; + my $ret = print CONS $buf . "\r"; # XXX: should this be \x0A ? + exit $ret if defined $pid; close CONS; } exit if defined $pid; @@ -386,129 +471,186 @@ sub _syslog_send_stream { # To be correct, it should use a STREAMS API, but perl doesn't have one. 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)); #return send(SYSLOG, $buf, 0); } +sub _syslog_send_native { + my ($buf, $numpri) = @_; + syslog_xs($numpri, $buf); + return 1; +} + + +# xlate() +# ----- +# private function to translate names to numeric values +# sub xlate { - local($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 { &$name }; - defined $value ? $value : -1; + + # ExtUtils::Constant 0.20 introduced a new way to implement + # constants, called ProxySubs. When it was used to generate + # the C code, the constant() function no longer returns the + # correct value. Therefore, we first try a direct call to + # constant(), and if the value is an error we try to call the + # constant by its full name. + my $value = constant($name); + + if (index($value, "not a valid") >= 0) { + $name = "Sys::Syslog::$name"; + $value = eval { no strict "refs"; &$name }; + $value = $@ unless defined $value; + } + + $value = -1 if index($value, "not a valid") >= 0; + + return defined $value ? $value : -1; } -sub connect { - @fallbackMethods = @connectMethods unless (scalar @fallbackMethods); + +# connect_log() +# ----------- +# This function acts as a kind of front-end: it tries to connect to +# a syslog service using the selected methods, trying each one in the +# selected order. +# +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. + # Retry what we were on, because it has worked in the past. unshift(@fallbackMethods, $current_proto); } + $connected = 0; my @errs = (); my $proto = undef; - while ($proto = shift(@fallbackMethods)) { + + while ($proto = shift @fallbackMethods) { + no strict 'refs'; my $fn = "connect_$proto"; - $connected = &$fn(\@errs) unless (!defined &$fn); - last if ($connected); + $connected = &$fn(\@errs) if defined &$fn; + last if $connected; } $transmit_ok = 0; if ($connected) { $current_proto = $proto; - local($old) = select(SYSLOG); $| = 1; select($old); + my ($old) = select(SYSLOG); $| = 1; select($old); } else { @fallbackMethods = (); - foreach my $err (@errs) { - carp $err; - } - croak "no connection to syslog available"; + $err_sub->(join "\n\t- ", "no connection to syslog available", @errs); + return undef; } } sub connect_tcp { my ($errs) = @_; - unless ($host) { - require Sys::Hostname; - my($host_uniq) = Sys::Hostname::hostname(); - ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) - } + my $tcp = getprotobyname('tcp'); if (!defined $tcp) { - push(@{$errs}, "getprotobyname failed for tcp"); + push @$errs, "getprotobyname failed for tcp"; return 0; } - my $syslog = getservbyname('syslog','tcp'); - $syslog = getservbyname('syslogng','tcp') unless (defined $syslog); + + my $syslog = getservbyname('syslog', 'tcp'); + $syslog = getservbyname('syslogng', 'tcp') unless defined $syslog; if (!defined $syslog) { - push(@{$errs}, "getservbyname failed for tcp"); + push @$errs, "getservbyname failed for syslog/tcp and syslogng/tcp"; return 0; } - my $this = sockaddr_in($syslog, INADDR_ANY); - my $that = sockaddr_in($syslog, inet_aton($host)); - if (!$that) { - push(@{$errs}, "can't lookup $host"); - return 0; + my $addr; + if (defined $host) { + $addr = inet_aton($host); + if (!$addr) { + push @$errs, "can't lookup $host"; + return 0; + } + } else { + $addr = INADDR_LOOPBACK; } - if (!socket(SYSLOG,AF_INET,SOCK_STREAM,$tcp)) { - push(@{$errs}, "tcp socket: $!"); + $addr = sockaddr_in($syslog, $addr); + + if (!socket(SYSLOG, AF_INET, SOCK_STREAM, $tcp)) { + push @$errs, "tcp socket: $!"; return 0; } + setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1); - setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1); - if (!CORE::connect(SYSLOG,$that)) { - push(@{$errs}, "tcp connect: $!"); + 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; } + $syslog_send = \&_syslog_send_socket; + return 1; } sub connect_udp { my ($errs) = @_; - unless ($host) { - require Sys::Hostname; - my($host_uniq) = Sys::Hostname::hostname(); - ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) - } + my $udp = getprotobyname('udp'); if (!defined $udp) { - push(@{$errs}, "getprotobyname failed for udp"); + push @$errs, "getprotobyname failed for udp"; return 0; } - my $syslog = getservbyname('syslog','udp'); + + my $syslog = getservbyname('syslog', 'udp'); if (!defined $syslog) { - push(@{$errs}, "getservbyname failed for udp"); + push @$errs, "getservbyname failed for syslog/udp"; return 0; } - my $this = sockaddr_in($syslog, INADDR_ANY); - my $that = sockaddr_in($syslog, inet_aton($host)); - if (!$that) { - push(@{$errs}, "can't lookup $host"); - return 0; + + my $addr; + if (defined $host) { + $addr = inet_aton($host); + if (!$addr) { + push @$errs, "can't lookup $host"; + return 0; + } + } else { + $addr = INADDR_LOOPBACK; } - if (!socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)) { - push(@{$errs}, "udp socket: $!"); + $addr = sockaddr_in($syslog, $addr); + + if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, $udp)) { + push @$errs, "udp socket: $!"; return 0; } - if (!CORE::connect(SYSLOG,$that)) { - push(@{$errs}, "udp connect: $!"); + if (!connect(SYSLOG, $addr)) { + push @$errs, "udp connect: $!"; return 0; } + # We want to check that the UDP connect worked. However the only # way to do that is to send a message and see if an ICMP is returned _syslog_send_socket(""); if (!connection_ok()) { - push(@{$errs}, "udp connect: nobody listening"); + push @$errs, "udp connect: nobody listening"; return 0; } + $syslog_send = \&_syslog_send_socket; + return 1; } @@ -516,78 +658,943 @@ sub connect_stream { my ($errs) = @_; # might want syslog_path to be variable based on syslog.h (if only # it were in there!) - $syslog_path = '/dev/conslog'; + $syslog_path = '/dev/conslog' unless defined $syslog_path; if (!-w $syslog_path) { - push(@{$errs}, "stream $syslog_path is not writable"); + push @$errs, "stream $syslog_path is not writable"; return 0; } - if (!open(SYSLOG, ">" . $syslog_path)) { - push(@{$errs}, "stream can't open $syslog_path: $!"); + if (!sysopen(SYSLOG, $syslog_path, O_WRONLY, 0400)) { + push @$errs, "stream can't open $syslog_path: $!"; return 0; } $syslog_send = \&_syslog_send_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) = @_; - if (length _PATH_LOG()) { - $syslog_path = _PATH_LOG(); - } else { - push(@{$errs}, "_PATH_LOG not available in syslog.h"); + + $syslog_path ||= _PATH_LOG() if length _PATH_LOG(); + + if (not defined $syslog_path) { + push @$errs, "_PATH_LOG not available in syslog.h and no user-supplied socket path"; return 0; } - my $that = sockaddr_un($syslog_path); - if (!$that) { - push(@{$errs}, "can't locate $syslog_path"); + + if (not (-S $syslog_path or -c _)) { + push @$errs, "$syslog_path is not a socket"; return 0; } - if (!socket(SYSLOG,AF_UNIX,SOCK_STREAM,0)) { - push(@{$errs}, "unix stream socket: $!"); + + my $addr = sockaddr_un($syslog_path); + if (!$addr) { + push @$errs, "can't locate $syslog_path"; return 0; } - if (!CORE::connect(SYSLOG,$that)) { - if (!socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0)) { - push(@{$errs}, "unix dgram socket: $!"); + if (!socket(SYSLOG, AF_UNIX, SOCK_STREAM, 0)) { + push @$errs, "unix stream socket: $!"; + return 0; + } + + if (!connect(SYSLOG, $addr)) { + if (!socket(SYSLOG, AF_UNIX, SOCK_DGRAM, 0)) { + push @$errs, "unix dgram socket: $!"; return 0; } - if (!CORE::connect(SYSLOG,$that)) { - push(@{$errs}, "unix dgram connect: $!"); + if (!connect(SYSLOG, $addr)) { + push @$errs, "unix dgram connect: $!"; return 0; } } + $syslog_send = \&_syslog_send_socket; + + return 1; +} + +sub connect_native { + my ($errs) = @_; + my $logopt = 0; + + # reconstruct the numeric equivalent of the options + for my $opt (keys %options) { + $logopt += xlate($opt) if $options{$opt} + } + + openlog_xs($ident, $logopt, xlate($facility)); + $syslog_send = \&_syslog_send_native; + + return 1; +} + +sub connect_eventlog { + my ($errs) = @_; + + $syslog_xobj = Sys::Syslog::Win32::_install(); + $syslog_send = \&Sys::Syslog::Win32::_syslog_send; + return 1; } sub connect_console { my ($errs) = @_; if (!-w '/dev/console') { - push(@{$errs}, "console is not writable"); + push @$errs, "console is not writable"; return 0; } $syslog_send = \&_syslog_send_console; return 1; } -# to test if the connection is still good, we need to check if any +# To test if the connection is still good, we need to check if any # errors are present on the connection. The errors will not be raised # by a write. Instead, sockets are made readable and the next read # would cause the error to be returned. Unfortunately the syslog # 'protocol' never provides anything for us to read. But with # judicious use of select(), we can see if it would be readable... sub connection_ok { - return 1 if (defined $current_proto && $current_proto eq 'console'); + return 1 if defined $current_proto and ( + $current_proto eq 'native' or $current_proto eq 'console' + or $current_proto eq 'eventlog' + ); + my $rin = ''; vec($rin, fileno(SYSLOG), 1) = 1; - my $ret = select $rin, undef, $rin, 0; + my $ret = select $rin, undef, $rin, $sock_timeout; return ($ret ? 0 : 1); } -sub disconnect { - close SYSLOG; +sub disconnect_log { $connected = 0; $syslog_send = undef; + + if (defined $current_proto and $current_proto eq 'native') { + closelog_xs(); + return 1; + } + elsif (defined $current_proto and $current_proto eq 'eventlog') { + $syslog_xobj->Close(); + return 1; + } + + return close SYSLOG; +} + + +# +# 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" } -1; + +"Eighth Rule: read the documentation." + +__END__ + +=head1 NAME + +Sys::Syslog - Perl interface to the UNIX syslog(3) calls + +=head1 VERSION + +Version 0.27 + +=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 + + openlog $ident, $logopt, $facility; # don't forget this + syslog $priority, $format, @args; + $oldmask = setlogmask $mask_priority; + closelog; + + +=head1 DESCRIPTION + +C<Sys::Syslog> is an interface to the UNIX C<syslog(3)> program. +Call C<syslog()> with a string priority and a list of C<printf()> args +just like C<syslog(3)>. + +You can find a kind of FAQ in L<"THE RULES OF SYS::SYSLOG">. Please read +it before coding, and again before asking questions. + + +=head1 EXPORTS + +C<Sys::Syslog> exports the following C<Exporter> tags: + +=over 4 + +=item * + +C<:standard> exports the standard C<syslog(3)> functions: + + openlog closelog setlogmask syslog + +=item * + +C<:extended> exports the Perl specific functions for C<syslog(3)>: + + setlogsock + +=item * + +C<:macros> exports the symbols corresponding to most of your C<syslog(3)> +macros and the C<LOG_UPTO()> and C<LOG_MASK()> functions. +See L<"CONSTANTS"> for the supported constants and their meaning. + +=back + +By default, C<Sys::Syslog> exports the symbols from the C<:standard> tag. + + +=head1 FUNCTIONS + +=over 4 + +=item B<openlog($ident, $logopt, $facility)> + +Opens the syslog. +C<$ident> is prepended to every message. C<$logopt> contains zero or +more of the options detailed below. C<$facility> specifies the part +of the system to report about, for example C<LOG_USER> or C<LOG_LOCAL0>: +see L<"Facilities"> for a list of well-known facilities, and your +C<syslog(3)> documentation for the facilities available in your system. +Check L<"SEE ALSO"> for useful links. 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<openlog()> now takes three arguments, just like C<openlog(3)>. + +B<You should use C<openlog()> before calling C<syslog()>.> + +B<Options> + +=over 4 + +=item * + +C<cons> - This option is ignored, since the failover mechanism will drop +down to the console automatically if all other media fail. + +=item * + +C<ndelay> - Open the connection immediately (normally, the connection is +opened when the first message is logged). + +=item * + +C<nofatal> - When set to true, C<openlog()> and C<syslog()> will only +emit warnings instead of dying if the connection to the syslog can't +be established. + +=item * + +C<nowait> - 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<perror> - Write the message to standard error output as well to the +system log. + +=item * + +C<pid> - Include PID with each message. + +=back + +B<Examples> + +Open the syslog with options C<ndelay> and C<pid>, and with facility C<LOCAL0>: + + openlog($name, "ndelay,pid", "local0"); + +Same thing, but this time using the macro corresponding to C<LOCAL0>: + + openlog($name, "ndelay,pid", LOG_LOCAL0); + + +=item B<syslog($priority, $message)> + +=item B<syslog($priority, $format, @args)> + +If C<$priority> permits, logs C<$message> or C<sprintf($format, @args)> +with the addition that C<%m> in $message or C<$format> is replaced with +C<"$!"> (the latest error message). + +C<$priority> can specify a level, or a level and a facility. Levels and +facilities can be given as strings or as macros. When using the C<eventlog> +mechanism, priorities C<DEBUG> and C<INFO> are mapped to event type +C<informational>, C<NOTICE> and C<WARNIN> to C<warning> and C<ERR> to +C<EMERG> to C<error>. + +If you didn't use C<openlog()> before using C<syslog()>, C<syslog()> will +try to guess the C<$ident> by extracting the shortest prefix of +C<$format> that ends in a C<":">. + +B<Examples> + + 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<Note> + +C<Sys::Syslog> version v0.07 and older passed the C<$message> as the +formatting string to C<sprintf()> even when no formatting arguments +were provided. If the code calling C<syslog()> might execute with +older versions of this module, make sure to call the function as +C<syslog($priority, "%s", $message)> instead of C<syslog($priority, +$message)>. This protects against hostile formatting sequences that +might show up if $message contains tainted data. + +=back + + +=item B<setlogmask($mask_priority)> + +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<LOG_UPTO()> function to allow all levels up to a +given priority (but it only accept the numeric macros as arguments). + +B<Examples> + +Only log errors: + + setlogmask( LOG_MASK(LOG_ERR) ); + +Log everything except informational messages: + + setlogmask( ~(LOG_MASK(LOG_INFO)) ); + +Log critical messages, errors and warnings: + + 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<setlogsock($sock_type)> + +=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: + +=over + +=item * + +C<"native"> - use the native C functions from your C<syslog(3)> library +(added in C<Sys::Syslog> 0.15). + +=item * + +C<"eventlog"> - send messages to the Win32 events logger (Win32 only; +added in C<Sys::Syslog> 0.19). + +=item * + +C<"tcp"> - connect to a TCP socket, on the C<syslog/tcp> or C<syslogng/tcp> +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. If defined, the second parameter is used as a hostname to connect to. + +=item * + +C<"unix"> - connect to a UNIX domain socket (in some systems a character +special device). The name of that socket is the second parameter or, if +you omit the second parameter, the value returned by the C<_PATH_LOG> macro +(if your system defines it), or F</dev/log> or F</dev/conslog>, whatever is +writable. + +=item * + +C<"stream"> - connect to the stream indicated by the pathname provided as +the optional second parameter, or, if omitted, to F</dev/conslog>. +For example Solaris and IRIX system may prefer C<"stream"> instead of C<"unix">. + +=item * + +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</dev/log> +(added in C<Sys::Syslog> 0.21). + +=item * + +C<"console"> - send messages directly to the console, as for the C<"cons"> +option of C<openlog()>. + +=back + +A reference to an array can also be passed as the first parameter. +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<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. + +Giving an invalid value for C<$sock_type> will C<croak>. + +B<Examples> + +Select the UDP socket mechanism: + + setlogsock("udp"); + +Select the native, UDP socket then UNIX domain socket mechanisms: + + setlogsock(["native", "udp", "unix"]); + +=over + +=item B<Note> + +Now that the "native" mechanism is supported by C<Sys::Syslog> and selected +by default, the use of the C<setlogsock()> function is discouraged because +other mechanisms are less portable across operating systems. Authors of +modules and programs that use this function, especially its cargo-cult form +C<setlogsock("unix")>, are advised to remove any occurence of it unless they +specifically want to use a given mechanism (like TCP or UDP to connect to +a remote host). + +=back + +=item B<closelog()> + +Closes the log file and returns true on success. + +=back + + +=head1 THE RULES OF SYS::SYSLOG + +I<The First Rule of Sys::Syslog is:> +You do not call C<setlogsock>. + +I<The Second Rule of Sys::Syslog is:> +You B<do not> call C<setlogsock>. + +I<The Third Rule of Sys::Syslog is:> +The program crashes, C<die>s, calls C<closelog>, the log is over. + +I<The Fourth Rule of Sys::Syslog is:> +One facility, one priority. + +I<The Fifth Rule of Sys::Syslog is:> +One log at a time. + +I<The Sixth Rule of Sys::Syslog is:> +No C<syslog> before C<openlog>. + +I<The Seventh Rule of Sys::Syslog is:> +Logs will go on as long as they have to. + +I<The Eighth, and Final Rule of Sys::Syslog is:> +If this is your first use of Sys::Syslog, you must read the doc. + + +=head1 EXAMPLES + +An example: + + openlog($program, 'cons,pid', 'user'); + syslog('info', '%s', 'this is another test'); + syslog('mail|warning', 'this is a better test: %d', time); + closelog(); + + syslog('debug', 'this is the last test'); + +Another example: + + openlog("$program $$", 'ndelay', 'user'); + syslog('notice', 'fooprogram: this is really done'); + +Example of use of C<%m>: + + $! = 55; + syslog('info', 'problem was %m'); # %m == $! in syslog(3) + +Log to UDP port on C<$remotehost> instead of logging locally: + + setlogsock("udp", $remotehost); + openlog($program, 'ndelay', 'user'); + syslog('info', 'something happened over here'); + + +=head1 CONSTANTS + +=head2 Facilities + +=over 4 + +=item * + +C<LOG_AUDIT> - audit daemon (IRIX); falls back to C<LOG_AUTH> + +=item * + +C<LOG_AUTH> - security/authorization messages + +=item * + +C<LOG_AUTHPRIV> - security/authorization messages (private) + +=item * + +C<LOG_CONSOLE> - C</dev/console> output (FreeBSD); falls back to C<LOG_USER> + +=item * + +C<LOG_CRON> - clock daemons (B<cron> and B<at>) + +=item * + +C<LOG_DAEMON> - system daemons without separate facility value + +=item * + +C<LOG_FTP> - FTP daemon + +=item * + +C<LOG_KERN> - kernel messages + +=item * + +C<LOG_INSTALL> - installer subsystem (Mac OS X); falls back to C<LOG_USER> + +=item * + +C<LOG_LAUNCHD> - launchd - general bootstrap daemon (Mac OS X); +falls back to C<LOG_DAEMON> + +=item * + +C<LOG_LFMT> - logalert facility; falls back to C<LOG_USER> + +=item * + +C<LOG_LOCAL0> through C<LOG_LOCAL7> - reserved for local use + +=item * + +C<LOG_LPR> - line printer subsystem + +=item * + +C<LOG_MAIL> - mail subsystem + +=item * + +C<LOG_NETINFO> - NetInfo subsystem (Mac OS X); falls back to C<LOG_DAEMON> + +=item * + +C<LOG_NEWS> - USENET news subsystem + +=item * + +C<LOG_NTP> - NTP subsystem (FreeBSD, NetBSD); falls back to C<LOG_DAEMON> + +=item * + +C<LOG_RAS> - Remote Access Service (VPN / PPP) (Mac OS X); +falls back to C<LOG_AUTH> + +=item * + +C<LOG_REMOTEAUTH> - remote authentication/authorization (Mac OS X); +falls back to C<LOG_AUTH> + +=item * + +C<LOG_SECURITY> - security subsystems (firewalling, etc.) (FreeBSD); +falls back to C<LOG_AUTH> + +=item * + +C<LOG_SYSLOG> - messages generated internally by B<syslogd> + +=item * + +C<LOG_USER> (default) - generic user-level messages + +=item * + +C<LOG_UUCP> - UUCP subsystem + +=back + + +=head2 Levels + +=over 4 + +=item * + +C<LOG_EMERG> - system is unusable + +=item * + +C<LOG_ALERT> - action must be taken immediately + +=item * + +C<LOG_CRIT> - critical conditions + +=item * + +C<LOG_ERR> - error conditions + +=item * + +C<LOG_WARNING> - warning conditions + +=item * + +C<LOG_NOTICE> - normal, but significant, condition + +=item * + +C<LOG_INFO> - informational message + +=item * + +C<LOG_DEBUG> - debug-level message + +=back + + +=head1 DIAGNOSTICS + +=over + +=item C<Invalid argument passed to setlogsock> + +B<(F)> You gave C<setlogsock()> an invalid value for C<$sock_type>. + +=item C<eventlog passed to setlogsock, but no Win32 API available> + +B<(W)> You asked C<setlogsock()> to use the Win32 event logger but the +operating system running the program isn't Win32 or does not provides Win32 +compatible facilities. + +=item C<no connection to syslog available> + +B<(F)> C<syslog()> failed to connect to the specified socket. + +=item C<stream passed to setlogsock, but %s is not writable> + +B<(W)> You asked C<setlogsock()> to use a stream socket, but the given +path is not writable. + +=item C<stream passed to setlogsock, but could not find any device> + +B<(W)> You asked C<setlogsock()> to use a stream socket, but didn't +provide a path, and C<Sys::Syslog> was unable to find an appropriate one. + +=item C<tcp passed to setlogsock, but tcp service unavailable> + +B<(W)> You asked C<setlogsock()> to use a TCP socket, but the service +is not available on the system. + +=item C<syslog: expecting argument %s> + +B<(F)> You forgot to give C<syslog()> the indicated argument. + +=item C<syslog: invalid level/facility: %s> + +B<(F)> You specified an invalid level or facility. + +=item C<syslog: too many levels given: %s> + +B<(F)> You specified too many levels. + +=item C<syslog: too many facilities given: %s> + +B<(F)> You specified too many facilities. + +=item C<syslog: level must be given> + +B<(F)> You forgot to specify a level. + +=item C<udp passed to setlogsock, but udp service unavailable> + +B<(W)> You asked C<setlogsock()> to use a UDP socket, but the service +is not available on the system. + +=item C<unix passed to setlogsock, but path not available> + +B<(W)> You asked C<setlogsock()> to use a UNIX socket, but C<Sys::Syslog> +was unable to find an appropriate an appropriate device. + +=back + + +=head1 SEE ALSO + +=head2 Manual Pages + +L<syslog(3)> + +SUSv3 issue 6, IEEE Std 1003.1, 2004 edition, +L<http://www.opengroup.org/onlinepubs/000095399/basedefs/syslog.h.html> + +GNU C Library documentation on syslog, +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/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.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/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> + +Stratus VOS 15.1, +L<http://stratadoc.stratus.com/vos/15.1.1/r502-01/wwhelp/wwhimpl/js/html/wwhelp.htm?context=r502-01&file=ch5r502-01bi.html> + +=head2 RFCs + +I<RFC 3164 - The BSD syslog Protocol>, L<http://www.faqs.org/rfcs/rfc3164.html> +-- Please note that this is an informational RFC, and therefore does not +specify a standard of any kind. + +I<RFC 3195 - Reliable Delivery for syslog>, L<http://www.faqs.org/rfcs/rfc3195.html> + +=head2 Articles + +I<Syslogging with Perl>, L<http://lexington.pm.org/meetings/022001.html> + +=head2 Event Log + +Windows Event Log, +L<http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wes/wes/windows_event_log.asp> + + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +Tom Christiansen E<lt>F<tchrist (at) perl.com>E<gt> and Larry Wall +E<lt>F<larry (at) wall.org>E<gt>. + +UNIX domain sockets added by Sean Robinson +E<lt>F<robinson_s (at) sc.maricopa.edu>E<gt> with support from Tim Bunce +E<lt>F<Tim.Bunce (at) ig.co.uk>E<gt> and the C<perl5-porters> mailing list. + +Dependency on F<syslog.ph> replaced with XS code by Tom Hughes +E<lt>F<tom (at) compton.nu>E<gt>. + +Code for C<constant()>s regenerated by Nicholas Clark E<lt>F<nick (at) ccl4.org>E<gt>. + +Failover to different communication modes by Nick Williams +E<lt>F<Nick.Williams (at) morganstanley.com>E<gt>. + +Extracted from core distribution for publishing on the CPAN by +SE<eacute>bastien Aperghis-Tramoni E<lt>sebastien (at) aperghis.netE<gt>. + +XS code for using native C functions borrowed from C<L<Unix::Syslog>>, +written by Marcus Harnisch E<lt>F<marcus.harnisch (at) gmx.net>E<gt>. + +Yves Orton suggested and helped for making C<Sys::Syslog> use the native +event logger under Win32 systems. + +Jerry D. Hedden and Reini Urban provided greatly appreciated help to +debug and polish C<Sys::Syslog> under Cygwin. + + +=head1 BUGS + +Please report any bugs or feature requests to +C<bug-sys-syslog (at) rt.cpan.org>, or through the web interface at +L<http://rt.cpan.org/Public/Dist/Display.html?Name=Sys-Syslog>. +I will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Sys::Syslog + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L<http://annocpan.org/dist/Sys-Syslog> + +=item * CPAN Ratings + +L<http://cpanratings.perl.org/d/Sys-Syslog> + +=item * RT: CPAN's request tracker + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-Syslog> + +=item * Search CPAN + +L<http://search.cpan.org/dist/Sys-Syslog/> + +=item * Kobes' CPAN Search + +L<http://cpan.uwinnipeg.ca/dist/Sys-Syslog> + +=item * Perl Documentation + +L<http://perldoc.perl.org/Sys/Syslog.html> + +=back + + +=head1 COPYRIGHT + +Copyright (C) 1990-2008 by Larry Wall and others. + + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +=begin comment + +Notes for the future maintainer (even if it's still me..) +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +Using Google Code Search, I search who on Earth was relying on $host being +public. It found 5 hits: + +* First was inside Indigo Star Perl2exe documentation. Just an old version +of Sys::Syslog. + + +* One real hit was inside DalWeathDB, a weather related program. It simply +does a + + $Sys::Syslog::host = '127.0.0.1'; + +- L<http://www.gallistel.net/nparker/weather/code/> + + +* Two hits were in TPC, a fax server thingy. It does a + + $Sys::Syslog::host = $TPC::LOGHOST; + +but also has this strange piece of code: + + # work around perl5.003 bug + sub Sys::Syslog::hostname {} + +I don't know what bug the author referred to. + +- L<http://www.tpc.int/> +- L<ftp://ftp.tpc.int/tpc/server/UNIX/> +- L<ftp://ftp-usa.tpc.int/pub/tpc/server/UNIX/> + + +* Last hit was in Filefix, which seems to be a FIDOnet mail program (!). +This one does not use $host, but has the following piece of code: + + sub Sys::Syslog::hostname + { + use Sys::Hostname; + return hostname; + } + +I guess this was a more elaborate form of the previous bit, maybe because +of a bug in Sys::Syslog back then? + +- L<ftp://ftp.kiae.su/pub/unix/fido/> + + +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> + +Getting the most out of the Event Viewer +- L<http://www.codeproject.com/dotnet/evtvwr.asp?print=true> + +Log events to the Windows NT Event Log with JNI +- L<http://www.javaworld.com/javaworld/jw-09-2001/jw-0928-ntmessages.html> + +=end comment + diff --git a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Syslog.xs b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Syslog.xs index 93f1272e91..704ed9e778 100644 --- a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Syslog.xs +++ b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/Syslog.xs @@ -1,11 +1,29 @@ +#if defined(_WIN32) +# include <windows.h> +#endif + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#ifdef USE_PPPORT_H +# include "ppport.h" +#endif -#ifdef I_SYSLOG -#include <syslog.h> +#ifndef HAVE_SYSLOG +#define HAVE_SYSLOG 1 #endif +#if defined(_WIN32) && !defined(__CYGWIN__) +# undef HAVE_SYSLOG +# include "fallback/syslog.h" +#else +# if defined(I_SYSLOG) || PATCHLEVEL < 6 +# include <syslog.h> +# endif +#endif + +static SV *ident_svptr; + #include "const-c.inc" MODULE = Sys::Syslog PACKAGE = Sys::Syslog @@ -82,3 +100,72 @@ LOG_UPTO(pri) #endif OUTPUT: RETVAL + +#ifdef HAVE_SYSLOG + +void +openlog_xs(ident, option, facility) + INPUT: + SV* ident + int option + int facility + PREINIT: + STRLEN len; + char* ident_pv; + CODE: + ident_svptr = newSVsv(ident); + ident_pv = SvPV(ident_svptr, len); + openlog(ident_pv, option, facility); + +void +syslog_xs(priority, message) + INPUT: + int priority + const char * message + CODE: + syslog(priority, "%s", message); + +int +setlogmask_xs(mask) + INPUT: + int mask + CODE: + RETVAL = setlogmask(mask); + OUTPUT: + RETVAL + +void +closelog_xs() + CODE: + closelog(); + if (SvREFCNT(ident_svptr)) + SvREFCNT_dec(ident_svptr); + +#else /* HAVE_SYSLOG */ + +void +openlog_xs(ident, option, facility) + INPUT: + SV* ident + int option + int facility + CODE: + +void +syslog_xs(priority, message) + INPUT: + int priority + const char * message + CODE: + +int +setlogmask_xs(mask) + INPUT: + int mask + CODE: + +void +closelog_xs() + CODE: + +#endif /* HAVE_SYSLOG */ diff --git a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/00-load.t b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/00-load.t new file mode 100755 index 0000000000..bbf2289457 --- /dev/null +++ b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/00-load.t @@ -0,0 +1,8 @@ +#!perl -wT +use strict; +use Test::More tests => 1; + +use_ok( 'Sys::Syslog' ); + +diag( "Testing Sys::Syslog $Sys::Syslog::VERSION, Perl $], $^X" ) + unless $ENV{PERL_CORE}; diff --git a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/constants.t b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/constants.t new file mode 100755 index 0000000000..c2002fb374 --- /dev/null +++ b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/constants.t @@ -0,0 +1,42 @@ +#!perl -wT +use strict; +use File::Spec; +use Test::More; + +# NB. For PERL_CORE to be set, taint mode must not be enabled +my $macrosall = $ENV{PERL_CORE} ? File::Spec->catfile(qw(.. ext Sys Syslog macros.all)) + : 'macros.all'; +open(MACROS, $macrosall) or plan skip_all => "can't read '$macrosall': $!"; +my @names = map {chomp;$_} <MACROS>; +close(MACROS); +plan tests => @names * 2 + 2; + +my $callpack = my $testpack = 'Sys::Syslog'; +eval "use $callpack"; + +eval "${callpack}::This()"; +like( $@, "/^This is not a valid $testpack macro/", "trying a non-existing macro"); + +eval "${callpack}::NOSUCHNAME()"; +like( $@, "/^NOSUCHNAME is not a valid $testpack macro/", "trying a non-existing macro"); + +# Testing all macros +if(@names) { + for my $name (@names) { + SKIP: { + $name =~ /^(\w+)$/ or skip "invalid name '$name'", 2; + $name = $1; + my $v = eval "${callpack}::$name()"; + + if(defined $v and $v =~ /^\d+$/) { + is( $@, '', "calling the constant $name as a function" ); + like( $v, '/^\d+$/', "checking that $name is a number ($v)" ); + + } else { + like( $@, "/^Your vendor has not defined $testpack macro $name/", + "calling the constant via its name" ); + skip "irrelevant test in this case", 1 + } + } + } +} diff --git a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/syslog.t b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/syslog.t index 8f038d31fb..56a83c74ef 100755 --- a/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/syslog.t +++ b/usr/src/cmd/perl/5.8.4/distrib/ext/Sys/Syslog/t/syslog.t @@ -1,94 +1,273 @@ -#!./perl +#!perl -T BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSyslog\b/) { - print "1..0 # Skip: Sys::Syslog was not built\n"; - exit 0; - } - if ($Config{'extensions'} !~ /\bSocket\b/) { - print "1..0 # Skip: Socket was not built\n"; - exit 0; + if ($ENV{PERL_CORE}) { + chdir 't'; + @INC = '../lib'; } +} - require Socket; +use strict; +use Config; +use File::Spec; +use Test::More; - # This code inspired by Sys::Syslog::connect(): - require Sys::Hostname; - my ($host_uniq) = Sys::Hostname::hostname(); - my ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; +# we enable all Perl warnings, but we don't "use warnings 'all'" because +# we want to disable the warnings generated by Sys::Syslog +no warnings; +use warnings qw(closure deprecated exiting glob io misc numeric once overflow + pack portable recursion redefine regexp severe signal substr + syntax taint uninitialized unpack untie utf8 void); - if (! defined Socket::inet_aton($host)) { - print "1..0 # Skip: Can't lookup $host\n"; - exit 0; - } +# if someone is using warnings::compat, the previous trick won't work, so we +# must manually disable warnings +$^W = 0 if $] < 5.006; + +my $is_Win32 = $^O =~ /win32/i; +my $is_Cygwin = $^O =~ /cygwin/i; + +# if testing in core, check that the module is at least available +if ($ENV{PERL_CORE}) { + plan skip_all => "Sys::Syslog was not build" + unless $Config{'extensions'} =~ /\bSyslog\b/; } -BEGIN { - eval {require Sys::Syslog} or do { - if ($@ =~ /Your vendor has not/) { - print "1..0 # Skip: missing macros\n"; - exit 0; +# we also need Socket +plan skip_all => "Socket was not build" + unless $Config{'extensions'} =~ /\bSocket\b/; + +my $tests; +plan tests => $tests; + +# any remaining warning should be severly punished +BEGIN { eval "use Test::NoWarnings"; $tests = $@ ? 0 : 1; } + +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/, + "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" ); + + +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 + unless -e Sys::Syslog::_PATH_LOG(); + + # The only known $^O eq 'svr4' that needs this is NCR MP-RAS, + # but assuming 'stream' in SVR4 is probably not that bad. + my $sock_type = $^O =~ /^(solaris|irix|svr4|powerux)$/ ? 'stream' : 'unix'; + + eval { setlogsock($sock_type) }; + is( $@, '', "setlogsock() called with '$sock_type'" ); + TODO: { + local $TODO = "minor bug"; + ok( $r, "setlogsock() should return true: '$r'" ); + } + + # open syslog with a "local0" facility + SKIP: { + # 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'" ); } - } } -use Sys::Syslog qw(:DEFAULT setlogsock); -# Test this to 1 if your syslog accepts udp connections. -# Most don't (or at least shouldn't) -my $Test_Syslog_INET = 0; +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", 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", 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", 20 unless $r; + is( $@, '', "[$sock_type] setlogsock() called with '$sock_type'" ); + ok( $r, "[$sock_type] setlogsock() should return true: '$r'" ); -my $test_string = "uid $< is testing perl $] syslog capabilities"; + # openlog() without option NDELAY + $r = eval { openlog('perl', '', 'local0') } || 0; + 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'" ); -print "1..6\n"; + # openlog() with the option NDELAY + $r = eval { openlog('perl', 'ndelay', 'local0') } || 0; + 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'" ); -if (Sys::Syslog::_PATH_LOG()) { - if (-e Sys::Syslog::_PATH_LOG()) { - # The only known $^O eq 'svr4' that needs this is NCR MP-RAS, - # but assuming 'stream' in SVR4 is probably not that bad. - if ($^O =~ /^(solaris|irix|svr4|powerux)$/) { - # we should check for stream support here, not for solaris/irix - print defined(eval { setlogsock('stream') }) ? "ok 1\n" : "not ok 1 # $!\n"; - } else { - print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1 # $!\n"; + # 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: /', "[$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'" ); + ok( !$r, "[$sock_type] 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/', "[$sock_type] syslog() called with level 'local0,local1'" ); + ok( !$r, "[$sock_type] 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( $@, '', "[$sock_type] syslog() called with level 'info' (string)" ); + ok( $r, "[$sock_type] syslog() should return true: '$r'" ); + + # syslog() with level "info" (as a macro), should pass + { local $! = 1; + $r = eval { syslog(LOG_INFO(), "$test_string by connecting to a $sock_type socket, setting a fake errno: %m") } || 0; } - if (defined(eval { openlog('perl', 'ndelay', 'local0') })) { - print "ok 2\n"; - print defined(eval { syslog('info', $test_string ) }) - ? "ok 3\n" : "not ok 3 # $!\n"; - } else { - if ($@ =~ /no connection to syslog available/) { - print "ok 2 # Skip: syslogd not running\n"; - } else { - print "not ok 2 # $@\n"; - } - print "ok 3 # Skip: openlog failed\n"; - } - } else { - for (1..3) { - print - "ok $_ # Skip: file ", - Sys::Syslog::_PATH_LOG(), - " does not exist\n"; + is( $@, '', "[$sock_type] syslog() called with level 'info' (macro)" ); + ok( $r, "[$sock_type] syslog() should return true: '$r'" ); + + push @passed, $sock_type; + + SKIP: { + skip "skipping closelog() tests for 'console'", 2 if $sock_type eq 'console'; + # closelog() + $r = eval { closelog() } || 0; + is( $@, '', "[$sock_type] closelog()" ); + ok( $r, "[$sock_type] closelog() should return true: '$r'" ); } } } -else { - for (1..3) { print "ok $_ # Skip: _PATH_LOG unavailable\n" } -} -if( $Test_Syslog_INET ) { - print defined(eval { setlogsock('inet') }) ? "ok 4\n" - : "not ok 4\n"; - print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" - : "not ok 5 # $!\n"; - print defined(eval { syslog('info', $test_string ) }) ? "ok 6\n" - : "not ok 6 # $!\n"; + +BEGIN { $tests += 10 } +SKIP: { + skip "not testing setlogsock('stream') on Win32", 10 if $is_Win32; + skip "the 'unix' mechanism works, so the tests will likely fail with the 'stream' mechanism", 10 + if grep {/unix/} @passed; + + skip "not testing setlogsock('stream'): _PATH_LOG unavailable", 10 + unless -e Sys::Syslog::_PATH_LOG(); + + # setlogsock() with "stream" and an undef path + $r = eval { setlogsock("stream", undef ) } || ''; + is( $@, '', "setlogsock() called, with 'stream' and an undef path" ); + if ($is_Cygwin) { + if (-x "/usr/sbin/syslog-ng") { + ok( $r, "setlogsock() on Cygwin with syslog-ng should return true: '$r'" ); + } + else { + ok( !$r, "setlogsock() on Cygwin without syslog-ng should return false: '$r'" ); + } + } + else { + 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); + } } -else { - print "ok $_ # Skip: assuming syslog doesn't accept inet connections\n" - foreach (4..6); + + +BEGIN { $tests += 3 + 4 * 3 } +# 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"); + + 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"); + $r = eval { setlogmask(0) } || 0; + is( $@, '', "setlogmask() called with a null mask" ); + is( $r, $newmask, "setlogmask() must return the new mask"); + setlogmask($oldmask); + } } diff --git a/usr/src/cmd/perl/5.8.4/distrib/patchlevel.h b/usr/src/cmd/perl/5.8.4/distrib/patchlevel.h index 461e64f5b9..589a256ea8 100644 --- a/usr/src/cmd/perl/5.8.4/distrib/patchlevel.h +++ b/usr/src/cmd/perl/5.8.4/distrib/patchlevel.h @@ -151,6 +151,7 @@ static char *local_patches[] = { "SPRINTF0 - fixes for sprintf formatting issues - CVE-2005-3962", "6663288 Upgrade to CGI.pm 3.33", "REGEXP0 - fix for UTF-8 recoding in regexps - CVE-2007-5116", + "6758953 Perl Sys::Syslog can log messages with wrong severity", NULL }; |