This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fw: CPAN Upload: S/SA/SAPER/Sys-Syslog-0.20.tar.gz
[perl5.git] / 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 * 7 }
115 # try to open a syslog using all the available connection methods
116 my @passed = ();
117 for my $sock_type (qw(native eventlog unix stream inet tcp udp)) {
118     SKIP: {
119         skip "the 'unix' mechanism works, so the tests will likely fail with the 'stream' mechanism", 20 
120             if $sock_type eq 'stream' and grep {/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 }