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