cpan/Sys-Syslog/t/syslog.t

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