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