xref: /openbsd/regress/usr.sbin/syslogd/funcs.pl (revision 2722e17a) 
1#	$OpenBSD: funcs.pl,v 1.32 2017/04/07 15:49:46 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 selector2config {
282    my %s2m = @_;
283    my $conf = "";
284    my $i = 0;
285    foreach my $sel (sort keys %s2m) {
286	$conf .= "$sel\t\$objdir/file-$i.log\n";
287	$i++;
288    }
289    return $conf;
290}
291
292sub selector2loggrep {
293    my %s2m = @_;
294    my %allmsg;
295    @allmsg{map { @$_} values %s2m} = ();
296    my @loggrep;
297    foreach my $sel (sort keys %s2m) {
298	my @m = @{$s2m{$sel}};
299	my %msg;
300	$msg{$_}++ foreach (@m);
301	my %nomsg = %allmsg;
302	delete @nomsg{@m};
303	push @loggrep, {
304	    (map { qr/: $_$/ => $msg{$_} } sort keys %msg),
305	    (map { qr/: $_$/ => 0 } sort keys %nomsg),
306	};
307    }
308    return @loggrep;
309}
310
311sub check_logs {
312	my ($c, $r, $s, $m, %args) = @_;
313
314	return if $args{nocheck};
315
316	check_log($c, $r, $s, @$m);
317	check_out($r, %args);
318	check_fstat($c, $r, $s);
319	check_ktrace($c, $r, $s);
320	if (my $file = $s->{"outfile"}) {
321		my $pattern = $s->{filegrep} || get_testgrep();
322		check_pattern(ref $s, $file, $pattern, \&filegrep);
323	}
324	check_multifile(@{$args{multifile} || []});
325}
326
327sub compare($$) {
328	local $_ = $_[1];
329	if (/^\d+/) {
330		return $_[0] == $_;
331	} elsif (/^==(\d+)/) {
332		return $_[0] == $1;
333	} elsif (/^!=(\d+)/) {
334		return $_[0] != $1;
335	} elsif (/^>=(\d+)/) {
336		return $_[0] >= $1;
337	} elsif (/^<=(\d+)/) {
338		return $_[0] <= $1;
339	} elsif (/^~(\d+)/) {
340		return $1 * 0.8 <= $_[0] && $_[0] <= $1 * 1.2;
341	}
342	die "bad compare operator: $_";
343}
344
345sub check_pattern {
346	my ($name, $proc, $pattern, $func) = @_;
347
348	$pattern = [ $pattern ] unless ref($pattern) eq 'ARRAY';
349	foreach my $pat (@$pattern) {
350		if (ref($pat) eq 'HASH') {
351			foreach my $re (sort keys %$pat) {
352				my $num = $pat->{$re};
353				my @matches = $func->($proc, $re);
354				compare(@matches, $num)
355				    or die "$name matches '@matches': ",
356				    "'$re' => $num";
357			}
358		} else {
359			$func->($proc, $pat)
360			    or die "$name log missing pattern: $pat";
361		}
362	}
363}
364
365sub check_log {
366	foreach my $proc (@_) {
367		next unless $proc && !$proc->{nocheck};
368		my $pattern = $proc->{loggrep} || get_testgrep();
369		check_pattern(ref $proc, $proc, $pattern, \&loggrep);
370	}
371}
372
373sub loggrep {
374	my ($proc, $pattern) = @_;
375
376	return $proc->loggrep($pattern);
377}
378
379sub check_out {
380	my ($r, %args) = @_;
381
382	unless ($args{pipe}{nocheck}) {
383		$r->loggrep("bytes transferred", 1) or sleep 1;
384	}
385	foreach my $dev (qw(console user)) {
386		$args{$dev}{nocheck} ||= $args{tty}{nocheck};
387		$args{$dev}{loggrep} ||= $args{tty}{loggrep};
388		next if $args{$dev}{nocheck};
389		my $ctl = $r->{"ctl$dev"};
390		close($ctl);
391		my $file = $r->{"out$dev"};
392		open(my $fh, '<', $file)
393		    or die "Open file $file for reading failed: $!";
394		grep { /^logout/ or /^console .* off/ } <$fh> or sleep 1;
395		close($fh);
396	}
397
398	foreach my $name (qw(file pipe console user)) {
399		next if $args{$name}{nocheck};
400		my $file = $r->{"out$name"} or die;
401		my $pattern = $args{$name}{loggrep} || get_testgrep();
402		check_pattern($name, $file, $pattern, \&filegrep);
403	}
404}
405
406sub check_fstat {
407	foreach my $proc (@_) {
408		my $pattern = $proc && $proc->{fstat} or next;
409		my $file = $proc->{fstatfile} or die;
410		check_pattern("fstat", $file, $pattern, \&filegrep);
411	}
412}
413
414sub filegrep {
415	my ($file, $pattern) = @_;
416
417	open(my $fh, '<', $file)
418	    or die "Open file $file for reading failed: $!";
419	return wantarray ?
420	    grep { /$pattern/ } <$fh> : first { /$pattern/ } <$fh>;
421}
422
423sub check_ktrace {
424	foreach my $proc (@_) {
425		my $pattern = $proc && $proc->{ktrace} or next;
426		my $file = $proc->{ktracefile} or die;
427		check_pattern("ktrace", $file, $pattern, \&kdumpgrep);
428	}
429}
430
431sub kdumpgrep {
432	my ($file, $pattern) = @_;
433
434	my @sudo = ! -r $file && $ENV{SUDO} ? $ENV{SUDO} : ();
435	my @cmd = (@sudo, "kdump", "-f", $file);
436	open(my $fh, '-|', @cmd)
437	    or die "Open pipe from '@cmd' failed: $!";
438	my @matches = grep { /$pattern/ } <$fh>;
439	close($fh) or die $! ?
440	    "Close pipe from '@cmd' failed: $!" :
441	    "Command '@cmd' failed: $?";
442	return wantarray ? @matches : $matches[0];
443}
444
445sub create_multifile {
446	for (my $i = 0; $i < @_; $i++) {
447		my $file = "file-$i.log";
448		open(my $fh, '>', $file)
449		    or die "Create $file failed: $!";
450	}
451}
452
453sub check_multifile {
454	for (my $i = 0; $i < @_; $i++) {
455		my $file = "file-$i.log";
456		my $pattern = $_[$i]{loggrep} or die;
457		check_pattern("multifile $i", $file, $pattern, \&filegrep);
458	}
459}
460
4611;
462