ext/Sys/Syslog/t/syslog.t

   1 #!perl -T
   2
   3 BEGIN {
   4     if ($ENV{PERL_CORE}) {
   5         chdir 't';
   6         @INC = '../lib';
   7     }
   8 }
   9
  10 use strict;
  11 use Config;
  12 use File::Spec;
  13 use Test::More;
  14
  15 # we enable all Perl warnings, but we don't "use warnings 'all'" because
  16 # we want to disable the warnings generated by Sys::Syslog
  17 no warnings;
  18 use warnings qw(closure deprecated exiting glob io misc numeric once overflow
  19                 pack portable recursion redefine regexp severe signal substr
  20                 syntax taint uninitialized unpack untie utf8 void);
  21
  22 my $is_Win32  = $^O =~ /win32/i;
  23 my $is_Cygwin = $^O =~ /cygwin/i;
  24
  25 # if testing in core, check that the module is at least available
  26 if ($ENV{PERL_CORE}) {
  27     plan skip_all => "Sys::Syslog was not build"
  28         unless $Config{'extensions'} =~ /\bSyslog\b/;
  29 }
  30
  31 # we also need Socket
  32 plan skip_all => "Socket was not build"
  33     unless $Config{'extensions'} =~ /\bSocket\b/;
  34
  35 my $tests;
  36 plan tests => $tests;
  37
  38 # any remaining warning should be severly punished
  39 BEGIN { eval "use Test::NoWarnings"; $tests = $@ ? 0 : 1; }
  40
  41 BEGIN { $tests += 1 }
  42 # ok, now loads them
  43 eval 'use Socket';
  44 use_ok('Sys::Syslog', ':standard', ':extended', ':macros');
  45
  46 BEGIN { $tests += 1 }
  47 # check that the documented functions are correctly provided
  48 can_ok( 'Sys::Syslog' => qw(openlog syslog syslog setlogmask setlogsock closelog) );
  49
  50
  51 BEGIN { $tests += 1 }
  52 # check the diagnostics
  53 # setlogsock()
  54 eval { setlogsock() };
  55 like( $@, qr/^Invalid argument passed to setlogsock/,
  56     "calling setlogsock() with no argument" );
  57
  58 BEGIN { $tests += 3 }
  59 # syslog()
  60 eval { syslog() };
  61 like( $@, qr/^syslog: expecting argument \$priority/,
  62     "calling syslog() with no argument" );
  63
  64 eval { syslog(undef) };
  65 like( $@, qr/^syslog: expecting argument \$priority/,
  66     "calling syslog() with one undef argument" );
  67
  68 eval { syslog('') };
  69 like( $@, qr/^syslog: expecting argument \$format/,
  70     "calling syslog() with one empty argument" );
  71
  72
  73 my $test_string = "uid $< is testing Perl $] syslog(3) capabilities";
  74 my $r = 0;
  75
  76 BEGIN { $tests += 8 }
  77 # try to open a syslog using a Unix or stream socket
  78 SKIP: {
  79     skip "can't connect to Unix socket: _PATH_LOG unavailable", 8
  80       unless -e Sys::Syslog::_PATH_LOG();
  81
  82     # The only known $^O eq 'svr4' that needs this is NCR MP-RAS,
  83     # but assuming 'stream' in SVR4 is probably not that bad.
  84     my $sock_type = $^O =~ /^(solaris|irix|svr4|powerux)$/ ? 'stream' : 'unix';
  85
  86     eval { setlogsock($sock_type) };
  87     is( $@, '', "setlogsock() called with '$sock_type'" );
  88     TODO: {
  89         local $TODO = "minor bug";
  90         ok( $r, "setlogsock() should return true: '$r'" );
  91     }
  92
  93     # open syslog with a "local0" facility
  94     SKIP: {
  95         # openlog()
  96         $r = eval { openlog('perl', 'ndelay', 'local0') } || 0;
  97         skip "can't connect to syslog", 6 if $@ =~ /^no connection to syslog available/;
  98         is( $@, '', "openlog() called with facility 'local0'" );
  99         ok( $r, "openlog() should return true: '$r'" );
 100
 101         # syslog()
 102         $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket") } || 0;
 103         is( $@, '', "syslog() called with level 'info'" );
 104         ok( $r, "syslog() should return true: '$r'" );
 105
 106         # closelog()
 107         $r = eval { closelog() } || 0;
 108         is( $@, '', "closelog()" );
 109         ok( $r, "closelog() should return true: '$r'" );
 110     }
 111 }
 112
 113
 114 BEGIN { $tests += 20 * 8 }
 115 # try to open a syslog using all the available connection methods
 116 my @passed = ();
 117 for my $sock_type (qw(native eventlog unix pipe stream inet tcp udp)) {
 118     SKIP: {
 119         skip "the 'stream' mechanism because a previous mechanism with similar interface succeeded", 20
 120             if $sock_type eq 'stream' and grep {/pipe|unix/} @passed;
 121
 122         # setlogsock() called with an arrayref
 123         $r = eval { setlogsock([$sock_type]) } || 0;
 124         skip "can't use '$sock_type' socket", 20 unless $r;
 125         is( $@, '', "[$sock_type] setlogsock() called with ['$sock_type']" );
 126         ok( $r, "[$sock_type] setlogsock() should return true: '$r'" );
 127
 128         # setlogsock() called with a single argument
 129         $r = eval { setlogsock($sock_type) } || 0;
 130         skip "can't use '$sock_type' socket", 18 unless $r;
 131         is( $@, '', "[$sock_type] setlogsock() called with '$sock_type'" );
 132         ok( $r, "[$sock_type] setlogsock() should return true: '$r'" );
 133
 134         # openlog() without option NDELAY
 135         $r = eval { openlog('perl', '', 'local0') } || 0;
 136         skip "can't connect to syslog", 16 if $@ =~ /^no connection to syslog available/;
 137         is( $@, '', "[$sock_type] openlog() called with facility 'local0' and without option 'ndelay'" );
 138         ok( $r, "[$sock_type] openlog() should return true: '$r'" );
 139
 140         # openlog() with the option NDELAY
 141         $r = eval { openlog('perl', 'ndelay', 'local0') } || 0;
 142         skip "can't connect to syslog", 14 if $@ =~ /^no connection to syslog available/;
 143         is( $@, '', "[$sock_type] openlog() called with facility 'local0' with option 'ndelay'" );
 144         ok( $r, "[$sock_type] openlog() should return true: '$r'" );
 145
 146         # syslog() with negative level, should fail
 147         $r = eval { syslog(-1, "$test_string by connecting to a $sock_type socket") } || 0;
 148         like( $@, '/^syslog: invalid level\/facility: /', "[$sock_type] syslog() called with level -1" );
 149         ok( !$r, "[$sock_type] syslog() should return false: '$r'" );
 150
 151         # syslog() with levels "info" and "notice" (as a strings), should fail
 152         $r = eval { syslog('info,notice', "$test_string by connecting to a $sock_type socket") } || 0;
 153         like( $@, '/^syslog: too many levels given: notice/', "[$sock_type] syslog() called with level 'info,notice'" );
 154         ok( !$r, "[$sock_type] syslog() should return false: '$r'" );
 155
 156         # syslog() with facilities "local0" and "local1" (as a strings), should fail
 157         $r = eval { syslog('local0,local1', "$test_string by connecting to a $sock_type socket") } || 0;
 158         like( $@, '/^syslog: too many facilities given: local1/', "[$sock_type] syslog() called with level 'local0,local1'" );
 159         ok( !$r, "[$sock_type] syslog() should return false: '$r'" );
 160
 161         # syslog() with level "info" (as a string), should pass
 162         $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket") } || 0;
 163         is( $@, '', "[$sock_type] syslog() called with level 'info' (string)" );
 164         ok( $r, "[$sock_type] syslog() should return true: '$r'" );
 165
 166         # syslog() with level "info" (as a macro), should pass
 167         { local $! = 1;
 168           $r = eval { syslog(LOG_INFO(), "$test_string by connecting to a $sock_type socket, setting a fake errno: %m") } || 0;
 169         }
 170         is( $@, '', "[$sock_type] syslog() called with level 'info' (macro)" );
 171         ok( $r, "[$sock_type] syslog() should return true: '$r'" );
 172
 173         push @passed, $sock_type;
 174
 175         SKIP: {
 176             skip "skipping closelog() tests for 'console'", 2 if $sock_type eq 'console';
 177             # closelog()
 178             $r = eval { closelog() } || 0;
 179             is( $@, '', "[$sock_type] closelog()" );
 180             ok( $r, "[$sock_type] closelog() should return true: '$r'" );
 181         }
 182     }
 183 }
 184
 185
 186 BEGIN { $tests += 10 }
 187 SKIP: {
 188     skip "not testing setlogsock('stream') on Win32", 10 if $is_Win32;
 189     skip "the 'unix' mechanism works, so the tests will likely fail with the 'stream' mechanism", 10
 190         if grep {/unix/} @passed;
 191
 192     # setlogsock() with "stream" and an undef path
 193     $r = eval { setlogsock("stream", undef ) } || '';
 194     is( $@, '', "setlogsock() called, with 'stream' and an undef path" );
 195     if ($is_Cygwin) {
 196         if (-x "/usr/sbin/syslog-ng") {
 197             ok( $r, "setlogsock() on Cygwin with syslog-ng should return true: '$r'" );
 198         }
 199         else {
 200             ok( !$r, "setlogsock() on Cygwin without syslog-ng should return false: '$r'" );
 201         }
 202     }
 203     else  {
 204         ok( $r, "setlogsock() should return true: '$r'" );
 205     }
 206
 207     # setlogsock() with "stream" and an empty path
 208     $r = eval { setlogsock("stream", '' ) } || '';
 209     is( $@, '', "setlogsock() called, with 'stream' and an empty path" );
 210     ok( !$r, "setlogsock() should return false: '$r'" );
 211
 212     # setlogsock() with "stream" and /dev/null
 213     $r = eval { setlogsock("stream", '/dev/null' ) } || '';
 214     is( $@, '', "setlogsock() called, with 'stream' and '/dev/null'" );
 215     ok( $r, "setlogsock() should return true: '$r'" );
 216
 217     # setlogsock() with "stream" and a non-existing file
 218     $r = eval { setlogsock("stream", 'test.log' ) } || '';
 219     is( $@, '', "setlogsock() called, with 'stream' and 'test.log' (file does not exist)" );
 220     ok( !$r, "setlogsock() should return false: '$r'" );
 221
 222     # setlogsock() with "stream" and a local file
 223     SKIP: {
 224         my $logfile = "test.log";
 225         open(LOG, ">$logfile") or skip "can't create file '$logfile': $!", 2;
 226         close(LOG);
 227         $r = eval { setlogsock("stream", $logfile ) } || '';
 228         is( $@, '', "setlogsock() called, with 'stream' and '$logfile' (file exists)" );
 229         ok( $r, "setlogsock() should return true: '$r'" );
 230         unlink($logfile);
 231     }
 232 }
 233
 234
 235 BEGIN { $tests += 3 + 4 * 3 }
 236 # setlogmask()
 237 {
 238     my $oldmask = 0;
 239
 240     $oldmask = eval { setlogmask(0) } || 0;
 241     is( $@, '', "setlogmask() called with a null mask" );
 242     $r = eval { setlogmask(0) } || 0;
 243     is( $@, '', "setlogmask() called with a null mask (second time)" );
 244     is( $r, $oldmask, "setlogmask() must return the same mask as previous call");
 245
 246     my @masks = (
 247         LOG_MASK(LOG_ERR()),
 248         ~LOG_MASK(LOG_INFO()),
 249         LOG_MASK(LOG_CRIT()) | LOG_MASK(LOG_ERR()) | LOG_MASK(LOG_WARNING()),
 250     );
 251
 252     for my $newmask (@masks) {
 253         $r = eval { setlogmask($newmask) } || 0;
 254         is( $@, '', "setlogmask() called with a new mask" );
 255         is( $r, $oldmask, "setlogmask() must return the same mask as previous call");
 256         $r = eval { setlogmask(0) } || 0;
 257         is( $@, '', "setlogmask() called with a null mask" );
 258         is( $r, $newmask, "setlogmask() must return the new mask");
 259         setlogmask($oldmask);
 260     }
 261 }