From: Sébastien Aperghis-Tramoni Date: Thu, 23 Aug 2007 16:04:46 +0000 (+0200) Subject: Upgrade Sys::Syslog to 0.19_01 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a650b8419c25651c98cefeaefad81b6e7d4e4c4a;p=p5sagit%2Fp5-mst-13.2.git Upgrade Sys::Syslog to 0.19_01 Message-ID: <1187877886.46cd93fe13b12@imp.free.fr> p4raw-id: //depot/perl@31750 --- diff --git a/MANIFEST b/MANIFEST index 42adc8f..adf62c9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1087,6 +1087,11 @@ ext/Sys/Syslog/Syslog.xs Sys::Syslog extension external subroutines ext/Sys/Syslog/t/00-load.t test for Sys::Syslog ext/Sys/Syslog/t/constants.t test for Sys::Syslog ext/Sys/Syslog/t/syslog.t See if Sys::Syslog works +ext/Sys/Syslog/win32/compile.pl Sys::Syslog extension Win32 related file +ext/Sys/Syslog/win32/PerlLog_dll.uu Sys::Syslog extension Win32 related file +ext/Sys/Syslog/win32/PerlLog.mc Sys::Syslog extension Win32 related file +ext/Sys/Syslog/win32/PerlLog_RES.uu Sys::Syslog extension Win32 related file +ext/Sys/Syslog/win32/Win32.pm Sys::Syslog extension Win32 related file ext/Text/Soundex/Changes Changelog for Text::Soundex ext/Text/Soundex/Makefile.PL Text::Soundex extension makefile writer ext/Text/Soundex/README README for Text::Soundex diff --git a/ext/Sys/Syslog/Changes b/ext/Sys/Syslog/Changes index 27b2631..fdb71a3 100644 --- a/ext/Sys/Syslog/Changes +++ b/ext/Sys/Syslog/Changes @@ -1,5 +1,28 @@ Revision history for Sys-Syslog +0.19 -- 2007.08.xx -- Sebastien Aperghis-Tramoni (SAPER) + [BUGFIX] CPAN-RT#20635: Fix tests to avoid problems related to the + "stream" mechanism which occured on Debian and Cygwin. + [BUGFIX] CPAN-RT#20780: Facility could not be temporarily changed. + Also fixes the syslog() before openlog() bug. + [BUGFIX] CPAN-RT#21333: Makefile.PL now creates a typemap for Perl 5.6.1 + [BUGFIX] CPAN-RT#21516: disconnect_log() now correctly calls closelog_xs(). + [BUGFIX] CPAN-RT#21866: Silence warnings in openlog(). + [BUGFIX] CPAN-RT#25488: Silence warnings in disconnect_log(). + via syslog(). + [BUGFIX] Rewrote the constants generation code in order to provide + fallback value for non-standard macros. + [FEATURE] Added Win32 event log support thanks to Yves Orton. + [FEATURE] Added new macros from modern BSD and IRIX. + [FEATURE] Each non-standard macro now fall backs to a standard macro. + [CODE] Merged changes from Jerry D. Hedden to use ppport.h only when not + built from core distribution (blead@30657). + [TESTS] t/syslog.t now generates a more detailled TAP output. + [TESTS] Merged change blead@29176: suppress taint mode from t/constants.t + [TESTS] Added regression tests for CPAN-RT#21866 and #25488. + [EG] Added example script eg/syslog.pl + [DOC] Added the Sys::Syslog Rules. + 0.18 -- 2006.08.28 -- Sebastien Aperghis-Tramoni (SAPER) [BUGFIX] Rewrote the way the default identifiant is constructed. [TESTS] CPAN-RT#20946: Removed the console mechanism from the main @@ -12,7 +35,7 @@ Revision history for Sys-Syslog some dead code. [CODE] Actually added the macros from Mac OS X that were announced in the 0.14 version. - [DOC] CPAN-RT#20545: Rewrote the documentation about setlogksock(). + [DOC] CPAN-RT#20545: Rewrote the documentation about setlogsock(). 0.16 -- 2006.06.20 -- Sebastien Aperghis-Tramoni (SAPER) [BUGFIX] Perl-RT#20557: Save errno before trying to connect. @@ -24,7 +47,6 @@ Revision history for Sys-Syslog [DOC] Added documentation about the "native" mechanism. [DOC] Now indicates whether tickets are from CPAN or Perl RT. - 0.15 -- 2006.06.10 -- Sebastien Aperghis-Tramoni (SAPER) [FEATURE] CPAN-RT#17316: Added a "nofatal" option to openlog(). [FEATURE] Sys::Syslog warnings can now be controled by the warnings diff --git a/ext/Sys/Syslog/Makefile.PL b/ext/Sys/Syslog/Makefile.PL index f56e7ba..679a2ff 100644 --- a/ext/Sys/Syslog/Makefile.PL +++ b/ext/Sys/Syslog/Makefile.PL @@ -1,90 +1,174 @@ use strict; +use Config; use ExtUtils::MakeMaker; eval 'use ExtUtils::MakeMaker::Coverage'; +use File::Copy; +use File::Path; +use File::Spec; require 5.006; + +# 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"; + +# 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::TieRegistry" => 0, "Win32::EventLog" => 0; + + $virtual_path{'win32/Win32.pm' } = '$(INST_LIBDIR)/Syslog/Win32.pm'; + $virtual_path{'win32/PerlLog.dll'} = '$(INST_ARCHAUTODIR)/PerlLog.dll'; + + # 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 $/; }; + 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'; +} + WriteMakefile( NAME => 'Sys::Syslog', LICENSE => 'perl', VERSION_FROM => 'Syslog.pm', ABSTRACT_FROM => 'Syslog.pm', INSTALLDIRS => 'perl', - MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', + PM => \%virtual_path, PREREQ_PM => { 'Test::More' => 0, 'XSLoader' => 0, + @extra_prereqs, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Sys-Syslog-*' }, - realclean => { FILES => 'const-c.inc const-xs.inc macros.all' }, - ( - (grep { $_ eq 'PERL_CORE=1' } @ARGV) - ? () - : ('DEFINE' => '-DUSE_PPPORT_H') - ), + realclean => { FILES => 'lib const-c.inc const-xs.inc macros.all PerlLog.h *.bak *.bin *.rc' }, + @extra_params ); + +# find a default value for _PATH_LOG my $_PATH_LOG; -if (-S "/dev/log" and -w "/dev/log") { - # Most unixes have a unix domain socket /dev/log. - $_PATH_LOG = "/dev/log"; -} elsif (-c "/dev/conslog" and -w "/dev/conslog") { +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"; -} else { +} +elsif (-S "/dev/log" and -w _) { + # Most unixes have a unix domain socket /dev/log. + $_PATH_LOG = "/dev/log"; +} +elsif (-S "/var/run/syslog" and -w _) { + # Mac OS X puts it at a different path. + $_PATH_LOG = "/var/run/syslog"; +} +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 @names = ( - # levels - qw( - LOG_ALERT LOG_CRIT LOG_DEBUG LOG_EMERG LOG_ERR - LOG_INFO LOG_NOTICE LOG_WARNING - ), - - # facilities - qw( - LOG_AUTH LOG_AUTHPRIV LOG_CRON LOG_DAEMON LOG_FTP - LOG_INSTALL LOG_KERN LOG_LAUNCHD LOG_LFMT LOG_LOCAL0 - LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4 LOG_LOCAL5 - LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NETINFO - LOG_NEWS LOG_RAS LOG_REMOTEAUTH LOG_SYSLOG LOG_USER LOG_UUCP - ), - - # options - qw( - LOG_CONS LOG_PID LOG_NDELAY LOG_NOWAIT LOG_ODELAY LOG_PERROR - ), - - # others macros - qw( - LOG_FACMASK LOG_NFACILITIES - ), - { name => "LOG_PRIMASK", type => "IV", default => [ "IV", 7] }, - { name => "_PATH_LOG", type => "PV", default => [ "PV", qq("$_PATH_LOG") ] }, + 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( ($] > 5.009002 ? (PROXYSUBS => 1) : ()), NAME => 'Sys::Syslog', - NAMES => \@names, + NAMES => [ @levels, @facilities, @options, @others_macros ], ); - open(MACROS, '>macros.all') or warn "can't write 'macros.all': $!\n"; - print MACROS join $/, grep {!ref} @names; + 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 { - require File::Copy; - require File::Spec; +} +else { foreach my $file ('const-c.inc', 'const-xs.inc') { my $fallback = File::Spec->catfile('fallback', $file); - File::Copy::copy($fallback, $file) or die "Can't copy $fallback to $ $!"; + copy($fallback, $file) or die "fatal: Can't copy $fallback to $file: $!"; } } diff --git a/ext/Sys/Syslog/README b/ext/Sys/Syslog/README index a6b4fc3..e3e693c 100644 --- a/ext/Sys/Syslog/README +++ b/ext/Sys/Syslog/README @@ -21,16 +21,16 @@ INSTALLATION An ANSI-compliant compiler is required to compile the extension. - Sys::Syslog should on any Perl since 5.6.0. This module has been - tested by the author on the following Perl and system versions + Sys::Syslog should work on any Perl since 5.6.0. This module has + been tested by the author on the following Perl and system versions but is likely to run on many more: - - Perl 5.6.2 i686-linux gcc-3.4.1 (custom build) - - Perl 5.8.5 i386-linux-thread-multi gcc-3.4.1 (vendor build) - - Perl 5.8.7 i386-linux gcc-3.4.1 (custom build) - - Perl 5.8.8 i386-freebsd-64int gcc-3.4.4 (custom build) - - Perl 5.8.8 i386-linux gcc-3.4.1 (custom build) - - Perl 5.8.6 darwin-thread-multi-2level gcc-4.0.1 (PowerPC) (vendor build) + Perl Architecture GCC + ----------------------------------------------------- + 5.6.2 i686-linux 3.4.1 + 5.8.5 i386-linux-thread-multi 3.4.1 + 5.8.8 i386-freebsd-64int 3.4.4 + 5.8.6 darwin-thread-multi-2level (PowerPC) 4.0.1 See also the corresponding CPAN Testers page: http://testers.cpan.org/show/Sys-Syslog.html diff --git a/ext/Sys/Syslog/Syslog.pm b/ext/Sys/Syslog/Syslog.pm index 6dc3c85..957c22a 100644 --- a/ext/Sys/Syslog/Syslog.pm +++ b/ext/Sys/Syslog/Syslog.pm @@ -2,6 +2,7 @@ package Sys::Syslog; use strict; use warnings::register; use Carp; +use Fcntl qw(O_WRONLY); use File::Basename; use POSIX qw(strftime setlocale LC_TIME); use Socket ':all'; @@ -9,7 +10,7 @@ require 5.006; require Exporter; { no strict 'vars'; - $VERSION = '0.18_01'; + $VERSION = '0.19_01'; @ISA = qw(Exporter); %EXPORT_TAGS = ( @@ -22,14 +23,19 @@ require Exporter; LOG_INFO LOG_NOTICE LOG_WARNING ), - # facilities + # standard facilities qw( - LOG_AUTH LOG_AUTHPRIV LOG_CRON LOG_DAEMON LOG_FTP - LOG_INSTALL LOG_KERN LOG_LAUNCHD LOG_LFMT LOG_LOCAL0 - LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4 LOG_LOCAL5 - LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NETINFO - LOG_NEWS LOG_RAS LOG_REMOTEAUTH LOG_SYSLOG LOG_USER LOG_UUCP - ), + 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( @@ -68,18 +74,20 @@ require Exporter; # # Public variables # -our $host; # host to send syslog messages to +use vars qw($host); # host to send syslog messages to (see notes at end) # # 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 $current_proto = undef; # current mechanism used to transmit messages my $ident = ''; # identifiant prepended to each message -my $facility = ''; # current facility +$facility = ''; # current facility my $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask my %options = ( @@ -89,12 +97,23 @@ my %options = ( pid => 0, ); -# it would be nice to try stream/unix first, since that will be -# most efficient. However streams are dodgy - see _syslog_send_stream +# Default is now to first use the native mechanism, so Perl programs +# behave like other normal C programs, then try other mechanisms. my @connectMethods = qw(native tcp udp unix stream console); if ($^O =~ /^(freebsd|linux)$/) { @connectMethods = grep { $_ ne 'udp' } @connectMethods; } + +# use EventLog on Win32 +my $is_Win32 = $^O =~ /Win32/i; +eval "use Sys::Syslog::Win32"; + +if (not $@) { + unshift @connectMethods, 'eventlog'; +} elsif ($is_Win32) { + warn $@; +} + my @defaultMethods = @connectMethods; my @fallbackMethods = (); @@ -110,7 +129,7 @@ sub AUTOLOAD { ($constname = $AUTOLOAD) =~ s/.*:://; croak "Sys::Syslog::constant() not defined" if $constname eq 'constant'; my ($error, $val) = constant($constname); - croak $error if $error; + croak $error if $error; no strict 'refs'; *$AUTOLOAD = sub { $val }; goto &$AUTOLOAD; @@ -120,6 +139,11 @@ sub AUTOLOAD { sub openlog { ($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} } @@ -152,42 +176,55 @@ sub setlogsock { @connectMethods = @$setsock; } elsif (lc $setsock eq 'stream') { - unless (defined $syslog_path) { + 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; } } - warnings::warnif "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) { + + 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 && -w $syslog_path)) { $syslog_path = _PATH_LOG() unless defined $syslog_path; - @connectMethods = ( 'unix' ); + @connectMethods = qw(unix); } else { warnings::warnif 'unix passed to setlogsock, but path not available'; return undef; } } elsif (lc $setsock eq 'native') { - @connectMethods = ( 'native' ); + @connectMethods = qw(native); + + } elsif (lc $setsock eq 'eventlog') { + if (eval "use Win32::EventLog; 1") { + @connectMethods = qw(eventlog); + } else { + warnings::warnif "eventlog passed to setlogsock, but operating system isn't Win32-compatible" + } } elsif (lc $setsock eq 'tcp') { if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) { - @connectMethods = ( 'tcp' ); + @connectMethods = qw(tcp); } else { warnings::warnif "tcp passed to setlogsock, but tcp service unavailable"; return undef; @@ -195,7 +232,7 @@ sub setlogsock { } elsif (lc $setsock eq 'udp') { if (getservbyname('syslog', 'udp')) { - @connectMethods = ( 'udp' ); + @connectMethods = qw(udp); } else { warnings::warnif "udp passed to setlogsock, but udp service unavailable"; return undef; @@ -205,10 +242,10 @@ sub setlogsock { @connectMethods = ( 'tcp', 'udp' ); } elsif (lc $setsock eq 'console') { - @connectMethods = ( 'console' ); + @connectMethods = qw(console); } else { - croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'native', 'tcp', 'udp' or 'inet'" + croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'native', 'eventlog', 'tcp', 'udp' or 'inet'" } return 1; @@ -223,7 +260,11 @@ sub syslog { my $fail_time = undef; my $error = $!; - my $facility = $facility; # may need to change temporarily. + # if $ident is undefined, it means openlog() wasn't previously called + # so do it now in order to have sensible defaults + openlog() unless $ident; + + local $facility = $facility; # may need to change temporarily. croak "syslog: expecting argument \$priority" unless defined $priority; croak "syslog: expecting argument \$format" unless defined $mask; @@ -256,15 +297,12 @@ sub syslog { $numfac = xlate($facility); } - # if no identifiant, set up a default one - $ident ||= basename($0) || getlogin() || getpwuid($<) || 'syslog'; - connect_log() unless $connected; if ($mask =~ /%m/) { # escape percent signs for sprintf() $error =~ s/%/%%/g if @_; - # replace %m with $err, if preceded by an even number of percent signs + # replace %m with $error, if preceded by an even number of percent signs $mask =~ s/(?($buf, $numpri)) { + if ($syslog_send->($buf, $numpri, $numfac)) { $transmit_ok++; return 1; } @@ -371,8 +413,8 @@ sub _syslog_send_socket { sub _syslog_send_native { my ($buf, $numpri) = @_; - eval { syslog_xs($numpri, $buf) }; - return $@ ? 0 : 1; + syslog_xs($numpri, $buf); + return 1; } @@ -420,7 +462,7 @@ sub connect_log { $transmit_ok = 0; if ($connected) { $current_proto = $proto; - my($old) = select(SYSLOG); $| = 1; select($old); + my ($old) = select(SYSLOG); $| = 1; select($old); } else { @fallbackMethods = (); $err_sub->(join "\n\t- ", "no connection to syslog available", @errs); @@ -460,8 +502,9 @@ sub connect_tcp { push @$errs, "tcp socket: $!"; return 0; } + setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1); - setsockopt(SYSLOG, &IPPROTO_TCP, &TCP_NODELAY, 1); + setsockopt(SYSLOG, IPPROTO_TCP, TCP_NODELAY, 1); if (!connect(SYSLOG, $addr)) { push @$errs, "tcp connect: $!"; return 0; @@ -530,7 +573,7 @@ sub connect_stream { push @$errs, "stream $syslog_path is not writable"; return 0; } - if (!open(SYSLOG, ">" . $syslog_path)) { + if (!sysopen(SYSLOG, $syslog_path, 0400, O_WRONLY)) { push @$errs, "stream can't open $syslog_path: $!"; return 0; } @@ -562,6 +605,7 @@ sub connect_unix { push @$errs, "unix stream socket: $!"; return 0; } + if (!connect(SYSLOG, $addr)) { if (!socket(SYSLOG, AF_UNIX, SOCK_DGRAM, 0)) { push @$errs, "unix dgram socket: $!"; @@ -598,6 +642,15 @@ sub connect_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') { @@ -608,7 +661,7 @@ sub connect_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 @@ -617,10 +670,12 @@ sub connect_console { sub connection_ok { 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, 0.25; return ($ret ? 0 : 1); } @@ -628,8 +683,12 @@ sub disconnect_log { $connected = 0; $syslog_send = undef; - if($current_proto eq 'native') { - eval { close_xs() }; + 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; } @@ -646,7 +705,7 @@ Sys::Syslog - Perl interface to the UNIX syslog(3) calls =head1 VERSION -Version 0.18 +Version 0.19 =head1 SYNOPSIS @@ -654,7 +713,6 @@ Version 0.18 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 syslog $priority, $format, @args; $oldmask = setlogmask $mask_priority; @@ -667,6 +725,9 @@ C is an interface to the UNIX C program. Call C with a string priority and a list of C args just like C. +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 @@ -770,7 +831,10 @@ 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. +facilities can be given as strings or as macros. When using the C +mechanism, priorities C and C are mapped to event type +C, C and C to C and C to +C to C. If you didn't use C before using C, C will try to guess the C<$ident> by extracting the shortest prefix of @@ -873,6 +937,11 @@ For example Solaris and IRIX system may prefer C<"stream"> instead of C<"unix">. C<"console"> - send messages directly to the console, as for the C<"cons"> option of C. +=item * + +C<"eventlog"> - send messages to the Win32 events logger (Win32 only; +added in C 0.19). + =back A reference to an array can also be passed as the first parameter. @@ -914,8 +983,37 @@ Closes the log file and returns true on success. =back +=head1 THE RULES OF SYS::SYSLOG + +I +You do not call C. + +I +You B call C. + +I +The program crashes, Cs, calls C, the log is over. + +I +One facility, one priority. + +I +One log at a time. + +I +No C before C. + +I +Logs will go on as long as they have to. + +I +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); @@ -923,11 +1021,13 @@ Closes the log file and returns true on success. syslog('debug', 'this is the last test'); - setlogsock('unix'); +Another example: + openlog("$program $$", 'ndelay', 'user'); syslog('notice', 'fooprogram: this is really done'); - setlogsock('inet'); +Example of use of C<%m>: + $! = 55; syslog('info', 'problem was %m'); # %m == $! in syslog(3) @@ -947,6 +1047,10 @@ Log to UDP port on C<$remotehost> instead of logging locally: =item * +C - audit daemon (IRIX); falls back to C + +=item * + C - security/authorization messages =item * @@ -955,6 +1059,10 @@ C - security/authorization messages (private) =item * +C - C output (FreeBSD); falls back to C + +=item * + C - clock daemons (B and B) =item * @@ -971,11 +1079,16 @@ C - kernel messages =item * -C - installer subsystem +C - installer subsystem (Mac OS X); falls back to C =item * -C - launchd - general bootstrap daemon (Mac OS X) +C - launchd - general bootstrap daemon (Mac OS X); +falls back to C + +=item * + +C - logalert facility; falls back to C =item * @@ -991,7 +1104,7 @@ C - mail subsystem =item * -C - NetInfo subsystem (Mac OS X) +C - NetInfo subsystem (Mac OS X); falls back to C =item * @@ -999,11 +1112,22 @@ C - USENET news subsystem =item * -C - Remote Access Service (VPN / PPP) (Mac OS X) +C - NTP subsystem (FreeBSD, NetBSD); falls back to C + +=item * + +C - Remote Access Service (VPN / PPP) (Mac OS X); +falls back to C =item * -C - remote authentication/authorization (Mac OS X) +C - remote authentication/authorization (Mac OS X); +falls back to C + +=item * + +C - security subsystems (firewalling, etc.) (FreeBSD); +falls back to C =item * @@ -1061,57 +1185,63 @@ C - debug-level message =head1 DIAGNOSTICS -=over 4 +=over -=item Invalid argument passed to setlogsock +=item C B<(F)> You gave C an invalid value for C<$sock_type>. -=item no connection to syslog available +=item C + +B<(W)> You asked C to use the Win32 event logger but the +operating system running the program isn't Win32 or does not provides Win32 +facilities. + +=item C B<(F)> C failed to connect to the specified socket. -=item stream passed to setlogsock, but %s is not writable +=item C 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 +=item C 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 +=item C B<(W)> You asked C to use a TCP socket, but the service is not available on the system. -=item syslog: expecting argument %s +=item C B<(F)> You forgot to give C the indicated argument. -=item syslog: invalid level/facility: %s +=item C B<(F)> You specified an invalid level or facility. -=item syslog: too many levels given: %s +=item C B<(F)> You specified too many levels. -=item syslog: too many facilities given: %s +=item C B<(F)> You specified too many facilities. -=item syslog: level must be given +=item C B<(F)> You forgot to specify a level. -=item udp passed to setlogsock, but udp service unavailable +=item C 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 +=item C B<(W)> You asked C to use a UNIX socket, but C was unable to find an appropriate an appropriate device. @@ -1121,6 +1251,8 @@ was unable to find an appropriate an appropriate device. =head1 SEE ALSO +=head2 Manual Pages + L SUSv3 issue 6, IEEE Std 1003.1, 2004 edition, @@ -1132,6 +1264,9 @@ L Solaris 10 documentation on syslog, L +IRIX 6.4 documentation on syslog, +L + AIX 5L 5.3 documentation on syslog, L @@ -1144,43 +1279,58 @@ L +=head2 RFCs + I, L -- Please note that this is an informational RFC, and therefore does not specify a standard of any kind. I, L +=head2 Articles + I, L +=head2 Event Log -=head1 AUTHORS +Windows Event Log, +L -Tom Christiansen EFE and Larry Wall -EFE. + +=head1 AUTHORS & ACKNOWLEDGEMENTS + +Tom Christiansen EFE and Larry Wall +EFE. UNIX domain sockets added by Sean Robinson -EFE with support from Tim Bunce -EFE and the C mailing list. +EFE with support from Tim Bunce +EFE and the C mailing list. Dependency on F replaced with XS code by Tom Hughes -EFE. +EFE. -Code for Cs regenerated by Nicholas Clark EFE. +Code for Cs regenerated by Nicholas Clark EFE. Failover to different communication modes by Nick Williams -EFE. +EFE. + +Extracted from core distribution for publishing on the CPAN by +SEbastien Aperghis-Tramoni Esebastien (at) aperghis.netE. XS code for using native C functions borrowed from C>, -written by Marcus Harnisch EFE. +written by Marcus Harnisch EFE. -Extracted from core distribution for publishing on the CPAN by -SEbastien Aperghis-Tramoni Esebastien@aperghis.netE. +Yves Orton suggested and helped for making C use the native +event logger under Win32 systems. + +Jerry D. Hedden and Reini Urban provided greatly appreciated help to +debug and polish C under Cygwin. =head1 BUGS Please report any bugs or feature requests to -C, or through the web interface at +C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. @@ -1229,3 +1379,55 @@ 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 + + +* 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 +- L +- L + + +* 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 + +=end comment diff --git a/ext/Sys/Syslog/Syslog.xs b/ext/Sys/Syslog/Syslog.xs index 61712d4..7d72c64 100644 --- a/ext/Sys/Syslog/Syslog.xs +++ b/ext/Sys/Syslog/Syslog.xs @@ -5,10 +5,19 @@ # include "ppport.h" #endif +#ifndef HAVE_SYSLOG +#define HAVE_SYSLOG 1 +#endif + #ifdef I_SYSLOG #include #endif +#if defined(_WIN32) && !defined(__CYGWIN__) +#undef HAVE_SYSLOG +#include "fallback/syslog.h" +#endif + static SV *ident_svptr; #include "const-c.inc" @@ -88,6 +97,7 @@ LOG_UPTO(pri) OUTPUT: RETVAL +#ifdef HAVE_SYSLOG void openlog_xs(ident, option, facility) @@ -125,3 +135,4 @@ closelog_xs() if (SvREFCNT(ident_svptr)) SvREFCNT_dec(ident_svptr); +#endif /* HAVE_SYSLOG */ diff --git a/ext/Sys/Syslog/fallback/const-c.inc b/ext/Sys/Syslog/fallback/const-c.inc index b0bd772..8fb8cb6 100644 --- a/ext/Sys/Syslog/fallback/const-c.inc +++ b/ext/Sys/Syslog/fallback/const-c.inc @@ -24,7 +24,7 @@ static int constant_7 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - LOG_ERR LOG_FTP LOG_LPR LOG_PID LOG_RAS */ + LOG_ERR LOG_FTP LOG_LPR LOG_NTP LOG_PID LOG_RAS */ /* Offset 4 gives the best switch position. */ switch (name[4]) { case 'E': @@ -60,6 +60,18 @@ constant_7 (pTHX_ const char *name, IV *iv_return) { #endif } break; + case 'N': + if (memEQ(name, "LOG_NTP", 7)) { + /* ^ */ +#ifdef LOG_NTP + *iv_return = LOG_NTP; + return PERL_constant_ISIV; +#else + *iv_return = LOG_DAEMON; + return PERL_constant_ISIV; +#endif + } + break; case 'P': if (memEQ(name, "LOG_PID", 7)) { /* ^ */ @@ -78,7 +90,8 @@ constant_7 (pTHX_ const char *name, IV *iv_return) { *iv_return = LOG_RAS; return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + *iv_return = LOG_AUTH; + return PERL_constant_ISIV; #endif } break; @@ -154,7 +167,8 @@ constant_8 (pTHX_ const char *name, IV *iv_return) { *iv_return = LOG_LFMT; return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + *iv_return = LOG_USER; + return PERL_constant_ISIV; #endif } break; @@ -221,34 +235,34 @@ static int constant_9 (pTHX_ const char *name, IV *iv_return, const char **pv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - LOG_ALERT LOG_DEBUG LOG_EMERG _PATH_LOG */ - /* Offset 4 gives the best switch position. */ - switch (name[4]) { - case 'A': - if (memEQ(name, "LOG_ALERT", 9)) { - /* ^ */ -#ifdef LOG_ALERT - *iv_return = LOG_ALERT; + LOG_ALERT LOG_AUDIT LOG_DEBUG LOG_EMERG _PATH_LOG */ + /* Offset 5 gives the best switch position. */ + switch (name[5]) { + case 'E': + if (memEQ(name, "LOG_DEBUG", 9)) { + /* ^ */ +#ifdef LOG_DEBUG + *iv_return = LOG_DEBUG; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; - case 'D': - if (memEQ(name, "LOG_DEBUG", 9)) { - /* ^ */ -#ifdef LOG_DEBUG - *iv_return = LOG_DEBUG; + case 'L': + if (memEQ(name, "LOG_ALERT", 9)) { + /* ^ */ +#ifdef LOG_ALERT + *iv_return = LOG_ALERT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; - case 'E': + case 'M': if (memEQ(name, "LOG_EMERG", 9)) { - /* ^ */ + /* ^ */ #ifdef LOG_EMERG *iv_return = LOG_EMERG; return PERL_constant_ISIV; @@ -257,14 +271,26 @@ constant_9 (pTHX_ const char *name, IV *iv_return, const char **pv_return) { #endif } break; - case 'H': + case 'U': + if (memEQ(name, "LOG_AUDIT", 9)) { + /* ^ */ +#ifdef LOG_AUDIT + *iv_return = LOG_AUDIT; + return PERL_constant_ISIV; +#else + *iv_return = LOG_AUTH; + return PERL_constant_ISIV; +#endif + } + break; + case '_': if (memEQ(name, "_PATH_LOG", 9)) { - /* ^ */ + /* ^ */ #ifdef _PATH_LOG *pv_return = _PATH_LOG; return PERL_constant_ISPV; #else - *pv_return = ""; + *pv_return = "/var/run/syslog"; return PERL_constant_ISPV; #endif } @@ -453,12 +479,13 @@ static int constant_11 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. - LOG_FACMASK LOG_INSTALL LOG_LAUNCHD LOG_NETINFO LOG_PRIMASK LOG_WARNING */ - /* Offset 4 gives the best switch position. */ - switch (name[4]) { - case 'F': + LOG_CONSOLE LOG_FACMASK LOG_INSTALL LOG_LAUNCHD LOG_NETINFO LOG_PRIMASK + LOG_WARNING */ + /* Offset 6 gives the best switch position. */ + switch (name[6]) { + case 'C': if (memEQ(name, "LOG_FACMASK", 11)) { - /* ^ */ + /* ^ */ #ifdef LOG_FACMASK *iv_return = LOG_FACMASK; return PERL_constant_ISIV; @@ -468,57 +495,73 @@ constant_11 (pTHX_ const char *name, IV *iv_return) { } break; case 'I': - if (memEQ(name, "LOG_INSTALL", 11)) { - /* ^ */ -#ifdef LOG_INSTALL - *iv_return = LOG_INSTALL; + if (memEQ(name, "LOG_PRIMASK", 11)) { + /* ^ */ +#ifdef LOG_PRIMASK + *iv_return = LOG_PRIMASK; return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + *iv_return = 7; + return PERL_constant_ISIV; #endif } break; - case 'L': - if (memEQ(name, "LOG_LAUNCHD", 11)) { - /* ^ */ -#ifdef LOG_LAUNCHD - *iv_return = LOG_LAUNCHD; + case 'N': + if (memEQ(name, "LOG_CONSOLE", 11)) { + /* ^ */ +#ifdef LOG_CONSOLE + *iv_return = LOG_CONSOLE; return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + *iv_return = LOG_USER; + return PERL_constant_ISIV; #endif } break; - case 'N': - if (memEQ(name, "LOG_NETINFO", 11)) { - /* ^ */ -#ifdef LOG_NETINFO - *iv_return = LOG_NETINFO; + case 'R': + if (memEQ(name, "LOG_WARNING", 11)) { + /* ^ */ +#ifdef LOG_WARNING + *iv_return = LOG_WARNING; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; - case 'P': - if (memEQ(name, "LOG_PRIMASK", 11)) { - /* ^ */ -#ifdef LOG_PRIMASK - *iv_return = LOG_PRIMASK; + case 'S': + if (memEQ(name, "LOG_INSTALL", 11)) { + /* ^ */ +#ifdef LOG_INSTALL + *iv_return = LOG_INSTALL; return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + *iv_return = LOG_USER; + return PERL_constant_ISIV; #endif } break; - case 'W': - if (memEQ(name, "LOG_WARNING", 11)) { - /* ^ */ -#ifdef LOG_WARNING - *iv_return = LOG_WARNING; + case 'T': + if (memEQ(name, "LOG_NETINFO", 11)) { + /* ^ */ +#ifdef LOG_NETINFO + *iv_return = LOG_NETINFO; return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + *iv_return = LOG_DAEMON; + return PERL_constant_ISIV; +#endif + } + break; + case 'U': + if (memEQ(name, "LOG_LAUNCHD", 11)) { + /* ^ */ +#ifdef LOG_LAUNCHD + *iv_return = LOG_LAUNCHD; + return PERL_constant_ISIV; +#else + *iv_return = LOG_DAEMON; + return PERL_constant_ISIV; #endif } break; @@ -545,13 +588,23 @@ use ExtUtils::Constant qw (constant_types C_constant XS_constant); my $types = {map {($_, 1)} qw(IV PV)}; my @names = (qw(LOG_ALERT LOG_AUTH LOG_AUTHPRIV LOG_CONS LOG_CRIT LOG_CRON LOG_DAEMON LOG_DEBUG LOG_EMERG LOG_ERR LOG_FACMASK LOG_FTP - LOG_INFO LOG_INSTALL LOG_KERN LOG_LAUNCHD LOG_LFMT LOG_LOCAL0 - LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4 LOG_LOCAL5 - LOG_LOCAL6 LOG_LOCAL7 LOG_LPR LOG_MAIL LOG_NDELAY LOG_NETINFO - LOG_NEWS LOG_NFACILITIES LOG_NOTICE LOG_NOWAIT LOG_ODELAY - LOG_PERROR LOG_PID LOG_PRIMASK LOG_RAS LOG_REMOTEAUTH LOG_SYSLOG - LOG_USER LOG_UUCP LOG_WARNING), - {name=>"_PATH_LOG", type=>"PV", default=>["PV", "\"\""]}); + LOG_INFO LOG_KERN 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_NOTICE LOG_NOWAIT LOG_ODELAY LOG_PERROR + LOG_PID LOG_SYSLOG LOG_USER LOG_UUCP LOG_WARNING), + {name=>"LOG_AUDIT", type=>"IV", default=>["IV", "LOG_AUTH"]}, + {name=>"LOG_CONSOLE", type=>"IV", default=>["IV", "LOG_USER"]}, + {name=>"LOG_INSTALL", type=>"IV", default=>["IV", "LOG_USER"]}, + {name=>"LOG_LAUNCHD", type=>"IV", default=>["IV", "LOG_DAEMON"]}, + {name=>"LOG_LFMT", type=>"IV", default=>["IV", "LOG_USER"]}, + {name=>"LOG_NETINFO", type=>"IV", default=>["IV", "LOG_DAEMON"]}, + {name=>"LOG_NFACILITIES", type=>"IV", default=>["IV", "30"]}, + {name=>"LOG_NTP", type=>"IV", default=>["IV", "LOG_DAEMON"]}, + {name=>"LOG_PRIMASK", type=>"IV", default=>["IV", "7"]}, + {name=>"LOG_RAS", type=>"IV", default=>["IV", "LOG_AUTH"]}, + {name=>"LOG_REMOTEAUTH", type=>"IV", default=>["IV", "LOG_AUTH"]}, + {name=>"LOG_SECURITY", type=>"IV", default=>["IV", "LOG_AUTH"]}, + {name=>"_PATH_LOG", type=>"PV", default=>["PV", "\"/var/run/syslog\""]}); print constant_types(); # macro defs foreach (C_constant ("Sys::Syslog", 'constant', 'IV', $types, undef, 3, @names) ) { @@ -579,13 +632,33 @@ __END__ return constant_11 (aTHX_ name, iv_return); break; case 12: - if (memEQ(name, "LOG_AUTHPRIV", 12)) { + /* Names all of length 12. */ + /* LOG_AUTHPRIV LOG_SECURITY */ + /* Offset 8 gives the best switch position. */ + switch (name[8]) { + case 'P': + if (memEQ(name, "LOG_AUTHPRIV", 12)) { + /* ^ */ #ifdef LOG_AUTHPRIV - *iv_return = LOG_AUTHPRIV; - return PERL_constant_ISIV; + *iv_return = LOG_AUTHPRIV; + return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + return PERL_constant_NOTDEF; #endif + } + break; + case 'R': + if (memEQ(name, "LOG_SECURITY", 12)) { + /* ^ */ +#ifdef LOG_SECURITY + *iv_return = LOG_SECURITY; + return PERL_constant_ISIV; +#else + *iv_return = LOG_AUTH; + return PERL_constant_ISIV; +#endif + } + break; } break; case 14: @@ -594,7 +667,8 @@ __END__ *iv_return = LOG_REMOTEAUTH; return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + *iv_return = LOG_AUTH; + return PERL_constant_ISIV; #endif } break; @@ -604,7 +678,8 @@ __END__ *iv_return = LOG_NFACILITIES; return PERL_constant_ISIV; #else - return PERL_constant_NOTDEF; + *iv_return = 30; + return PERL_constant_ISIV; #endif } break; diff --git a/ext/Sys/Syslog/t/00-load.t b/ext/Sys/Syslog/t/00-load.t index 35d9042..188ab12 100644 --- a/ext/Sys/Syslog/t/00-load.t +++ b/ext/Sys/Syslog/t/00-load.t @@ -1,9 +1,9 @@ -#!perl -T - +#!perl -wT +use strict; use Test::More tests => 1; BEGIN { use_ok( 'Sys::Syslog' ); } -#diag( "Testing Sys::Syslog $Sys::Syslog::VERSION, Perl $], $^X" ); +diag( "Testing Sys::Syslog $Sys::Syslog::VERSION, Perl $], $^X" ); diff --git a/ext/Sys/Syslog/t/constants.t b/ext/Sys/Syslog/t/constants.t index b484295..c2002fb 100644 --- a/ext/Sys/Syslog/t/constants.t +++ b/ext/Sys/Syslog/t/constants.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!perl -wT use strict; use File::Spec; use Test::More; diff --git a/ext/Sys/Syslog/t/syslog.t b/ext/Sys/Syslog/t/syslog.t index 7e9e2ad..5a2fc3e 100755 --- a/ext/Sys/Syslog/t/syslog.t +++ b/ext/Sys/Syslog/t/syslog.t @@ -1,7 +1,7 @@ -#!/usr/bin/perl -T +#!perl -T BEGIN { - if( $ENV{PERL_CORE} ) { + if ($ENV{PERL_CORE}) { chdir 't'; @INC = '../lib'; } @@ -19,18 +19,26 @@ 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); -# check that the module is at least available -plan skip_all => "Sys::Syslog was not build" - unless $Config{'extensions'} =~ /\bSyslog\b/; +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/; +} # we also need Socket plan skip_all => "Socket was not build" - unless $Config{'extensions'} =~ /\bSocket\b/; + unless $Config{'extensions'} =~ /\bSocket\b/; my $tests; plan tests => $tests; -BEGIN { $tests = 1 } +# 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'); @@ -103,110 +111,124 @@ SKIP: { } -BEGIN { $tests += 20 * 6 } +BEGIN { $tests += 20 * 7 } # try to open a syslog using all the available connection methods -for my $sock_type (qw(native stream unix inet tcp udp)) { +my @passed = (); +for my $sock_type (qw(native eventlog unix stream inet tcp udp)) { SKIP: { + skip "the 'unix' mechanism works, so the tests will likely fail with the 'stream' mechanism", 20 + if $sock_type eq 'stream' and grep {/unix/} @passed; + # setlogsock() called with an arrayref $r = eval { setlogsock([$sock_type]) } || 0; skip "can't use '$sock_type' socket", 20 unless $r; - is( $@, '', "setlogsock() called with ['$sock_type']" ); - ok( $r, "setlogsock() should return true: '$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", 18 unless $r; - is( $@, '', "setlogsock() called with '$sock_type'" ); - ok( $r, "setlogsock() should return true: '$r'" ); + is( $@, '', "[$sock_type] setlogsock() called with '$sock_type'" ); + ok( $r, "[$sock_type] setlogsock() should return true: '$r'" ); # openlog() without option NDELAY $r = eval { openlog('perl', '', 'local0') } || 0; skip "can't connect to syslog", 16 if $@ =~ /^no connection to syslog available/; - is( $@, '', "openlog() called with facility 'local0' and without option 'ndelay'" ); - ok( $r, "openlog() should return true: '$r'" ); + is( $@, '', "[$sock_type] openlog() called with facility 'local0' and without option 'ndelay'" ); + ok( $r, "[$sock_type] openlog() should return true: '$r'" ); # openlog() with the option NDELAY $r = eval { openlog('perl', 'ndelay', 'local0') } || 0; skip "can't connect to syslog", 14 if $@ =~ /^no connection to syslog available/; - is( $@, '', "openlog() called with facility 'local0' with option 'ndelay'" ); - ok( $r, "openlog() should return true: '$r'" ); + is( $@, '', "[$sock_type] openlog() called with facility 'local0' with option 'ndelay'" ); + ok( $r, "[$sock_type] openlog() should return true: '$r'" ); # syslog() with negative level, should fail $r = eval { syslog(-1, "$test_string by connecting to a $sock_type socket") } || 0; - like( $@, '/^syslog: invalid level\/facility: /', "syslog() called with level -1" ); - ok( !$r, "syslog() should return false: '$r'" ); + like( $@, '/^syslog: invalid level\/facility: /', "[$sock_type] syslog() called with level -1" ); + 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/', "syslog() called with level 'info,notice'" ); - ok( !$r, "syslog() should return false: '$r'" ); + 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/', "syslog() called with level 'info,notice'" ); - ok( !$r, "syslog() should return false: '$r'" ); + like( $@, '/^syslog: too many facilities given: local1/', "[$sock_type] syslog() called with level 'info,notice'" ); + 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 (errno=%m)") } || 0; - is( $@, '', "syslog() called with level 'info' (string)" ); - ok( $r, "syslog() should return true: '$r'" ); + $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 - $r = eval { syslog(LOG_INFO(), "$test_string by connecting to a $sock_type socket (errno=%m)") } || 0; - is( $@, '', "syslog() called with level 'info' (macro)" ); - ok( $r, "syslog() should return true: '$r'" ); - - # syslog() with facility "kern" (as a string), should fail - #$r = eval { syslog('kern', "$test_string by connecting to a $sock_type socket") } || 0; - #like( $@, '/^syslog: invalid level/facility: kern/', "syslog() called with facility 'kern'" ); - #ok( !$r, "syslog() should return false: '$r'" ); + { local $! = 1; + $r = eval { syslog(LOG_INFO(), "$test_string by connecting to a $sock_type socket, setting a fake errno: %m") } || 0; + } + is( $@, '', "[$sock_type] syslog() called with level 'info' (macro)" ); + ok( $r, "[$sock_type] syslog() should return true: '$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'" ); + push @passed, $sock_type; 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'" ); + is( $@, '', "[$sock_type] closelog()" ); + ok( $r, "[$sock_type] closelog() should return true: '$r'" ); } } } BEGIN { $tests += 10 } -# setlogsock() with "stream" and an undef path -$r = eval { setlogsock("stream", undef ) } || ''; -is( $@, '', "setlogsock() called, with 'stream' and an undef path" ); -ok( $r, "setlogsock() should return true: '$r'" ); - -# setlogsock() with "stream" and an empty path -$r = eval { setlogsock("stream", '' ) } || ''; -is( $@, '', "setlogsock() called, with 'stream' and an empty path" ); -ok( !$r, "setlogsock() should return false: '$r'" ); - -# setlogsock() with "stream" and /dev/null -$r = eval { setlogsock("stream", '/dev/null' ) } || ''; -is( $@, '', "setlogsock() called, with 'stream' and '/dev/null'" ); -ok( $r, "setlogsock() should return true: '$r'" ); - -# setlogsock() with "stream" and a non-existing file -$r = eval { setlogsock("stream", 'test.log' ) } || ''; -is( $@, '', "setlogsock() called, with 'stream' and 'test.log' (file does not exist)" ); -ok( !$r, "setlogsock() should return false: '$r'" ); - -# setlogsock() with "stream" and a local file SKIP: { - my $logfile = "test.log"; - open(LOG, ">$logfile") or skip "can't create file '$logfile': $!", 2; - close(LOG); - $r = eval { setlogsock("stream", $logfile ) } || ''; - is( $@, '', "setlogsock() called, with 'stream' and '$logfile' (file exists)" ); + 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; + + # 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'" ); - unlink($logfile); + + # 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); + } } diff --git a/ext/Sys/Syslog/win32/PerlLog.mc b/ext/Sys/Syslog/win32/PerlLog.mc new file mode 100644 index 0000000..3a7c1fd --- /dev/null +++ b/ext/Sys/Syslog/win32/PerlLog.mc @@ -0,0 +1,602 @@ +; // Sys::Syslog Message File 1.0.0 + +MessageIdTypedef = DWORD + +SeverityNames = ( + Success = 0x0:STATUS_SEVERITY_SUCCESS + Informational = 0x1:STATUS_SEVERITY_INFORMATIONAL + Warning = 0x2:STATUS_SEVERITY_WARNING + Error = 0x3:STATUS_SEVERITY_ERROR +) + +LanguageNames = ( English = 0x0409:MSG00409 ) +LanguageNames = ( French = 0x040C:MSG0040C ) + + +; // ================================================================= +; // The following are facility name definitions + +MessageId = 0x0001 +SymbolicName = CAT_KERN +Language = English +Kernel +. +Language = French +Kernel +. + +MessageId = 0x0002 +SymbolicName = CAT_USER +Language = English +User +. +Language = French +User +. + +MessageId = 0x0003 +SymbolicName = CAT_MAIL +Language = English +Mail +. +Language = French +Mail +. + +MessageId = 0x0004 +SymbolicName = CAT_DAEMON +Language = English +Daemon +. +Language = French +Daemon +. + +MessageId = 0x0005 +SymbolicName = CAT_AUTH +Language = English +Auth +. +Language = French +Auth +. + +MessageId = 0x0006 +SymbolicName = CAT_SYSLOG +Language = English +Syslog +. +Language = French +Syslog +. + +MessageId = 0x0007 +SymbolicName = CAT_LPR +Language = English +LPR +. +Language = French +LPR +. + +MessageId = 0x0008 +SymbolicName = CAT_NEWS +Language = English +News +. +Language = French +News +. + +MessageId = 0x0009 +SymbolicName = CAT_UUCP +Language = English +UUCP +. +Language = French +UUCP +. + +MessageId = 0x000a +SymbolicName = CAT_CRON +Language = English +Cron +. +Language = French +Cron +. + +MessageId = 0x000b +SymbolicName = CAT_AUTHPRIV +Language = English +AuthPrivate +. +Language = French +AuthPrivate +. + +MessageId = 0x000c +SymbolicName = CAT_FTP +Language = English +FTP +. +Language = French +FTP +. + +MessageId = 0x000d +SymbolicName = CAT_LOCAL0 +Language = English +Local0 +. +Language = French +Local0 +. + +MessageId = 0x000e +SymbolicName = CAT_LOCAL1 +Language = English +Local1 +. +Language = French +Local1 +. + +MessageId = 0x000f +SymbolicName = CAT_LOCAL2 +Language = English +Local2 +. +Language = French +Local2 +. + +MessageId = 0x0010 +SymbolicName = CAT_LOCAL3 +Language = English +Local3 +. +Language = French +Local3 +. + +MessageId = 0x0011 +SymbolicName = CAT_LOCAL4 +Language = English +Local4 +. +Language = French +Local4 +. + +MessageId = 0x0012 +SymbolicName = CAT_LOCAL5 +Language = English +Local5 +. +Language = French +Local5 +. + +MessageId = 0x0013 +SymbolicName = CAT_LOCAL6 +Language = English +Local6 +. +Language = French +Local6 +. + +MessageId = 0x0014 +SymbolicName = CAT_LOCAL7 +Language = English +Local7 +. +Language = French +Local7 +. + +; // Mac OS X specific facilities ------------------------------------ + +MessageId = 0x0015 +SymbolicName = CAT_NETINFO +Language = English +NetInfo +. +Language = French +NetInfo +. + +MessageId = 0x0016 +SymbolicName = CAT_REMOTEAUTH +Language = English +RemoteAuth +. +Language = French +RemoteAuth +. + +MessageId = 0x0017 +SymbolicName = CAT_RAS +Language = English +RAS +. +Language = French +RAS +. + +MessageId = 0x0018 +SymbolicName = CAT_INSTALL +Language = English +Install +. +Language = French +Install +. + +MessageId = 0x0019 +SymbolicName = CAT_LAUNCHD +Language = English +Launchd +. +Language = French +Launchd +. + +; //modern BSD specific facilities ---------------------------------- + +MessageId = 0x001a +SymbolicName = CAT_CONSOLE +Language = English +Console +. +Language = French +Console +. + +MessageId = 0x001b +SymbolicName = CAT_NTP +Language = English +NTP +. +Language = French +NTP +. + +MessageId = 0x001c +SymbolicName = CAT_SECURITY +Language = English +Security +. +Language = French +Sécurité +. + +; // IRIX specific facilities ---------------------------------------- + +MessageId = 0x001d +SymbolicName = CAT_AUDIT +Language = English +Audit +. +Language = French +Audit +. + +MessageId = 0x001e +SymbolicName = CAT_LFMT +Language = English +LogAlert +. +Language = French +LogAlert +. + + +; // ================================================================= +; // The following are message definitions. + +MessageId = 0x0080 +SymbolicName = MSG_KERNEL +Language = English +Kernel message: %1 +. +Language = French +Message du noyau : %1 +. + + +MessageId = 0x0081 +SymbolicName = MSG_USER +Language = English +User message: %1 +. +Language = French +Message utilisateur : %1 +. + + +MessageId = 0x0082 +SymbolicName = MSG_MAIL +Language = English +Mail subsystem message: %1 +. +Language = French +Message du sous-système de courrier : %1 +. + + +MessageId = 0x0083 +SymbolicName = MSG_DAEMON +Language = English +Message from a system daemon without separate facility value: %1 +. +Language = French +Message d'un daemon sans catégorie spécifique : %1 +. + + +MessageId = 0x0084 +SymbolicName = MSG_AUTH +Language = English +Security/authorization message: %1 +. +Language = French +Message de sécurite ou d'authorisation : %1 +. + + +MessageId = 0x0085 +SymbolicName = MSG_SYSLOG +Language = English +Message generated internally by syslogd: %1 +. +Language = French +Message interne généré par le daemon syslogd : %1 +. + + +MessageId = 0x0086 +SymbolicName = MSG_LPR +Language = English +Line printer subsystem message: %1 +. +Language = French +Message du sous-système d'impression : %1 +. + + +MessageId = 0x0087 +SymbolicName = MSG_NEWS +Language = English +USENET news subsystem message: %1 +. +Language = French +Message du sous-système de nouvelles USENET : %1 +. + + +MessageId = 0x0088 +SymbolicName = MSG_UUCP +Language = English +UUCP subsystem message: %1 +. +Language = French +Message du sous-système UUCP : %1 +. + + +MessageId = 0x0089 +SymbolicName = MSG_CRON +Language = English +Message generated by the clock daemons (cron and at): %1 +. +Language = French +Message généré par les daemons d'exécution programmée (cron et at) : %1 +. + + +MessageId = 0x008A +SymbolicName = MSG_AUTHPRIV +Language = English +Security or authorization private message: %1 +. +Language = French +Message privé de sécurité ou d'authorisation : %1 +. + + +MessageId = 0x008B +SymbolicName = MSG_FTP +Language = English +FTP daemon message: %1 +. +Language = French +Message du daemon FTP : %1 +. + + +MessageId = 0x008C +SymbolicName = MSG_LOCAL0 +Language = English +Local message on channel 0: %1 +. +Language = French +Message local sur le canal 0 : %1 +. + + +MessageId = 0x008D +SymbolicName = MSG_LOCAL1 +Language = English +Local message on channel 1: %1 +. +Language = French +Message local sur le canal 1 : %1 +. + + +MessageId = 0x008E +SymbolicName = MSG_LOCAL2 +Language = English +Local message on channel 2: %1 +. +Language = French +Message local sur le canal 2 : %1 +. + + +MessageId = 0x008F +SymbolicName = MSG_LOCAL3 +Language = English +Local message on channel 3: %1 +. +Language = French +Message local sur le canal 3 : %1 +. + + +MessageId = 0x0090 +SymbolicName = MSG_LOCAL4 +Language = English +Local message on channel 4: %1 +. +Language = French +Message local sur le canal 4 : %1 +. + + +MessageId = 0x0091 +SymbolicName = MSG_LOCAL5 +Language = English +Local message on channel 5: %1 +. +Language = French +Message local sur le canal 5 : %1 +. + + +MessageId = 0x0092 +SymbolicName = MSG_LOCAL6 +Language = English +Local message on channel 6: %1 +. +Language = French +Message local sur le canal 6 : %1 +. + + +MessageId = 0x0093 +SymbolicName = MSG_LOCAL7 +Language = English +Local message on channel 7: %1 +. +Language = French +Message local sur le canal 7 : %1 +. + + +; // Mac OS X specific facilities ------------------------------------ + +MessageId = 0x0094 +SymbolicName = MSG_NETINFO +Language = English +NetInfo subsystem message: %1 +. +Language = French +Message du sous-système NetInfo : %1 +. + + +MessageId = 0x0095 +SymbolicName = MSG_REMOTEAUTH +Language = English +Remote authentication or authorization message: %1 +. +Language = French +Message d'authentification ou d'authorisation distante : %1 +. + + +MessageId = 0x0096 +SymbolicName = MSG_RAS +Language = English +Message generated by the Remote Access Service (VPN / PPP): %1 +. +Language = French +Message généré par le Service d'Accès Distant (Remote Access Service) (VPN / PPP) : %1 +. + + +MessageId = 0x0097 +SymbolicName = MSG_INSTALL +Language = English +Installer subsystem message: %1 +. +Language = French +Message du sous-système d'installation : %1 +. + + +MessageId = 0x0098 +SymbolicName = MSG_LAUNCHD +Language = English +Message generated by launchd, the general bootstrap daemon: %1 +. +Language = French +Message généré par launchd, le daemon générique de démarrage : %1 +. + +; //modern BSD specific facilities ---------------------------------- + +MessageId = 0x0099 +SymbolicName = MSG_CONSOLE +Language = English +Message for the console: %1 +. +Language = French +Message pour la console : %1 +. + + +MessageId = 0x009a +SymbolicName = MSG_NTP +Language = English +NTP subsystem message: %1 +. +Language = French +Message du sous-système NTP : %1 +. + + +MessageId = 0x009b +SymbolicName = MSG_SECURITY +Language = English +Security subsystem message (firewalling, etc.): %1 +. +Language = French +Message du sous-système de sécurité (pare-feu, etc.) : %1 +. + + +; // IRIX specific facilities ---------------------------------------- + +MessageId = 0x009c +SymbolicName = MSG_AUDIT +Language = English +Audit daemon message: %1 +. +Language = French +Message du daemon d'audit NTP : %1 +. + + +MessageId = 0x009d +SymbolicName = MSG_LFMT +Language = English +Logalert facility: %1 +. +Language = French +Message de logalert : %1 +. + diff --git a/ext/Sys/Syslog/win32/PerlLog_RES.uu b/ext/Sys/Syslog/win32/PerlLog_RES.uu new file mode 100644 index 0000000..036cecf --- /dev/null +++ b/ext/Sys/Syslog/win32/PerlLog_RES.uu @@ -0,0 +1,130 @@ +M`````"````#__P``__\```````````````````````"\"P``(````/__"P#_ +M_P$``````#``#`0```````````8````!````&0```$P```"`````B````(0" +M``",````F````*`%``":"```F@@``'@*``"K"```JP@``!`+``"\"```O`@` +M`'P+```8``$`2P!E`'(`;@!E`&P`#0`*```````4``$`50!S`&4`<@`-``H` +M`````!0``0!-`&$`:0!L``T`"@``````&``!`$0`80!E`&T`;P!N``T`"@`` +M````%``!`$$`=0!T`&@`#0`*```````8``$`4P!Y`',`;`!O`&<`#0`*```` +M```0``$`3`!0`%(`#0`*````%``!`$X`90!W`',`#0`*```````4``$`50!5 +M`$,`4``-``H``````!0``0!#`'(`;P!N``T`"@``````(``!`$$`=0!T`&@` +M4`!R`&D`=@!A`'0`90`-``H````0``$`1@!4`%``#0`*````&``!`$P`;P!C +M`&$`;``P``T`"@``````&``!`$P`;P!C`&$`;``Q``T`"@``````&``!`$P` +M;P!C`&$`;``R``T`"@``````&``!`$P`;P!C`&$`;``S``T`"@``````&``! +M`$P`;P!C`&$`;``T``T`"@``````&``!`$P`;P!C`&$`;``U``T`"@`````` +M&``!`$P`;P!C`&$`;``V``T`"@``````&``!`$P`;P!C`&$`;``W``T`"@`` +M````&``!`$X`90!T`$D`;@!F`&\`#0`*````(``!`%(`90!M`&\`=`!E`$$` +M=0!T`&@`#0`*```````0``$`4@!!`%,`#0`*````&``!`$D`;@!S`'0`80!L +M`&P`#0`*````&``!`$P`80!U`&X`8P!H`&0`#0`*````-``!`$T`90!S`',` +M80!G`&4`(`!D`'4`(`!N`&\`>0!A`'4`(``Z`"``)0`Q``T`"@```#P``0!- +M`&4`0!S`'0`I@-M`&4`(`!D`&4`(`!C`&\`=0!R`'(`:0!E`'(`(``Z`"`` +M)0`Q``T`"@``````<``!`$T`90!S`',`80!G`&4`(`!D`"<`=0!N`"``9`!A +M`&4`;0!O`&X`(`!S`&$`;@!S`"``8P!A`'0`F`-G`&\`<@!I`&4`(`!S`'`` +MF`-C`&D`9@!I`'$`=0!E`"``.@`@`"4`,0`-``H``````&```0!-`&4`0!S`&P`;P!G`&0`(``Z +M`"``)0`Q``T`"@```%P``0!-`&4`0!S`'0`I@-M`&4`(`!D`"<`:0!M`'``<@!E`',`0!S`'0`90!M`"`` +M;0!E`',`0!S`'0`90!M`"``9`!A`&4`;0!O`&X` +M(`!W`&D`=`!H`&\`=0!T`"``0!S`'0`90!M`"``;0!E`',`0!S`'0`90!M`"``;0!E`',`0!S`'0`90!M`"``;0!E`',`@!A`'0`:0!O`&X`(`!M`&4`0`@ +M`&P`80!U`&X`8P!H`&0`+``@`'0`:`!E`"``9P!E`&X`90!R`&$`;``@`&(` +M;P!O`'0`\6B=K+4XDX[6Z)VLM3B5)I8VC;RU.)``````````!010`` +M3`$"`!LK3D4``````````.``#B$+`0<````````<```````````````0```` +M$```````8``0`````@``!``````````$``````````!``````@``IAX```(` +M`````!```!``````$```$````````!```````````````````````````!`` +M`+`8`````````````````````````#````@````````````````````````` +M```````````````````````````````````````````````````````````` +M`````````````````````````"YR`"8`V,`=0!T +M`&D`;P!N`"``<`!R`&\`9P!R`&$`;0!M`)@#90`@`"@`8P!R`&\`;@`@`&4` +M=``@`&$`=``I`"``.@`@`"4`,0`-``H```!L``$`30!E`',`0!S`&P`;P!G``T`"@`````` +M$``!`$P`4`!2``T`"@```!0``0!.`&4`=P!S``T`"@``````%``!`%4`50!# +M`%``#0`*```````4``$`0P!R`&\`;@`-``H``````"```0!!`'4`=`!H`%`` +M<@!I`'8`80!T`&4`#0`*````$``!`$8`5`!0``T`"@```!@``0!,`&\`8P!A +M`&P`,``-``H``````!@``0!,`&\`8P!A`&P`,0`-``H``````!@``0!,`&\` +M8P!A`&P`,@`-``H``````!@``0!,`&\`8P!A`&P`,P`-``H``````!@``0!, +M`&\`8P!A`&P`-``-``H``````!@``0!,`&\`8P!A`&P`-0`-``H``````!@` +M`0!,`&\`8P!A`&P`-@`-``H``````!@``0!,`&\`8P!A`&P`-P`-``H````` +M`!@``0!.`&4`=`!)`&X`9@!O``T`"@```"```0!2`&4`;0!O`'0`90!!`'4` +M=`!H``T`"@``````$``!`%(`00!3``T`"@```!@``0!)`&X`0`@`'8`80!L`'4`90`Z`"`` +M)0`Q``T`"@``````4``!`%,`90!C`'4`<@!I`'0`>0`O`&$`=0!T`&@`;P!R +M`&D`>@!A`'0`:0!O`&X`(`!M`&4`0`@`&(`>0`@`',`>0!S`&P`;P!G`&0`.@`@`"4` +M,0`-``H```!0``$`3`!I`&X`90`@`'``<@!I`&X`=`!E`'(`(`!S`'4`8@!S +M`'D`0!S`'0`90!M`"``;0!E`',`0`@`'0`:`!E`"``8P!L`&\`8P!K`"``9`!A`&4`;0!O`&X````````````````````````````````````````` diff --git a/ext/Sys/Syslog/win32/Win32.pm b/ext/Sys/Syslog/win32/Win32.pm new file mode 100644 index 0000000..70caf33 --- /dev/null +++ b/ext/Sys/Syslog/win32/Win32.pm @@ -0,0 +1,283 @@ +package Sys::Syslog::Win32; +use strict; +use warnings; +use Carp; +use File::Spec; + +# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING === +# +# This file was generated by Sys-Syslog/win32/compile.pl on Wed Aug 22 01:33:58 2007 +# Any changes being made here will be lost the next time Sys::Syslog +# is installed. +# +# Do NOT USE THIS MODULE DIRECTLY: this is a utility module for Sys::Syslog. +# It may change at any time to fit the needs of Sys::Syslog therefore no +# warranty is made WRT to its API. You Have Been Warned. +# +# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING === + +our $Source; +my $logger; +my $Registry; + +use Win32::EventLog; +use Win32::TieRegistry 0.20 ( + TiedRef => \$Registry, + Delimiter => "/", + ArrayValues => 1, + SplitMultis => 1, + AllowLoad => 1, + qw( + REG_SZ + REG_EXPAND_SZ + REG_DWORD + REG_BINARY + REG_MULTI_SZ + KEY_READ + KEY_WRITE + KEY_ALL_ACCESS + ), +); + +my $is_Cygwin = $^O =~ /Cygwin/i; +my $is_Win32 = $^O =~ /Win32/i; + +my %const = ( + CAT_KERN => 1, + CAT_USER => 2, + CAT_MAIL => 3, + CAT_DAEMON => 4, + CAT_AUTH => 5, + CAT_SYSLOG => 6, + CAT_LPR => 7, + CAT_NEWS => 8, + CAT_UUCP => 9, + CAT_CRON => 10, + CAT_AUTHPRIV => 11, + CAT_FTP => 12, + CAT_LOCAL0 => 13, + CAT_LOCAL1 => 14, + CAT_LOCAL2 => 15, + CAT_LOCAL3 => 16, + CAT_LOCAL4 => 17, + CAT_LOCAL5 => 18, + CAT_LOCAL6 => 19, + CAT_LOCAL7 => 20, + CAT_NETINFO => 21, + CAT_REMOTEAUTH => 22, + CAT_RAS => 23, + CAT_INSTALL => 24, + CAT_LAUNCHD => 25, + CAT_CONSOLE => 26, + CAT_NTP => 27, + CAT_SECURITY => 28, + CAT_AUDIT => 29, + CAT_LFMT => 30, + MSG_KERNEL => 128, + MSG_USER => 129, + MSG_MAIL => 130, + MSG_DAEMON => 131, + MSG_AUTH => 132, + MSG_SYSLOG => 133, + MSG_LPR => 134, + MSG_NEWS => 135, + MSG_UUCP => 136, + MSG_CRON => 137, + MSG_AUTHPRIV => 138, + MSG_FTP => 139, + MSG_LOCAL0 => 140, + MSG_LOCAL1 => 141, + MSG_LOCAL2 => 142, + MSG_LOCAL3 => 143, + MSG_LOCAL4 => 144, + MSG_LOCAL5 => 145, + MSG_LOCAL6 => 146, + MSG_LOCAL7 => 147, + MSG_NETINFO => 148, + MSG_REMOTEAUTH => 149, + MSG_RAS => 150, + MSG_INSTALL => 151, + MSG_LAUNCHD => 152, + MSG_CONSOLE => 153, + MSG_NTP => 154, + MSG_SECURITY => 155, + MSG_AUDIT => 156, + MSG_LFMT => 157, + STATUS_SEVERITY_SUCCESS => 0, + STATUS_SEVERITY_INFORMATIONAL => 1, + STATUS_SEVERITY_WARNING => 2, + STATUS_SEVERITY_ERROR => 3, + +); + +my %id2name = ( + Sys::Syslog::LOG_KERN() => 'KERN', + Sys::Syslog::LOG_USER() => 'USER', + Sys::Syslog::LOG_MAIL() => 'MAIL', + Sys::Syslog::LOG_DAEMON() => 'DAEMON', + Sys::Syslog::LOG_AUTH() => 'AUTH', + Sys::Syslog::LOG_SYSLOG() => 'SYSLOG', + Sys::Syslog::LOG_LPR() => 'LPR', + Sys::Syslog::LOG_NEWS() => 'NEWS', + Sys::Syslog::LOG_UUCP() => 'UUCP', + Sys::Syslog::LOG_CRON() => 'CRON', + Sys::Syslog::LOG_AUTHPRIV() => 'AUTHPRIV', + Sys::Syslog::LOG_FTP() => 'FTP', + Sys::Syslog::LOG_LOCAL0() => 'LOCAL0', + Sys::Syslog::LOG_LOCAL1() => 'LOCAL1', + Sys::Syslog::LOG_LOCAL2() => 'LOCAL2', + Sys::Syslog::LOG_LOCAL3() => 'LOCAL3', + Sys::Syslog::LOG_LOCAL4() => 'LOCAL4', + Sys::Syslog::LOG_LOCAL5() => 'LOCAL5', + Sys::Syslog::LOG_LOCAL6() => 'LOCAL6', + Sys::Syslog::LOG_LOCAL7() => 'LOCAL7', + Sys::Syslog::LOG_NETINFO() => 'NETINFO', + Sys::Syslog::LOG_REMOTEAUTH() => 'REMOTEAUTH', + Sys::Syslog::LOG_RAS() => 'RAS', + Sys::Syslog::LOG_INSTALL() => 'INSTALL', + Sys::Syslog::LOG_LAUNCHD() => 'LAUNCHD', + Sys::Syslog::LOG_CONSOLE() => 'CONSOLE', + Sys::Syslog::LOG_NTP() => 'NTP', + Sys::Syslog::LOG_SECURITY() => 'SECURITY', + Sys::Syslog::LOG_AUDIT() => 'AUDIT', + Sys::Syslog::LOG_LFMT() => 'LFMT', + +); + +my @priority2eventtype = ( + EVENTLOG_ERROR_TYPE(), # LOG_EMERG + EVENTLOG_ERROR_TYPE(), # LOG_ALERT + EVENTLOG_ERROR_TYPE(), # LOG_CRIT + EVENTLOG_ERROR_TYPE(), # LOG_ERR + EVENTLOG_WARNING_TYPE(), # LOG_WARNING + EVENTLOG_WARNING_TYPE(), # LOG_NOTICE + EVENTLOG_INFORMATION_TYPE(), # LOG_INFO + EVENTLOG_INFORMATION_TYPE(), # LOG_DEBUG +); + + +# +# _install() +# -------- +# Used to set up a connection to the eventlog. +# +sub _install { + return $logger if $logger; + + # can't just use basename($0) here because Win32 path often are a + # a mix of / and \, and File::Basename::fileparse() can't handle that, + # while File::Spec::splitpath() can.. Go figure.. + my (undef, undef, $basename) = File::Spec->splitpath($0); + ($Source) ||= $basename; + + $Source.=" [SSW:1.0.1]"; + + #$Registry->Delimiter("/"); # is this needed? + my $root = 'LMachine/SYSTEM/CurrentControlSet/Services/Eventlog/Application/'; + my $dll = 'Sys/Syslog/PerlLog.dll'; + + if (!$Registry->{$root.$Source} || + !$Registry->{$root.$Source.'/CategoryMessageFile'}[0] || + !-e $Registry->{$root.$Source.'/CategoryMessageFile'}[0] ) + { + + # find the resource DLL, which should be along Syslog.dll + my ($file) = grep { -e $_ } map { ("$_/$dll" => "$_/auto/$dll") } @INC; + $dll = $file if $file; + + # on Cygwin, convert the Unix path into absolute Windows path + if ($is_Cygwin) { + if ($] > 5.009005) { + chomp($file = Cygwin::posix_to_win_path($file, 1)); + } + else { + local $ENV{PATH} = ''; + chomp($dll = `/usr/bin/cygpath --absolute --windows "$dll"`); + } + } + + $dll =~ s![\\/]+!\\!g; # must be backslashes! + die "fatal: Can't find resource DLL for Sys::Syslog\n" if !$dll; + + $Registry->{$root.$Source} = { + '/EventMessageFile' => [ $dll, REG_EXPAND_SZ ], + '/CategoryMessageFile' => [ $dll, REG_EXPAND_SZ ], + '/CategoryCount' => [ '0x0000001e', REG_DWORD ], + #'/TypesSupported' => [ '0x0000001e', REG_DWORD ], + }; + + warn "Configured eventlog to use $dll for $Source\n" if $Sys::Syslog::DEBUG; + } + + #Carp::confess("Registry has the wrong value for '$Source', possibly mismatched dll!\nMine:$dll\nGot :$Registry->{$root.$Source.'/CategoryMessageFile'}[0]\n") + # if $Registry->{$root.$Source.'/CategoryMessageFile'}[0] ne $dll; + + # we really should do something useful with this but for now + # we set it to "" to prevent Win32::EventLog from warning + my $host = ""; + + $logger = Win32::EventLog->new($Source, $host) + or Carp::confess("Failed to connect to the '$Source' event log"); + + return $logger; +} + + +# +# _syslog_send() +# ------------ +# Used to convert syslog messages into eventlog messages +# +sub _syslog_send { + my ($buf, $numpri, $numfac) = @_; + $numpri ||= EVENTLOG_INFORMATION_TYPE(); + $numfac ||= Sys::Syslog::LOG_USER(); + my $name = $id2name{$numfac}; + + my $opts = { + EventType => $priority2eventtype[$numpri], + EventID => $const{"MSG_$name"}, + Category => $const{"CAT_$name"}, + Strings => "$buf\0", + Data => "", + }; + + if ($Sys::Syslog::DEBUG) { + require Data::Dumper; + warn Data::Dumper->Dump( + [$numpri, $numfac, $name, $opts], + [qw(numpri numfac name opts)] + ); + } + + return $logger->Report($opts); +} + + +=head1 NAME + +Sys::Syslog::Win32 - Win32 support for Sys::Syslog + +=head1 DESCRIPTION + +This module is a back-end plugin for C, for supporting the Win32 +event log. It is not expected to be directly used by any module other than +C therefore it's API may change at any time and no warranty is +made with regards to backward compatibility. You Have Been Warned. + +=head1 SEE ALSO + +L + +=head1 AUTHORS + +SEbastien Aperghis-Tramoni and Yves Orton + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1; diff --git a/ext/Sys/Syslog/win32/compile.pl b/ext/Sys/Syslog/win32/compile.pl new file mode 100644 index 0000000..8502309 --- /dev/null +++ b/ext/Sys/Syslog/win32/compile.pl @@ -0,0 +1,277 @@ +#!perl +use strict; +use warnings; +use File::Basename; +use File::Copy; +use File::Path; + +my $name = shift || 'PerlLog'; + +# get the version from the message file +open(my $msgfh, '<', "$name.mc") or die "fatal: Can't read file '$name.mc': $!\n"; +my $top = <$msgfh>; +close($msgfh); + +my ($version) = $top =~ /Sys::Syslog Message File (\d+\.\d+\.\d+)/ + or die "error: File '$name.mc' doesn't have a version number\n"; + +# compile the message text files +system("mc -d $name.mc"); +system("rc $name.rc"); +system(qq{ link -nodefaultlib -incremental:no -release /nologo -base:0x60000000 } + .qq{ -comment:"Perl Syslog Message File v$version" } + .qq{ -machine:i386 -dll -noentry -out:$name.dll $name.res }); + +# uuencode the resource file +open(my $rsrc, '<', "$name.RES") or die "fatal: Can't read resource file '$name.RES': $!"; +binmode($rsrc); +my $uudata = pack "u", do { local $/; <$rsrc> }; +close($rsrc); + +open(my $uufh, '>', "$name\_RES.uu") or die "fatal: Can't write file '$name\_RES.uu': $!"; +print $uufh $uudata; +close($uufh); + +# uuencode the DLL +open(my $dll, '<', "$name.dll") or die "fatal: Can't read DLL '$name.dll': $!"; +binmode($dll); +$uudata = pack "u", do { local $/; <$dll> }; +close($dll); + +open($uufh, '>', "$name\_dll.uu") or die "fatal: Can't write file '$name\_dll.uu': $!"; +print $uufh $uudata; +close($uufh); + +# parse the generated header to extract the constants +open(my $header, '<', "$name.h") or die "fatal: Can't read header file '$name.h': $!"; +my %vals; +my $max = 0; + +while (<$header>) { + if (/^#define\s+(\w+)\s+(\d+)$/ || /^#define\s+(\w+)\s+\(\(DWORD\)(\d+)L\)/) { + $vals{$1} = $2; + if (substr($1, 0, 1) eq 'C') { + $max = $2 if $max < $2; + } + } +} + +close($header); + +my ($hash, $f2c, %fac); + +for my $name (sort { substr($a,0,1) cmp substr($b,0,1) || $vals{$a} <=> $vals{$b} } keys %vals) { + $hash .= " $name => $vals{$name},\n" ; + if ($name =~ /^CAT_(\w+)$/) { + $fac{$1} = $vals{$name}; + } +} + +for my $name (sort {$fac{$a} <=> $fac{$b}} keys %fac) { + $f2c .= " Sys::Syslog::LOG_$name() => '$name',\n"; +} + +# write the Sys::Syslog::Win32 module +open my $out, '>', "Win32.pm" or die "fatal: Can't write Win32.pm: $!"; +my $template = join '', ; +$template =~ s/__CONSTANT__/$hash/; +$template =~ s/__F2C__/$f2c/; +$template =~ s/__NAME_VER__/$name/; +$template =~ s/__VER__/$version/; +$max = sprintf "0x%08x", $max; +$template =~ s/__MAX__/'$max'/g; +$template =~ s/__TIME__/localtime()/ge; +print $out $template; +close $out; +print "Updated Win32.pm and relevent message files\n"; + +__END__ +package Sys::Syslog::Win32; +use strict; +use warnings; +use Carp; +use File::Spec; + +# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING === +# +# This file was generated by Sys-Syslog/win32/compile.pl on __TIME__ +# Any changes being made here will be lost the next time Sys::Syslog +# is installed. +# +# Do NOT USE THIS MODULE DIRECTLY: this is a utility module for Sys::Syslog. +# It may change at any time to fit the needs of Sys::Syslog therefore no +# warranty is made WRT to its API. You Have Been Warned. +# +# === WARNING === WARNING === WARNING === WARNING === WARNING === WARNING === + +our $Source; +my $logger; +my $Registry; + +use Win32::EventLog; +use Win32::TieRegistry 0.20 ( + TiedRef => \$Registry, + Delimiter => "/", + ArrayValues => 1, + SplitMultis => 1, + AllowLoad => 1, + qw( + REG_SZ + REG_EXPAND_SZ + REG_DWORD + REG_BINARY + REG_MULTI_SZ + KEY_READ + KEY_WRITE + KEY_ALL_ACCESS + ), +); + +my $is_Cygwin = $^O =~ /Cygwin/i; +my $is_Win32 = $^O =~ /Win32/i; + +my %const = ( +__CONSTANT__ +); + +my %id2name = ( +__F2C__ +); + +my @priority2eventtype = ( + EVENTLOG_ERROR_TYPE(), # LOG_EMERG + EVENTLOG_ERROR_TYPE(), # LOG_ALERT + EVENTLOG_ERROR_TYPE(), # LOG_CRIT + EVENTLOG_ERROR_TYPE(), # LOG_ERR + EVENTLOG_WARNING_TYPE(), # LOG_WARNING + EVENTLOG_WARNING_TYPE(), # LOG_NOTICE + EVENTLOG_INFORMATION_TYPE(), # LOG_INFO + EVENTLOG_INFORMATION_TYPE(), # LOG_DEBUG +); + + +# +# _install() +# -------- +# Used to set up a connection to the eventlog. +# +sub _install { + return $logger if $logger; + + # can't just use basename($0) here because Win32 path often are a + # a mix of / and \, and File::Basename::fileparse() can't handle that, + # while File::Spec::splitpath() can.. Go figure.. + my (undef, undef, $basename) = File::Spec->splitpath($0); + ($Source) ||= $basename; + + $Source.=" [SSW:__VER__]"; + + #$Registry->Delimiter("/"); # is this needed? + my $root = 'LMachine/SYSTEM/CurrentControlSet/Services/Eventlog/Application/'; + my $dll = 'Sys/Syslog/__NAME_VER__.dll'; + + if (!$Registry->{$root.$Source} || + !$Registry->{$root.$Source.'/CategoryMessageFile'}[0] || + !-e $Registry->{$root.$Source.'/CategoryMessageFile'}[0] ) + { + + # find the resource DLL, which should be along Syslog.dll + my ($file) = grep { -e $_ } map { ("$_/$dll" => "$_/auto/$dll") } @INC; + $dll = $file if $file; + + # on Cygwin, convert the Unix path into absolute Windows path + if ($is_Cygwin) { + if ($] > 5.009005) { + chomp($file = Cygwin::posix_to_win_path($file, 1)); + } + else { + local $ENV{PATH} = ''; + chomp($dll = `/usr/bin/cygpath --absolute --windows "$dll"`); + } + } + + $dll =~ s![\\/]+!\\!g; # must be backslashes! + die "fatal: Can't find resource DLL for Sys::Syslog\n" if !$dll; + + $Registry->{$root.$Source} = { + '/EventMessageFile' => [ $dll, REG_EXPAND_SZ ], + '/CategoryMessageFile' => [ $dll, REG_EXPAND_SZ ], + '/CategoryCount' => [ __MAX__, REG_DWORD ], + #'/TypesSupported' => [ __MAX__, REG_DWORD ], + }; + + warn "Configured eventlog to use $dll for $Source\n" if $Sys::Syslog::DEBUG; + } + + #Carp::confess("Registry has the wrong value for '$Source', possibly mismatched dll!\nMine:$dll\nGot :$Registry->{$root.$Source.'/CategoryMessageFile'}[0]\n") + # if $Registry->{$root.$Source.'/CategoryMessageFile'}[0] ne $dll; + + # we really should do something useful with this but for now + # we set it to "" to prevent Win32::EventLog from warning + my $host = ""; + + $logger = Win32::EventLog->new($Source, $host) + or Carp::confess("Failed to connect to the '$Source' event log"); + + return $logger; +} + + +# +# _syslog_send() +# ------------ +# Used to convert syslog messages into eventlog messages +# +sub _syslog_send { + my ($buf, $numpri, $numfac) = @_; + $numpri ||= EVENTLOG_INFORMATION_TYPE(); + $numfac ||= Sys::Syslog::LOG_USER(); + my $name = $id2name{$numfac}; + + my $opts = { + EventType => $priority2eventtype[$numpri], + EventID => $const{"MSG_$name"}, + Category => $const{"CAT_$name"}, + Strings => "$buf\0", + Data => "", + }; + + if ($Sys::Syslog::DEBUG) { + require Data::Dumper; + warn Data::Dumper->Dump( + [$numpri, $numfac, $name, $opts], + [qw(numpri numfac name opts)] + ); + } + + return $logger->Report($opts); +} + + +=head1 NAME + +Sys::Syslog::Win32 - Win32 support for Sys::Syslog + +=head1 DESCRIPTION + +This module is a back-end plugin for C, for supporting the Win32 +event log. It is not expected to be directly used by any module other than +C therefore it's API may change at any time and no warranty is +made with regards to backward compatibility. You Have Been Warned. + +=head1 SEE ALSO + +L + +=head1 AUTHORS + +SEbastien Aperghis-Tramoni and Yves Orton + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +1;