1#!perl -T 2 3use strict; 4use Config; 5use File::Spec; 6use 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 10no warnings; 11use 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 19my $is_Win32 = $^O =~ /win32/i; 20my $is_Cygwin = $^O =~ /cygwin/i; 21 22# if testing in core, check that the module is at least available 23if ($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 29plan skip_all => "Socket was not build" 30 unless $Config{'extensions'} =~ /\bSocket\b/; 31 32my $tests; 33plan tests => $tests; 34 35# any remaining warning should be severly punished 36BEGIN { eval "use Test::NoWarnings"; $tests = $@ ? 0 : 1; } 37 38BEGIN { $tests += 1 } 39# ok, now loads them 40eval 'use Socket'; 41use_ok('Sys::Syslog', ':standard', ':extended', ':macros'); 42 43BEGIN { $tests += 1 } 44# check that the documented functions are correctly provided 45can_ok( 'Sys::Syslog' => qw(openlog syslog syslog setlogmask setlogsock closelog) ); 46 47 48BEGIN { $tests += 1 } 49# check the diagnostics 50# setlogsock() 51eval { setlogsock() }; 52like( $@, qr/^Invalid argument passed to setlogsock/, 53 "calling setlogsock() with no argument" ); 54 55BEGIN { $tests += 3 } 56# syslog() 57eval { syslog() }; 58like( $@, qr/^syslog: expecting argument \$priority/, 59 "calling syslog() with no argument" ); 60 61eval { syslog(undef) }; 62like( $@, qr/^syslog: expecting argument \$priority/, 63 "calling syslog() with one undef argument" ); 64 65eval { syslog('') }; 66like( $@, qr/^syslog: expecting argument \$format/, 67 "calling syslog() with one empty argument" ); 68 69 70my $test_string = "uid $< is testing Perl $] syslog(3) capabilities"; 71my $r = 0; 72 73BEGIN { $tests += 8 } 74# try to open a syslog using a Unix or stream socket 75SKIP: { 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 111BEGIN { $tests += 22 * 8 } 112# try to open a syslog using all the available connection methods 113my @passed = (); 114for 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 188BEGIN { $tests += 10 } 189SKIP: { 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 240BEGIN { $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} 267