xref: /openbsd/regress/usr.sbin/syslogd/funcs.pl (revision 29e70a6f) 
1#	$OpenBSD: funcs.pl,v 1.29 2015/12/30 13:15:52 bluhm Exp $
2
3# Copyright (c) 2010-2015 Alexander Bluhm <bluhm@openbsd.org>
4#
5# Permission to use, copy, modify, and distribute this software for any
6# purpose with or without fee is hereby granted, provided that the above
7# copyright notice and this permission notice appear in all copies.
8#
9# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
17use strict;
18use warnings;
19no warnings 'experimental::smartmatch';
20use feature 'switch';
21use Errno;
22use List::Util qw(first);
23use Socket;
24use Socket6;
25use Sys::Syslog qw(:standard :extended :macros);
26use Time::HiRes 'sleep';
27use IO::Socket;
28use IO::Socket::INET6;
29
30my $firstlog = "syslogd regress test first message";
31my $secondlog = "syslogd regress test second message";
32my $thirdlog = "syslogd regress test third message";
33my $testlog = "syslogd regress test log message";
34my $downlog = "syslogd regress client shutdown";
35my $charlog = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
36
37sub find_ports {
38	my %args = @_;
39	my $num    = delete $args{num}    // 1;
40	my $domain = delete $args{domain} // AF_INET;
41	my $addr   = delete $args{addr}   // "127.0.0.1";
42	my $proto  = delete $args{proto}  // "udp";
43	$proto = "tcp" if $proto eq "tls";
44
45	my @sockets = (1..$num);
46	foreach my $s (@sockets) {
47		$s = IO::Socket::INET6->new(
48		    Domain    => $domain,
49		    LocalAddr => $addr,
50		    Proto     => $proto,
51		) or die "find_ports: create and bind socket failed: $!";
52	}
53	my @ports = map { $_->sockport() } @sockets;
54
55	return wantarray ? @ports : $ports[0];
56}
57
58########################################################################
59# Client funcs
60########################################################################
61
62sub write_log {
63	my $self = shift;
64
65	write_message($self, $testlog);
66	IO::Handle::flush(\*STDOUT);
67	${$self->{syslogd}}->loggrep($testlog, 2);
68	write_shutdown($self);
69}
70
71sub write_between2logs {
72	my $self = shift;
73	my $func = shift;
74
75	write_message($self, $firstlog);
76	$func->($self, @_);
77	write_message($self, $testlog);
78	IO::Handle::flush(\*STDOUT);
79	${$self->{syslogd}}->loggrep($testlog, 2);
80	write_shutdown($self);
81}
82
83sub write_message {
84	my $self = shift;
85
86	if (defined($self->{connectdomain})) {
87		my $msg = join("", @_);
88		if ($self->{connectdomain} eq "sendsyslog") {
89			if (($self->{connect}{version} || 0) == 2) {
90				my $flags = $self->{connect}{flags} || 0;
91				sendsyslog2($msg, $flags) or die ref($self),
92				    " sendsyslog2 failed: $!";
93			} else {
94				sendsyslog($msg) or die ref($self),
95				    " sendsyslog failed: $!";
96			}
97		} elsif ($self->{connectproto} eq "udp") {
98			# writing UDP packets works only with syswrite()
99			defined(my $n = syswrite(STDOUT, $msg))
100			    or die ref($self), " write log line failed: $!";
101			$n == length($msg)
102			    or die ref($self), " short UDP write";
103		} else {
104			print $msg;
105			print "\n" if $self->{connectproto} =~ /^(tcp|tls)$/;
106		}
107		print STDERR "<<< $msg\n";
108	} else {
109		syslog(LOG_INFO, @_);
110	}
111}
112
113sub sendsyslog {
114	my $msg = shift;
115	require 'sys/syscall.ph';
116	return syscall(&SYS_sendsyslog, $msg, length($msg)) != -1;
117}
118
119sub sendsyslog2 {
120	my $msg = shift;
121	my $flags = shift;
122	require 'sys/syscall.ph';
123	return syscall(&SYS_sendsyslog2, $msg, length($msg), $flags) != -1;
124}
125
126sub write_shutdown {
127	my $self = shift;
128
129	setlogsock("native")
130	    or die ref($self), " setlogsock native failed: $!";
131	syslog(LOG_NOTICE, $downlog);
132}
133
134sub write_lines {
135	my $self = shift;
136	my ($lines, $lenght) = @_;
137
138	foreach (1..$lines) {
139		write_chars($self, $lenght, " $_");
140	}
141}
142
143sub write_lengths {
144	my $self = shift;
145	my ($lenghts, $tail) = ref $_[0] ? @_ : [@_];
146
147	write_chars($self, $lenghts, $tail);
148}
149
150sub generate_chars {
151	my ($len) = @_;
152
153	my $msg = "";
154	my $char = '0';
155	for (my $i = 0; $i < $len; $i++) {
156		$msg .= $char;
157		given ($char) {
158			when(/9/)       { $char = 'A' }
159			when(/Z/)       { $char = 'a' }
160			when(/z/)       { $char = '0' }
161			default         { $char++ }
162		}
163	}
164	return $msg;
165}
166
167sub write_chars {
168	my $self = shift;
169	my ($length, $tail) = @_;
170
171	foreach my $len (ref $length ? @$length : $length) {
172		my $t = $tail // "";
173		substr($t, 0, length($t) - $len, "")
174		    if length($t) && length($t) > $len;
175		my $msg = generate_chars($len - length($t));
176		$msg .= $t if length($t);
177		write_message($self, $msg);
178		# if client is sending too fast, syslogd will not see everything
179		sleep .01;
180	}
181}
182
183sub write_unix {
184	my $self = shift;
185	my $path = shift || "/dev/log";
186	my $id = shift // $path;
187
188	my $u = IO::Socket::UNIX->new(
189	    Type  => SOCK_DGRAM,
190	    Peer => $path,
191	) or die ref($self), " connect to $path unix socket failed: $!";
192	my $msg = "id $id unix socket: $testlog";
193	print $u $msg;
194	print STDERR "<<< $msg\n";
195}
196
197sub write_tcp {
198	my $self = shift;
199	my $fh = shift || \*STDOUT;
200	my $id = shift // $fh;
201
202	my $msg = "id $id tcp socket: $testlog";
203	print $fh "$msg\n";
204	print STDERR "<<< $msg\n";
205}
206
207########################################################################
208# Server funcs
209########################################################################
210
211sub read_log {
212	my $self = shift;
213
214	read_message($self, $downlog);
215}
216
217sub read_between2logs {
218	my $self = shift;
219	my $func = shift;
220
221	unless ($self->{redo}) {
222		read_message($self, $firstlog);
223	}
224	$func->($self, @_);
225	unless ($self->{redo}) {
226		read_message($self, $testlog);
227		read_message($self, $downlog);
228	}
229}
230
231sub read_message {
232	my $self = shift;
233	my $regex = shift;
234
235	local $_;
236	for (;;) {
237		if ($self->{listenproto} eq "udp") {
238			# reading UDP packets works only with sysread()
239			defined(my $n = sysread(STDIN, $_, 8194))
240			    or die ref($self), " read log line failed: $!";
241			last if $n == 0;
242		} else {
243			defined($_ = <STDIN>)
244			    or last;
245		}
246		chomp;
247		print STDERR ">>> $_\n";
248		last if /$regex/;
249	}
250}
251
252########################################################################
253# Script funcs
254########################################################################
255
256sub get_testlog {
257	return $testlog;
258}
259
260sub get_testgrep {
261	return qr/$testlog\r*$/;
262}
263
264sub get_firstlog {
265	return $firstlog;
266}
267
268sub get_secondlog {
269	return $secondlog;
270}
271
272sub get_thirdlog {
273	return $thirdlog;
274}
275
276sub get_charlog {
277	# add a space so that we match at the beginning of the message
278	return " $charlog";
279}
280
281sub get_between2loggrep {
282	return (
283	    qr/$firstlog/ => 1,
284	    qr/$testlog/ => 1,
285	);
286}
287
288sub get_downlog {
289	return $downlog;
290}
291
292sub check_logs {
293	my ($c, $r, $s, $m, %args) = @_;
294
295	return if $args{nocheck};
296
297	check_log($c, $r, $s, @$m);
298	check_out($r, %args);
299	check_fstat($c, $r, $s);
300	check_ktrace($c, $r, $s);
301	if (my $file = $s->{"outfile"}) {
302		my $pattern = $s->{filegrep} || get_testgrep();
303		check_pattern(ref $s, $file, $pattern, \&filegrep);
304	}
305	check_multifile(@{$args{multifile} || []});
306}
307
308sub compare($$) {
309	local $_ = $_[1];
310	if (/^\d+/) {
311		return $_[0] == $_;
312	} elsif (/^==(\d+)/) {
313		return $_[0] == $1;
314	} elsif (/^!=(\d+)/) {
315		return $_[0] != $1;
316	} elsif (/^>=(\d+)/) {
317		return $_[0] >= $1;
318	} elsif (/^<=(\d+)/) {
319		return $_[0] <= $1;
320	} elsif (/^~(\d+)/) {
321		return $1 * 0.8 <= $_[0] && $_[0] <= $1 * 1.2;
322	}
323	die "bad compare operator: $_";
324}
325
326sub check_pattern {
327	my ($name, $proc, $pattern, $func) = @_;
328
329	$pattern = [ $pattern ] unless ref($pattern) eq 'ARRAY';
330	foreach my $pat (@$pattern) {
331		if (ref($pat) eq 'HASH') {
332			foreach my $re (sort keys %$pat) {
333				my $num = $pat->{$re};
334				my @matches = $func->($proc, $re);
335				compare(@matches, $num)
336				    or die "$name matches '@matches': ",
337				    "'$re' => $num";
338			}
339		} else {
340			$func->($proc, $pat)
341			    or die "$name log missing pattern: $pat";
342		}
343	}
344}
345
346sub check_log {
347	foreach my $proc (@_) {
348		next unless $proc && !$proc->{nocheck};
349		my $pattern = $proc->{loggrep} || get_testgrep();
350		check_pattern(ref $proc, $proc, $pattern, \&loggrep);
351	}
352}
353
354sub loggrep {
355	my ($proc, $pattern) = @_;
356
357	return $proc->loggrep($pattern);
358}
359
360sub check_out {
361	my ($r, %args) = @_;
362
363	unless ($args{pipe}{nocheck}) {
364		$r->loggrep("bytes transferred", 1) or sleep 1;
365	}
366	foreach my $dev (qw(console user)) {
367		$args{$dev}{nocheck} ||= $args{tty}{nocheck};
368		$args{$dev}{loggrep} ||= $args{tty}{loggrep};
369		next if $args{$dev}{nocheck};
370		my $ctl = $r->{"ctl$dev"};
371		close($ctl);
372		my $file = $r->{"out$dev"};
373		open(my $fh, '<', $file)
374		    or die "Open file $file for reading failed: $!";
375		grep { /^logout/ or /^console .* off/ } <$fh> or sleep 1;
376		close($fh);
377	}
378
379	foreach my $name (qw(file pipe console user)) {
380		next if $args{$name}{nocheck};
381		my $file = $r->{"out$name"} or die;
382		my $pattern = $args{$name}{loggrep} || get_testgrep();
383		check_pattern($name, $file, $pattern, \&filegrep);
384	}
385}
386
387sub check_fstat {
388	foreach my $proc (@_) {
389		my $pattern = $proc && $proc->{fstat} or next;
390		my $file = $proc->{fstatfile} or die;
391		check_pattern("fstat", $file, $pattern, \&filegrep);
392	}
393}
394
395sub filegrep {
396	my ($file, $pattern) = @_;
397
398	open(my $fh, '<', $file)
399	    or die "Open file $file for reading failed: $!";
400	return wantarray ?
401	    grep { /$pattern/ } <$fh> : first { /$pattern/ } <$fh>;
402}
403
404sub check_ktrace {
405	foreach my $proc (@_) {
406		my $pattern = $proc && $proc->{ktrace} or next;
407		my $file = $proc->{ktracefile} or die;
408		check_pattern("ktrace", $file, $pattern, \&kdumpgrep);
409	}
410}
411
412sub kdumpgrep {
413	my ($file, $pattern) = @_;
414
415	my @sudo = ! -r $file && $ENV{SUDO} ? $ENV{SUDO} : ();
416	my @cmd = (@sudo, "kdump", "-f", $file);
417	open(my $fh, '-|', @cmd)
418	    or die "Open pipe from '@cmd' failed: $!";
419	my @matches = grep { /$pattern/ } <$fh>;
420	close($fh) or die $! ?
421	    "Close pipe from '@cmd' failed: $!" :
422	    "Command '@cmd' failed: $?";
423	return wantarray ? @matches : $matches[0];
424}
425
426sub create_multifile {
427	for (my $i = 0; $i < @_; $i++) {
428		my $file = "file-$i.log";
429		open(my $fh, '>', $file)
430		    or die "Create $file failed: $!";
431	}
432}
433
434sub check_multifile {
435	for (my $i = 0; $i < @_; $i++) {
436		my $file = "file-$i.log";
437		my $pattern = $_[$i]{loggrep} or die;
438		check_pattern("multifile $i", $file, $pattern, \&filegrep);
439	}
440}
441
4421;
443