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