ext/Sys/Hostname/Hostname.xs Sys::Hostname extension external subroutines
ext/Sys/Hostname/Makefile.PL Sys::Hostname extension makefile writer
ext/Sys/Hostname/t/Hostname.t See if Sys::Hostname works
+ext/Sys/Syslog/Changes Changlog for Sys::Syslog
ext/Sys/Syslog/Makefile.PL Sys::Syslog extension makefile writer
+ext/Sys/Syslog/README README for Sys::Syslog
ext/Sys/Syslog/Syslog.pm Sys::Syslog extension Perl module
ext/Sys/Syslog/Syslog.xs Sys::Syslog extension external subroutines
+ext/Sys/Syslog/fallback/const-c.inc Sys::Syslog constants fallback file
+ext/Sys/Syslog/fallback/const-xs.inc Sys::Syslog constants fallback file
+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/distchk.t test for Sys::Syslog
+ext/Sys/Syslog/t/pod.t test for Sys::Syslog
+ext/Sys/Syslog/t/podcover.t test for Sys::Syslog
+ext/Sys/Syslog/t/podspell.t test for Sys::Syslog
+ext/Sys/Syslog/t/portfs.t test for Sys::Syslog
ext/Sys/Syslog/t/syslog.t See if Sys::Syslog works
ext/Thread/create.tx Test thread creation
ext/Thread/die2.tx Test thread die() differently
--- /dev/null
+Revision history for Sys-Syslog
+
+0.10 2005.12.08
+ [DOC] Improved documentation.
+ [TESTS] Added -T to t/syslog.t
+ [TESTS] Added t/constants.t to check the macros.
+ [TESTS] Added t/distchk.t, t/podspell.t, t/podcover.t, t/portfs.t
+
+0.09 2005.12.06
+ [CODE] Now setlogsock() really croak(), as documented.
+ [DIST] CPANized from blead@26281.
+ [DIST] Modified Makefile.PL so that ExtUtils::Constant is conditionaly
+ used, with a fallback in the case it's not available.
+ [DIST] Bumped version to 0.09
+ [DOC] Added support and license information.
+ [TESTS] Rewrote and ported t/syslog.t to Test::More
+
use ExtUtils::MakeMaker;
-use ExtUtils::Constant 0.11 'WriteConstants';
+eval 'use ExtUtils::MakeMaker::Coverage';
+require 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',
+ VERSION_FROM => 'Syslog.pm',
+ ABSTRACT_FROM => 'Syslog.pm',
+ INSTALLDIRS => 'perl',
+ MAN3PODS => {}, # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes',
+ PREREQ_PM => {
+ 'Test::More' => 0,
+ 'XSLoader' => 0,
+ },
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ clean => { FILES => 'Sys-Syslog-*' },
+ realclean => { FILES => 'const-c.inc const-xs.inc' },
);
my $_PATH_LOG;
if (-S "/dev/log" && -w "/dev/log") {
- # Most unixes have a unix domain socket /dev/log.
- $_PATH_LOG = "/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";
+ # 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 = "";
+ $_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(eval {require ExtUtils::Constant; 1}) {
+ my @names = (qw( LOG_ALERT LOG_AUTH LOG_AUTHPRIV LOG_CONS LOG_CRIT LOG_CRON
+ LOG_DAEMON LOG_DEBUG LOG_EMERG LOG_ERR LOG_FACMASK LOG_FTP
+ LOG_INFO LOG_KERN LOG_LFMT LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2
+ LOG_LOCAL3 LOG_LOCAL4 LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR
+ LOG_MAIL LOG_NDELAY LOG_NEWS LOG_NFACILITIES LOG_NOTICE
+ LOG_NOWAIT LOG_ODELAY LOG_PERROR LOG_PID LOG_PRIMASK LOG_SYSLOG
+ LOG_USER LOG_UUCP LOG_WARNING),
+ { name => "_PATH_LOG", type => "PV", default => [ "PV", qq("$_PATH_LOG") ] },
+ );
+
+ ExtUtils::Constant::WriteConstants(
+ NAME => 'Sys::Syslog',
+ NAMES => \@names,
+ );
+
+ open(MACROS, '>macros.all') or warn "can't write 'macros.all': $!\n";
+ print MACROS join $/, grep {!ref} @names;
+ close(MACROS);
+
+} else {
+ use File::Copy;
+ use File::Spec;
+ foreach my $file ('const-c.inc', 'const-xs.inc') {
+ my $fallback = File::Spec->catfile('fallback', $file);
+ copy ($fallback, $file) or die "Can't copy $fallback to $ $!";
+ }
+}
--- /dev/null
+NAME
+
+ Sys::Syslog - Perl interface to the UNIX syslog(3) calls
+
+
+DESCRIPTION
+
+ Sys::Syslog is an interface to the UNIX syslog(3) program.
+ Call syslog() with a string priority and a list of printf() args
+ just like syslog(3).
+
+
+INSTALLATION
+
+ To install this module, run the following commands:
+
+ $ perl Makefile.PL
+ $ make
+ $ make test
+ $ make install
+
+ A ANSI-compliant compiler is required to compile the extension.
+
+ Sys::Syslog has been tested by the author on the following systems,
+ but is likely to run on many more:
+
+ - Linux 2.6, gcc 3.4.1
+ - FreeBSD 4.7, gcc 2.95.4
+ - Mac OS X 10.2.6, gcc 3.1
+
+ Sys::Syslog should on any Perl since 5.6.0. This module has been
+ tested by the author to check that it works with the following
+ versions ot Perl:
+
+ - Perl 5.6.2 i686-linux (custom build)
+ - Perl 5.8.5 i386-linux-thread-multi (vendor build)
+ - Perl 5.6.1 i386-freebsd (custom build)
+ - Perl 5.8.7 i386-freebsd (custom build)
+ - Perl 5.6.0 darwin (vendor build)
+
+ See also the corresponding CPAN Testers page:
+ http://testers.cpan.org/show/Net-Pcap.html
+
+
+SUPPORT AND DOCUMENTATION
+
+ After installing, you can find documentation for this module
+ with the perldoc command.
+
+ perldoc Sys::Syslog
+
+ You can also look for information at:
+
+ Search CPAN
+ http://search.cpan.org/dist/Sys-Syslog
+
+ CPAN Request Tracker:
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-Syslog
+
+ AnnoCPAN, annotated CPAN documentation:
+ http://annocpan.org/dist/Sys-Syslog
+
+ CPAN Ratings:
+ http://cpanratings.perl.org/d/Sys-Syslog
+
+
+COPYRIGHT AND LICENCE
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
package Sys::Syslog;
+use strict;
+use Carp;
require 5.006;
require Exporter;
-use Carp;
-use strict;
our @ISA = qw(Exporter);
our @EXPORT = qw(openlog closelog setlogmask syslog);
our @EXPORT_OK = qw(setlogsock);
-our $VERSION = '0.08';
+our $VERSION = '0.10';
# it would be nice to try stream/unix first, since that will be
# most efficient. However streams are dodgy - see _syslog_send_stream
=head1 NAME
-Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
+Sys::Syslog - Perl interface to the UNIX syslog(3) calls
+
+=head1 VERSION
+
+Version 0.10
=head1 SYNOPSIS
- use Sys::Syslog; # all except setlogsock, or:
- use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock
+ 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
$oldmask = setlogmask $mask_priority;
closelog;
+
=head1 DESCRIPTION
-Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
+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)>.
-Syslog provides the functions:
+
+=head1 EXPORTS
+
+By default, C<Sys::Syslog> exports the following symbols:
+
+ openlog closelog setlogmask syslog
+
+as well as the symbols corresponding to most of your C<syslog(3)> macros.
+The symbol C<setlogsock> can be exported on demand.
+
+
+=head1 FUNCTIONS
=over 4
-=item openlog $ident, $logopt, $facility
+=item B<openlog($ident, $logopt, $facility)>
Opens the syslog.
-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
+C<$ident> is prepended to every message. C<$logopt> contains zero or
+more of the words C<pid>, C<ndelay>, C<nowait>. The C<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:
+automatically if all other media fail. C<$facility> specifies the
+part of the system to report about, for example C<LOG_USER> or C<LOG_LOCAL0>:
see your C<syslog(3)> documentation for the facilities available in
your system. 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 openlog() before calling syslog().>
-=item syslog $priority, $message
+=item B<syslog($priority, $message)>
-=item syslog $priority, $format, @args
+=item B<syslog($priority, $format, @args)>
-If I<$priority> permits, logs I<$message> or I<sprintf($format, @args)>
-with the addition that I<%m> in $message or $format is replaced with
+If C<$priority> permits, logs C<$message> or C<sprintf($format, @args)>
+with the addition that C<%m> in $message or $format 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 ":".
+If you didn't use C<openlog()> before using C<syslog()>, syslog will
+try to guess the C<$ident> by extracting the shortest prefix of
+C<$format> that ends in a C<":">.
-Note that Sys::Syslog version v0.07 and older passed the $message as
-the formatting string to sprintf() even when no formatting arguments
-were provided. If the code calling syslog() might execute with older
+Note that 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
-syslog($priority, "%s", $message) instead of syslog($priority,
-$message). This protects against hostile formatting sequences that
+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.
-=item setlogmask $mask_priority
+=item B<setlogmask($mask_priority)>
-Sets log mask I<$mask_priority> and returns the old mask.
+Sets log mask C<$mask_priority> and returns the old mask.
-=item setlogsock $sock_type [$stream_location] (added in 5.004_02)
+=item B<setlogsock($sock_type)>
+
+=item B<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.
+C<openlog()> or C<syslog()> and returns true on success,
+C<undef> on failure.
-A value of 'unix' will connect to the UNIX domain socket (in some
+A value of C<"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().
+(For example Solaris and IRIX require C<"stream"> instead of C<"unix">.)
+A value of C<"inet"> will connect to an INET socket (either C<tcp> or C<udp>,
+tried in that order) returned by C<getservbyname()>. C<"tcp"> and C<"udp"> can
+also be given as values. The value C<"console"> will send messages
+directly to the console, as for the C<"cons"> option in the logopts in
+C<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.
+The default is to try C<tcp>, C<udp>, C<unix>, C<stream>, C<console>.
-Giving an invalid value for sock_type will croak.
+Giving an invalid value for C<$sock_type> will croak.
-=item closelog
+=item B<closelog()>
Closes the log file.
=back
-Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
=head1 EXAMPLES
openlog($program, 'ndelay', 'user');
syslog('info', 'something happened over here');
+
+=head1 CONSTANTS
+
+=head2 Facilities
+
+=over 4
+
+=item *
+
+C<LOG_AUTH> - security/authorization messages
+
+=item *
+
+C<LOG_AUTHPRIV> - security/authorization messages (private)
+
+=item *
+
+C<LOG_CRON> - clock daemon (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_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_NEWS> - USENET news subsystem
+
+=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 4
+
+=item Invalid argument passed to setlogsock
+
+B<(F)> You gave C<setlogsock()> an invalid value for C<$sock_type>.
+
+=item no connection to syslog available
+
+B<(F)> C<syslog()> failed to connect to the specified socket.
+
+=item stream passed to setlogsock, but %s is not writable
+
+B<(F)> You asked C<setlogsock()> to use a stream socket, but the given
+path is not writable.
+
+=item stream passed to setlogsock, but could not find any device
+
+B<(F)> You asked C<setlogsock()> to use a stream socket, but didn't
+provide a path, and C<Sys::Syslog> was unable to find an appropriate one.
+
+=item tcp passed to setlogsock, but tcp service unavailable
+
+B<(F)> You asked C<setlogsock()> to use a TCP socket, but the service
+is not available on the system.
+
+=item syslog: expecting argument %s
+
+B<(F)> You forgot to give C<syslog()> the indicated argument.
+
+=item syslog: invalid level/facility: %s
+
+B<(F)> You specified an invalid level or facility, like C<LOG_KERN>
+(which is reserved to the kernel).
+
+=item syslog: too many levels given: %s
+
+B<(F)> You specified too many levels.
+
+=item syslog: too many facilities given: %s
+
+B<(F)> You specified too many facilities.
+
+=item syslog: level must be given
+
+B<(F)> You forgot to specify a level.
+
+=item udp passed to setlogsock, but udp service unavailable
+
+B<(F)> You asked C<setlogsock()> to use a UDP socket, but the service
+is not available on the system.
+
+=item unix passed to setlogsock, but path not available
+
+B<(F)> You asked C<setlogsock()> to use a UNIX socket, but C<Sys::Syslog>
+was unable to find an appropriate an appropriate device.
+
+=back
+
+
=head1 SEE ALSO
L<syslog(3)>
+
=head1 AUTHOR
Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall
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.
+E<lt>F<Tim.Bunce@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@compton.nu>E<gt>.
-Code for constant()s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
+Code for C<constant()>s regenerated by Nicholas Clark E<lt>F<nick@ccl4.org>E<gt>.
Failover to different communication modes by Nick Williams
E<lt>F<Nick.Williams@morganstanley.com>E<gt>.
+Extracted from core distribution for publishing on the CPAN by
+SE<eacute>bastien Aperghis-Tramoni E<lt>sebastien@aperghis.netE<gt>.
+
+
+=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/NoAuth/ReportBug.html?Queue=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>
+
+=back
+
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
=cut
sub AUTOLOAD {
last;
}
}
- carp "stream passed to setlogsock, but could not find any device"
+ croak "stream passed to setlogsock, but could not find any device"
unless defined $syslog_path;
}
unless (-w $syslog_path) {
- carp "stream passed to setlogsock, but $syslog_path is not writable";
+ croak "stream passed to setlogsock, but $syslog_path is not writable";
return undef;
} else {
@connectMethods = ( 'stream' );
$syslog_path = _PATH_LOG();
@connectMethods = ( 'unix' );
} else {
- carp 'unix passed to setlogsock, but path not available';
+ croak 'unix passed to setlogsock, but path not available';
return undef;
}
} elsif (lc($setsock) eq 'tcp') {
if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
@connectMethods = ( 'tcp' );
} else {
- carp "tcp passed to setlogsock, but tcp service unavailable";
+ croak "tcp passed to setlogsock, but tcp service unavailable";
return undef;
}
} elsif (lc($setsock) eq 'udp') {
if (getservbyname('syslog', 'udp')) {
@connectMethods = ( 'udp' );
} else {
- carp "udp passed to setlogsock, but udp service unavailable";
+ croak "udp passed to setlogsock, but udp service unavailable";
return undef;
}
} elsif (lc($setsock) eq 'inet') {
} elsif (lc($setsock) eq 'console') {
@connectMethods = ( 'console' );
} else {
- carp "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
+ croak "Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'";
}
return 1;
}
# To be correct, it should use a STREAMS API, but perl doesn't have one.
return syswrite(SYSLOG, $buf, length($buf));
}
+
sub _syslog_send_socket {
my ($buf) = @_;
return syswrite(SYSLOG, $buf, length($buf));
--- /dev/null
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+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 */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'E':
+ if (memEQ(name, "LOG_ERR", 7)) {
+ /* ^ */
+#ifdef LOG_ERR
+ *iv_return = LOG_ERR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "LOG_FTP", 7)) {
+ /* ^ */
+#ifdef LOG_FTP
+ *iv_return = LOG_FTP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "LOG_LPR", 7)) {
+ /* ^ */
+#ifdef LOG_LPR
+ *iv_return = LOG_LPR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "LOG_PID", 7)) {
+ /* ^ */
+#ifdef LOG_PID
+ *iv_return = LOG_PID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_8 (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_AUTH LOG_CONS LOG_CRIT LOG_CRON LOG_INFO LOG_KERN LOG_LFMT LOG_MAIL
+ LOG_NEWS LOG_USER LOG_UUCP */
+ /* Offset 6 gives the best switch position. */
+ switch (name[6]) {
+ case 'C':
+ if (memEQ(name, "LOG_UUCP", 8)) {
+ /* ^ */
+#ifdef LOG_UUCP
+ *iv_return = LOG_UUCP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "LOG_USER", 8)) {
+ /* ^ */
+#ifdef LOG_USER
+ *iv_return = LOG_USER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "LOG_INFO", 8)) {
+ /* ^ */
+#ifdef LOG_INFO
+ *iv_return = LOG_INFO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "LOG_CRIT", 8)) {
+ /* ^ */
+#ifdef LOG_CRIT
+ *iv_return = LOG_CRIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOG_MAIL", 8)) {
+ /* ^ */
+#ifdef LOG_MAIL
+ *iv_return = LOG_MAIL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "LOG_LFMT", 8)) {
+ /* ^ */
+#ifdef LOG_LFMT
+ *iv_return = LOG_LFMT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "LOG_CONS", 8)) {
+ /* ^ */
+#ifdef LOG_CONS
+ *iv_return = LOG_CONS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "LOG_CRON", 8)) {
+ /* ^ */
+#ifdef LOG_CRON
+ *iv_return = LOG_CRON;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "LOG_KERN", 8)) {
+ /* ^ */
+#ifdef LOG_KERN
+ *iv_return = LOG_KERN;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "LOG_AUTH", 8)) {
+ /* ^ */
+#ifdef LOG_AUTH
+ *iv_return = LOG_AUTH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "LOG_NEWS", 8)) {
+ /* ^ */
+#ifdef LOG_NEWS
+ *iv_return = LOG_NEWS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+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;
+ 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;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "LOG_EMERG", 9)) {
+ /* ^ */
+#ifdef LOG_EMERG
+ *iv_return = LOG_EMERG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "_PATH_LOG", 9)) {
+ /* ^ */
+#ifdef _PATH_LOG
+ *pv_return = _PATH_LOG;
+ return PERL_constant_ISPV;
+#else
+ *pv_return = "/dev/log";
+ return PERL_constant_ISPV;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_10 (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_DAEMON LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2 LOG_LOCAL3 LOG_LOCAL4
+ LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_NDELAY LOG_NOTICE LOG_NOWAIT
+ LOG_ODELAY LOG_PERROR LOG_SYSLOG */
+ /* Offset 9 gives the best switch position. */
+ switch (name[9]) {
+ case '0':
+ if (memEQ(name, "LOG_LOCAL", 9)) {
+ /* 0 */
+#ifdef LOG_LOCAL0
+ *iv_return = LOG_LOCAL0;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '1':
+ if (memEQ(name, "LOG_LOCAL", 9)) {
+ /* 1 */
+#ifdef LOG_LOCAL1
+ *iv_return = LOG_LOCAL1;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '2':
+ if (memEQ(name, "LOG_LOCAL", 9)) {
+ /* 2 */
+#ifdef LOG_LOCAL2
+ *iv_return = LOG_LOCAL2;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '3':
+ if (memEQ(name, "LOG_LOCAL", 9)) {
+ /* 3 */
+#ifdef LOG_LOCAL3
+ *iv_return = LOG_LOCAL3;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '4':
+ if (memEQ(name, "LOG_LOCAL", 9)) {
+ /* 4 */
+#ifdef LOG_LOCAL4
+ *iv_return = LOG_LOCAL4;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '5':
+ if (memEQ(name, "LOG_LOCAL", 9)) {
+ /* 5 */
+#ifdef LOG_LOCAL5
+ *iv_return = LOG_LOCAL5;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '6':
+ if (memEQ(name, "LOG_LOCAL", 9)) {
+ /* 6 */
+#ifdef LOG_LOCAL6
+ *iv_return = LOG_LOCAL6;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case '7':
+ if (memEQ(name, "LOG_LOCAL", 9)) {
+ /* 7 */
+#ifdef LOG_LOCAL7
+ *iv_return = LOG_LOCAL7;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "LOG_NOTIC", 9)) {
+ /* E */
+#ifdef LOG_NOTICE
+ *iv_return = LOG_NOTICE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "LOG_SYSLO", 9)) {
+ /* G */
+#ifdef LOG_SYSLOG
+ *iv_return = LOG_SYSLOG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "LOG_DAEMO", 9)) {
+ /* N */
+#ifdef LOG_DAEMON
+ *iv_return = LOG_DAEMON;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "LOG_PERRO", 9)) {
+ /* R */
+#ifdef LOG_PERROR
+ *iv_return = LOG_PERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'T':
+ if (memEQ(name, "LOG_NOWAI", 9)) {
+ /* T */
+#ifdef LOG_NOWAIT
+ *iv_return = LOG_NOWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "LOG_NDELA", 9)) {
+ /* Y */
+#ifdef LOG_NDELAY
+ *iv_return = LOG_NDELAY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "LOG_ODELA", 9)) {
+ /* Y */
+#ifdef LOG_ODELAY
+ *iv_return = LOG_ODELAY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_11 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ LOG_FACMASK LOG_PRIMASK LOG_WARNING */
+ /* Offset 6 gives the best switch position. */
+ switch (name[6]) {
+ case 'C':
+ if (memEQ(name, "LOG_FACMASK", 11)) {
+ /* ^ */
+#ifdef LOG_FACMASK
+ *iv_return = LOG_FACMASK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "LOG_PRIMASK", 11)) {
+ /* ^ */
+#ifdef LOG_PRIMASK
+ *iv_return = LOG_PRIMASK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ 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;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant (pTHX_ const char *name, STRLEN len, IV *iv_return, const char **pv_return) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!/usr/bin/perl5.8.5 -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw(IV PV)};
+my @names = (qw(LOG_ALERT LOG_AUTH LOG_AUTHPRIV LOG_CONS LOG_CRIT LOG_CRON
+ LOG_DAEMON LOG_DEBUG LOG_EMERG LOG_ERR LOG_FACMASK LOG_FTP
+ LOG_INFO LOG_KERN LOG_LFMT LOG_LOCAL0 LOG_LOCAL1 LOG_LOCAL2
+ LOG_LOCAL3 LOG_LOCAL4 LOG_LOCAL5 LOG_LOCAL6 LOG_LOCAL7 LOG_LPR
+ LOG_MAIL LOG_NDELAY LOG_NEWS LOG_NFACILITIES LOG_NOTICE
+ LOG_NOWAIT LOG_ODELAY LOG_PERROR LOG_PID LOG_PRIMASK LOG_SYSLOG
+ LOG_USER LOG_UUCP LOG_WARNING),
+ {name=>"_PATH_LOG", type=>"PV", default=>["PV", "\"/dev/log\""]});
+
+print constant_types(); # macro defs
+foreach (C_constant ("Sys::Syslog", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("Sys::Syslog", $types);
+__END__
+ */
+
+ switch (len) {
+ case 7:
+ return constant_7 (aTHX_ name, iv_return);
+ break;
+ case 8:
+ return constant_8 (aTHX_ name, iv_return);
+ break;
+ case 9:
+ return constant_9 (aTHX_ name, iv_return, pv_return);
+ break;
+ case 10:
+ return constant_10 (aTHX_ name, iv_return);
+ break;
+ case 11:
+ return constant_11 (aTHX_ name, iv_return);
+ break;
+ case 12:
+ if (memEQ(name, "LOG_AUTHPRIV", 12)) {
+#ifdef LOG_AUTHPRIV
+ *iv_return = LOG_AUTHPRIV;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 15:
+ if (memEQ(name, "LOG_NFACILITIES", 15)) {
+#ifdef LOG_NFACILITIES
+ *iv_return = LOG_NFACILITIES;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
--- /dev/null
+void
+constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ IV iv;
+ /* NV nv; Uncomment this if you need to return NVs */
+ const char *pv;
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ /* Change this to constant(aTHX_ s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ type = constant(aTHX_ s, len, &iv, &pv);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid Sys::Syslog macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined Sys::Syslog macro %s, used", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break;
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break;
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing Sys::Syslog macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
--- /dev/null
+#!perl -T
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'Sys::Syslog' );
+}
+
+diag( "Testing Sys::Syslog $Sys::Syslog::VERSION, Perl $], $^X" );
--- /dev/null
+#!/usr/bin/perl -T
+use strict;
+use Test::More;
+my @names;
+BEGIN {
+ if(open(MACROS, 'macros.all')) {
+ @names = map {chomp;$_} <MACROS>;
+ close(MACROS);
+ plan tests => @names + 3;
+ } else {
+ plan skip_all => "can't read 'macros.all': $!"
+ }
+}
+use Sys::Syslog;
+
+eval "use Test::Exception"; my $has_test_exception = !$@;
+
+# Testing error messages
+SKIP: {
+ skip "Test::Exception not available", 1 unless $has_test_exception;
+
+ # constant() errors
+ throws_ok(sub {
+ Sys::Syslog::constant()
+ }, '/^Usage: Sys::Syslog::constant\(sv\)/',
+ "calling constant() with no argument");
+}
+
+# Testing constant()
+like( Sys::Syslog::constant('This'),
+ '/^This is not a valid Sys::Syslog macro/',
+ "calling constant() with a non existing name" );
+
+like( Sys::Syslog::constant('NOSUCHNAME'),
+ '/^NOSUCHNAME is not a valid Sys::Syslog macro/',
+ "calling constant() with a non existing name" );
+
+# Testing all macros
+if(@names) {
+ for my $name (@names) {
+ like( Sys::Syslog::constant($name),
+ '/^(?:\d+|Your vendor has not defined Sys::Syslog macro '.$name.', used)$/',
+ "checking that $name is a number (".Sys::Syslog::constant($name).")" );
+ }
+}
+
--- /dev/null
+use strict;
+use Test::More;
+eval "use Test::Distribution not => [qw(versions podcover use)]";
+plan skip_all => "Test::Distribution required for checking distribution" if $@;
--- /dev/null
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
--- /dev/null
+#!/usr/bin/perl -T
+use strict;
+use Test::More;
+eval "use Test::Pod::Coverage 1.06";
+plan skip_all => "Test::Pod::Coverage 1.06 required for testing POD coverage" if $@;
+all_pod_coverage_ok({also_private => [qw(^constant$ ^connect ^disconnect$ ^xlate$ ^LOG_)]});
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use Test::More;
+eval "use Test::Spelling";
+plan skip_all => "Test::Spelling required for testing POD spell" if $@;
+set_spell_cmd('aspell -l --lang=en');
+add_stopwords(<DATA>);
+all_pod_files_spelling_ok();
+
+__END__
+
+SAPER
+Sébastien
+Aperghis
+Tramoni
+Christiansen
+AnnoCPAN
+CPAN
+README
+TODO
+AUTOLOADER
+API
+arrayref
+arrayrefs
+hashref
+hashrefs
+lookup
+hostname
+loopback
+netmask
+timestamp
+INET
+BPF
+IP
+TCP
+tcp
+UDP
+udp
+UUCP
+FDDI
+Firewire
+HDLC
+IEEE
+IrDA
+LocalTalk
+PPP
+unix
+Solaris
+IRIX
+endianness
+failover
+Failover
+logopts
+pathname
+syslogd
--- /dev/null
+#!/usr/bin/perl -T
+use strict;
+use Test::More;
+eval "use Test::Portability::Files";
+plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@;
+
+# run the selected tests
+run_tests();
-#!./perl
+#!/usr/bin/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 Test::More;
+use Config;
- # This code inspired by Sys::Syslog::connect():
- require Sys::Hostname;
- my ($host_uniq) = Sys::Hostname::hostname();
- my ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/;
+# check that the module is at least available
+plan skip_all => "Sys::Syslog was not build"
+ unless $Config{'extensions'} =~ /\bSyslog\b/;
- if (! defined Socket::inet_aton($host)) {
- print "1..0 # Skip: Can't lookup $host\n";
- exit 0;
- }
-}
+# we also need Socket
+plan skip_all => "Socket was not build"
+ unless $Config{'extensions'} =~ /\bSocket\b/;
BEGIN {
- eval {require Sys::Syslog} or do {
- if ($@ =~ /Your vendor has not/) {
- print "1..0 # Skip: missing macros\n";
- exit 0;
- }
- }
+ plan tests => 16;
+
+ # ok, now loads them
+ eval 'use Socket';
+ use_ok('Sys::Syslog', ':DEFAULT', 'setlogsock');
}
-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;
-
-my $test_string = "uid $< is testing perl $] syslog capabilities";
-
-print "1..6\n";
-
-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";
- }
- 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";
- }
+# check that the documented functions are correctly provided
+can_ok( 'Sys::Syslog' => qw(openlog syslog syslog setlogmask setlogsock closelog) );
+
+
+# check the diagnostics
+# setlogsock()
+eval { setlogsock() };
+like( $@, qr/^Invalid argument passed to setlogsock; must be 'stream', 'unix', 'tcp', 'udp' or 'inet'/,
+ "calling setlogsock() with no argument" );
+
+# syslog()
+eval { syslog() };
+like( $@, qr/^syslog: expecting argument \$priority/,
+ "calling syslog() with no argument" );
+
+my $test_string = "uid $< is testing Perl $] syslog(3) capabilities";
+my $r = 0;
+
+# try to test using a Unix socket
+SKIP: {
+ skip "can't connect to Unix socket: _PATH_LOG unavailable", 6
+ 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 but returned '$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";
+ SKIP: {
+ $r = eval { openlog('perl', 'ndelay', 'local0') };
+ skip "can't connect to syslog", 4 if $@ =~ /^no connection to syslog available/;
+ is( $@, '', "openlog()" );
+ ok( $r, "openlog() should return true but returned '$r'" );
+
+ $r = eval { syslog('info', "$test_string by connecting to a Unix socket") };
+ is( $@, '', "syslog()" );
+ ok( $r, "syslog() should return true but returned '$r'" );
+ }
}
-else {
- print "ok $_ # Skip: assuming syslog doesn't accept inet connections\n"
- foreach (4..6);
+
+# try to test using a INET socket
+SKIP: {
+ skip "assuming syslog doesn't accept inet connections", 6 if 1;
+
+ my $sock_type = 'inet';
+
+ $r = eval { setlogsock('inet') };
+ is( $@, '', "setlogsock() called with '$sock_type'" );
+ ok( $r, "setlogsock() should return true but returned '$r'" );
+
+ $r = eval { openlog('perl', 'ndelay', 'local0') };
+ is( $@, '', "openlog()" );
+ ok( $r, " -> should return true but returned '$r'" );
+
+ $r = eval { syslog('info', "$test_string by connecting to a INET socket") };
+ is( $@, '', "syslog()" );
+ ok( $r, " -> should return true but returned '$r'" );
}
+
projects / p5sagit/p5-mst-13.2.git / commitdiff