dslinux/user/perl/ext/Sys/Syslog/t 00-load.t constants.t syslog.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:44 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/ext/Sys/Syslog/t
In directory antilope:/tmp/cvs-serv17422/ext/Sys/Syslog/t

Added Files:
	00-load.t constants.t syslog.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: 00-load.t ---
#!perl -T

use Test::More tests => 1;

BEGIN {
	use_ok( 'Sys::Syslog' );
}

#diag( "Testing Sys::Syslog $Sys::Syslog::VERSION, Perl $], $^X" );

--- NEW FILE: syslog.t ---
#!/usr/bin/perl -T

BEGIN {
    if( $ENV{PERL_CORE} ) {
        chdir 't';
        @INC = '../lib';
    }
}

use strict;
use Config;
use File::Spec;
use Test::More;

# check that the module is at least available
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/;

BEGIN {
    plan tests => 119;

    # ok, now loads them
    eval 'use Socket';
    use_ok('Sys::Syslog', ':standard', ':extended', ':macros');
}

# 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 open a syslog using a Unix or stream socket
SKIP: {
    skip "can't connect to Unix socket: _PATH_LOG unavailable", 8
      unless -e Sys::Syslog::_PATH_LOG();

    # The only known $^O eq 'svr4' that needs this is NCR MP-RAS,
    # but assuming 'stream' in SVR4 is probably not that bad.
    my $sock_type = $^O =~ /^(solaris|irix|svr4|powerux)$/ ? 'stream' : 'unix';

    eval { setlogsock($sock_type) };
    is( $@, '', "setlogsock() called with '$sock_type'" );
    TODO: {
        local $TODO = "minor bug";
        ok( $r, "setlogsock() should return true: '$r'" );
    }

    # open syslog with a "local0" facility
    SKIP: {
        # openlog()
        $r = eval { openlog('perl', 'ndelay', 'local0') } || 0;
        skip "can't connect to syslog", 6 if $@ =~ /^no connection to syslog available/;
        is( $@, '', "openlog() called with facility 'local0'" );
        ok( $r, "openlog() should return true: '$r'" );

        # syslog()
        $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket") } || 0;
        is( $@, '', "syslog() called with level 'info'" );
        ok( $r, "syslog() should return true: '$r'" );

        # closelog()
        $r = eval { closelog() } || 0;
        is( $@, '', "closelog()" );
        ok( $r, "closelog() should return true: '$r'" );
    }
}

# try to open a syslog using all the available connection methods
for my $sock_type (qw(stream unix inet tcp udp console)) {
    SKIP: {
        # setlogsock()
        $r = eval { setlogsock([$sock_type]) } || 0;
        skip "can't use '$sock_type' socket", 16 unless $r;
        is( $@, '', "setlogsock() called with '$sock_type'" );
        ok( $r, "setlogsock() should return true: '$r'" );

        # openlog() without option NDELAY
        $r = eval { openlog('perl', '', 'local0') } || 0;
        skip "can't connect to syslog", 14 if $@ =~ /^no connection to syslog available/;
        is( $@, '', "openlog() called with facility 'local0' and without option 'ndelay'" );
        ok( $r, "openlog() should return true: '$r'" );

        # openlog() with the option NDELAY
        $r = eval { openlog('perl', 'ndelay', 'local0') } || 0;
        skip "can't connect to syslog", 12 if $@ =~ /^no connection to syslog available/;
        is( $@, '', "openlog() called with facility 'local0' with option 'ndelay'" );
        ok( $r, "openlog() should return true: '$r'" );

        # syslog() with level "info" (as a string), should pass
        $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket") } || 0;
        is( $@, '', "syslog() called with level 'info'" );
        ok( $r, "syslog() should return true: '$r'" );

        # syslog() with level "info" (as a macro), should pass
        $r = eval { syslog(LOG_INFO, "$test_string by connecting to a $sock_type socket") } || 0;
        is( $@, '', "syslog() called with level 'info'" );
        ok( $r, "syslog() should return true: '$r'" );

        # syslog() with facility "kern" (as a string), should fail
        $r = eval { syslog('kern', "$test_string by connecting to a $sock_type socket") } || 0;
        like( $@, '/^syslog: invalid level/facility: kern/', "syslog() called with facility 'kern'" );
        ok( !$r, "syslog() should return false: '$r'" );

        # syslog() with facility "kern" (as a macro), should fail
        $r = eval { syslog(LOG_KERN, "$test_string by connecting to a $sock_type socket") } || 0;
        like( $@, '/^syslog: invalid level/facility: 0/', "syslog() called with facility 'kern'" );
        ok( !$r, "syslog() should return false: '$r'" );

        SKIP: {
            skip "skipping closelog() tests for 'console'", 2 if $sock_type eq 'console';
            # closelog()
            $r = eval { closelog() } || 0;
            is( $@, '', "closelog()" );
            ok( $r, "closelog() should return true: '$r'" );
        }
    }
}

# setlogmask()
{
    my $oldmask = 0;

    $oldmask = eval { setlogmask(0) } || 0;
    is( $@, '', "setlogmask() called with a null mask" );
    $r = eval { setlogmask(0) } || 0;
    is( $@, '', "setlogmask() called with a null mask (second time)" );
    is( $r, $oldmask, "setlogmask() must return the same mask as previous call");

    for my $newmask ( LOG_ERR , LOG_CRIT|LOG_ERR|LOG_WARNING ) {
        $r = eval { setlogmask($newmask) } || 0;
        is( $@, '', "setlogmask() called with a new mask" );
        is( $r, $oldmask, "setlogmask() must return the same mask as previous call");
        $r = eval { setlogmask(0) } || 0;
        is( $@, '', "setlogmask() called with a null mask" );
        is( $r, $newmask, "setlogmask() must return the new mask");
        setlogmask($oldmask);
    }
}

--- NEW FILE: constants.t ---
#!/usr/bin/perl -T
use strict;
use File::Spec;
use Test::More;

my $macrosall = $ENV{PERL_CORE} ? File::Spec->catfile(qw(.. ext Sys Syslog macros.all))
                                : 'macros.all';
open(MACROS, $macrosall) or plan skip_all => "can't read '$macrosall': $!";
my @names = map {chomp;$_} <MACROS>;
close(MACROS);
plan tests => @names * 2 + 2;

my $callpack = my $testpack = 'Sys::Syslog';
eval "use $callpack";

eval "${callpack}::This()";
like( $@, "/^This is not a valid $testpack macro/", "trying a non-existing macro");

eval "${callpack}::NOSUCHNAME()";
like( $@, "/^NOSUCHNAME is not a valid $testpack macro/", "trying a non-existing macro");

# Testing all macros
if(@names) {
    for my $name (@names) {
        SKIP: {
            $name =~ /^(\w+)$/ or skip "invalid name '$name'", 2;
            $name = $1;
            my $v = eval "${callpack}::$name()";

            if(defined($v) && $v =~ /^\d+$/) {
                is( $@, '', "calling the constant $name as a function" );
                like( $v, '/^\d+$/', "checking that $name is a number ($v)" );

            } else {
                like( $@, "/^Your vendor has not defined $testpack macro $name/", 
                    "calling the constant via its name" );
                skip "irrelevant test in this case", 1
            }
        }
    }
}




More information about the dslinux-commit mailing list