xref: /openbsd/regress/usr.sbin/syslogd/funcs.pl (revision 7b30e940) 
1#	$OpenBSD: funcs.pl,v 1.26 2015/10/19 20:16:09 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			sendsyslog($msg)
90			    or die ref($self), " sendsyslog failed: $!";
91		} elsif ($self->{connectproto} eq "udp") {
92			# writing UDP packets works only with syswrite()
93			defined(my $n = syswrite(STDOUT, $msg))
94			    or die ref($self), " write log line failed: $!";
95			$n == length($msg)
96			    or die ref($self), " short UDP write";
97		} else {
98			print $msg;
99			print "\n" if $self->{connectproto} =~ /^(tcp|tls)$/;
100		}
101		print STDERR "<<< $msg\n";
102	} else {
103		syslog(LOG_INFO, @_);
104	}
105}
106
107sub sendsyslog {
108	my $msg = shift;
109	require 'sys/syscall.ph';
110	return syscall(&SYS_sendsyslog, $msg, length($msg)) != -1;
111}
112
113sub write_shutdown {
114	my $self = shift;
115
116	setlogsock("native")
117	    or die ref($self), " setlogsock native failed: $!";
118	syslog(LOG_NOTICE, $downlog);
119}
120
121sub write_lines {
122	my $self = shift;
123	my ($lines, $lenght) = @_;
124
125	foreach (1..$lines) {
126		write_chars($self, $lenght, " $_");
127	}
128}
129
130sub write_lengths {
131	my $self = shift;
132	my ($lenghts, $tail) = ref $_[0] ? @_ : [@_];
133
134	write_chars($self, $lenghts, $tail);
135}
136
137sub generate_chars {
138	my ($len) = @_;
139
140	my $msg = "";
141	my $char = '0';
142	for (my $i = 0; $i < $len; $i++) {
143		$msg .= $char;
144		given ($char) {
145			when(/9/)       { $char = 'A' }
146			when(/Z/)       { $char = 'a' }
147			when(/z/)       { $char = '0' }
148			default         { $char++ }
149		}
150	}
151	return $msg;
152}
153
154sub write_chars {
155	my $self = shift;
156	my ($length, $tail) = @_;
157
158	foreach my $len (ref $length ? @$length : $length) {
159		my $t = $tail // "";
160		substr($t, 0, length($t) - $len, "")
161		    if length($t) && length($t) > $len;
162		my $msg = generate_chars($len - length($t));
163		$msg .= $t if length($t);
164		write_message($self, $msg);
165		# if client is sending too fast, syslogd will not see everything
166		sleep .01;
167	}
168}
169
170sub write_unix {
171	my $self = shift;
172	my $path = shift || "/dev/log";
173	my $id = shift // $path;
174
175	my $u = IO::Socket::UNIX->new(
176	    Type  => SOCK_DGRAM,
177	    Peer => $path,
178	) or die ref($self), " connect to $path unix socket failed: $!";
179	my $msg = "id $id unix socket: $testlog";
180	print $u $msg;
181	print STDERR "<<< $msg\n";
182}
183
184sub write_tcp {
185	my $self = shift;
186	my $fh = shift || \*STDOUT;
187	my $id = shift // $fh;
188
189	my $msg = "id $id tcp socket: $testlog";
190	print $fh "$msg\n";
191	print STDERR "<<< $msg\n";
192}
193
194########################################################################
195# Server funcs
196########################################################################
197
198sub read_log {
199	my $self = shift;
200
201	read_message($self, $downlog);
202}
203
204sub read_between2logs {
205	my $self = shift;
206	my $func = shift;
207
208	unless ($self->{redo}) {
209		read_message($self, $firstlog);
210	}
211	$func->($self, @_);
212	unless ($self->{redo}) {
213		read_message($self, $testlog);
214		read_message($self, $downlog);
215	}
216}
217
218sub read_message {
219	my $self = shift;
220	my $regex = shift;
221
222	local $_;
223	for (;;) {
224		if ($self->{listenproto} eq "udp") {
225			# reading UDP packets works only with sysread()
226			defined(my $n = sysread(STDIN, $_, 8194))
227			    or die ref($self), " read log line failed: $!";
228			last if $n == 0;
229		} else {
230			defined($_ = <STDIN>)
231			    or last;
232		}
233		chomp;
234		print STDERR ">>> $_\n";
235		last if /$regex/;
236	}
237}
238
239########################################################################
240# Script funcs
241########################################################################
242
243sub get_testlog {
244	return $testlog;
245}
246
247sub get_testgrep {
248	return qr/$testlog\r*$/;
249}
250
251sub get_firstlog {
252	return $firstlog;
253}
254
255sub get_secondlog {
256	return $secondlog;
257}
258
259sub get_thirdlog {
260	return $thirdlog;
261}
262
263sub get_charlog {
264	# add a space so that we match at the beginning of the message
265	return " $charlog";
266}
267
268sub get_between2loggrep {
269	return (
270	    qr/$firstlog/ => 1,
271	    qr/$testlog/ => 1,
272	);
273}
274
275sub get_downlog {
276	return $downlog;
277}
278
279sub check_logs {
280	my ($c, $r, $s, $m, %args) = @_;
281
282	return if $args{nocheck};
283
284	check_log($c, $r, $s, @$m);
285	check_out($r, %args);
286	check_fstat($c, $r, $s);
287	check_ktrace($c, $r, $s);
288	if (my $file = $s->{"outfile"}) {
289		my $pattern = $s->{filegrep} || get_testgrep();
290		check_pattern(ref $s, $file, $pattern, \&filegrep);
291	}
292	check_multifile(@{$args{multifile} || []});
293}
294
295sub compare($$) {
296	local $_ = $_[1];
297	if (/^\d+/) {
298		return $_[0] == $_;
299	} elsif (/^==(\d+)/) {
300		return $_[0] == $1;
301	} elsif (/^!=(\d+)/) {
302		return $_[0] != $1;
303	} elsif (/^>=(\d+)/) {
304		return $_[0] >= $1;
305	} elsif (/^<=(\d+)/) {
306		return $_[0] <= $1;
307	} elsif (/^~(\d+)/) {
308		return $1 * 0.8 <= $_[0] && $_[0] <= $1 * 1.2;
309	}
310	die "bad compare operator: $_";
311}
312
313sub check_pattern {
314	my ($name, $proc, $pattern, $func) = @_;
315
316	$pattern = [ $pattern ] unless ref($pattern) eq 'ARRAY';
317	foreach my $pat (@$pattern) {
318		if (ref($pat) eq 'HASH') {
319			foreach my $re (sort keys %$pat) {
320				my $num = $pat->{$re};
321				my @matches = $func->($proc, $re);
322				compare(@matches, $num)
323				    or die "$name matches '@matches': ",
324				    "'$re' => $num";
325			}
326		} else {
327			$func->($proc, $pat)
328			    or die "$name log missing pattern: $pat";
329		}
330	}
331}
332
333sub check_log {
334	foreach my $proc (@_) {
335		next unless $proc && !$proc->{nocheck};
336		my $pattern = $proc->{loggrep} || get_testgrep();
337		check_pattern(ref $proc, $proc, $pattern, \&loggrep);
338	}
339}
340
341sub loggrep {
342	my ($proc, $pattern) = @_;
343
344	return $proc->loggrep($pattern);
345}
346
347sub check_out {
348	my ($r, %args) = @_;
349
350	unless ($args{pipe}{nocheck}) {
351		$r->loggrep("bytes transferred", 1) or sleep 1;
352	}
353
354	foreach my $name (qw(file pipe tty)) {
355		next if $args{$name}{nocheck};
356		my $file = $r->{"out$name"} or die;
357		my $pattern = $args{$name}{loggrep} || get_testgrep();
358		check_pattern($name, $file, $pattern, \&filegrep);
359	}
360}
361
362sub check_fstat {
363	foreach my $proc (@_) {
364		my $pattern = $proc && $proc->{fstat} or next;
365		my $file = $proc->{fstatfile} or die;
366		check_pattern("fstat", $file, $pattern, \&filegrep);
367	}
368}
369
370sub filegrep {
371	my ($file, $pattern) = @_;
372
373	open(my $fh, '<', $file)
374	    or die "Open file $file for reading failed: $!";
375	return wantarray ?
376	    grep { /$pattern/ } <$fh> : first { /$pattern/ } <$fh>;
377}
378
379sub check_ktrace {
380	foreach my $proc (@_) {
381		my $pattern = $proc && $proc->{ktrace} or next;
382		my $file = $proc->{ktracefile} or die;
383		check_pattern("ktrace", $file, $pattern, \&kdumpgrep);
384	}
385}
386
387sub kdumpgrep {
388	my ($file, $pattern) = @_;
389
390	my @sudo = ! -r $file && $ENV{SUDO} ? $ENV{SUDO} : ();
391	my @cmd = (@sudo, "kdump", "-f", $file);
392	open(my $fh, '-|', @cmd)
393	    or die "Open pipe from '@cmd' failed: $!";
394	my @matches = grep { /$pattern/ } <$fh>;
395	close($fh) or die $! ?
396	    "Close pipe from '@cmd' failed: $!" :
397	    "Command '@cmd' failed: $?";
398	return wantarray ? @matches : $matches[0];
399}
400
401sub create_multifile {
402	for (my $i = 0; $i < @_; $i++) {
403		my $file = "file-$i.log";
404		open(my $fh, '>', $file)
405		    or die "Create $file failed: $!";
406	}
407}
408
409sub check_multifile {
410	for (my $i = 0; $i < @_; $i++) {
411		my $file = "file-$i.log";
412		my $pattern = $_[$i]{loggrep} or die;
413		check_pattern("multifile $i", $file, $pattern, \&filegrep);
414	}
415}
416
4171;
418