summary refs log tree commit diff stats
path: root/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'scripts')
-rwxr-xr-xscripts/checkpatch.pl95
-rw-r--r--scripts/cocci-macro-file.h24
-rwxr-xr-xscripts/fix-multiline-comments.sh62
-rwxr-xr-xscripts/gtester-cat26
-rwxr-xr-xscripts/tap-driver.pl378
-rwxr-xr-xscripts/tap-merge.pl110
6 files changed, 633 insertions, 62 deletions
diff --git a/scripts/checkpatch.pl b/scripts/checkpatch.pl
index 18e16b79df..d10dddf1be 100755
--- a/scripts/checkpatch.pl
+++ b/scripts/checkpatch.pl
@@ -7,6 +7,7 @@
 
 use strict;
 use warnings;
+use Term::ANSIColor qw(:constants);
 
 my $P = $0;
 $P =~ s@.*/@@g;
@@ -26,6 +27,7 @@ my $tst_only;
 my $emacs = 0;
 my $terse = 0;
 my $file = undef;
+my $color = "auto";
 my $no_warnings = 0;
 my $summary = 1;
 my $mailback = 0;
@@ -64,6 +66,8 @@ Options:
                              is all off)
   --test-only=WORD           report only warnings/errors containing WORD
                              literally
+  --color[=WHEN]             Use colors 'always', 'never', or only when output
+                             is a terminal ('auto'). Default is 'auto'.
   -h, --help, --version      display this help and exit
 
 When FILE is - read standard input.
@@ -72,6 +76,14 @@ EOM
 	exit($exitcode);
 }
 
+# Perl's Getopt::Long allows options to take optional arguments after a space.
+# Prevent --color by itself from consuming other arguments
+foreach (@ARGV) {
+	if ($_ eq "--color" || $_ eq "-color") {
+		$_ = "--color=$color";
+	}
+}
+
 GetOptions(
 	'q|quiet+'	=> \$quiet,
 	'tree!'		=> \$tree,
@@ -89,6 +101,8 @@ GetOptions(
 
 	'debug=s'	=> \%debug,
 	'test-only=s'	=> \$tst_only,
+	'color=s'       => \$color,
+	'no-color'      => sub { $color = 'never'; },
 	'h|help'	=> \$help,
 	'version'	=> \$help
 ) or help(1);
@@ -144,6 +158,16 @@ if (!$chk_patch && !$chk_branch && !$file) {
 	die "One of --file, --branch, --patch is required\n";
 }
 
+if ($color =~ /^always$/i) {
+	$color = 1;
+} elsif ($color =~ /^never$/i) {
+	$color = 0;
+} elsif ($color =~ /^auto$/i) {
+	$color = (-t STDOUT);
+} else {
+	die "Invalid color mode: $color\n";
+}
+
 my $dbg_values = 0;
 my $dbg_possible = 0;
 my $dbg_type = 0;
@@ -339,13 +363,18 @@ my @lines = ();
 my $vname;
 if ($chk_branch) {
 	my @patches;
+	my %git_commits = ();
 	my $HASH;
-	open($HASH, "-|", "git", "log", "--format=%H", $ARGV[0]) ||
-		die "$P: git log --format=%H $ARGV[0] failed - $!\n";
-
-	while (<$HASH>) {
-		chomp;
-		push @patches, $_;
+	open($HASH, "-|", "git", "log", "--reverse", "--no-merges", "--format=%H %s", $ARGV[0]) ||
+		die "$P: git log --reverse --no-merges --format='%H %s' $ARGV[0] failed - $!\n";
+
+	for my $line (<$HASH>) {
+		$line =~ /^([0-9a-fA-F]{40,40}) (.*)$/;
+		next if (!defined($1) || !defined($2));
+		my $sha1 = $1;
+		my $subject = $2;
+		push(@patches, $sha1);
+		$git_commits{$sha1} = $subject;
 	}
 
 	close $HASH;
@@ -353,21 +382,33 @@ if ($chk_branch) {
 	die "$P: no revisions returned for revlist '$chk_branch'\n"
 	    unless @patches;
 
+	my $i = 1;
+	my $num_patches = @patches;
 	for my $hash (@patches) {
 		my $FILE;
 		open($FILE, '-|', "git", "show", $hash) ||
 			die "$P: git show $hash - $!\n";
-		$vname = $hash;
 		while (<$FILE>) {
 			chomp;
 			push(@rawlines, $_);
 		}
 		close($FILE);
+		$vname = substr($hash, 0, 12) . ' (' . $git_commits{$hash} . ')';
+		if ($num_patches > 1 && $quiet == 0) {
+			my $prefix = "$i/$num_patches";
+			$prefix = BLUE . BOLD . $prefix . RESET if $color;
+			print "$prefix Checking commit $vname\n";
+			$vname = "Patch $i/$num_patches";
+		} else {
+			$vname = "Commit " . $vname;
+		}
 		if (!process($hash)) {
 			$exit = 1;
+			print "\n" if ($num_patches > 1 && $quiet == 0);
 		}
 		@rawlines = ();
 		@lines = ();
+		$i++;
 	}
 } else {
 	for my $filename (@ARGV) {
@@ -386,6 +427,7 @@ if ($chk_branch) {
 		} else {
 			$vname = $filename;
 		}
+		print "Checking $filename...\n" if @ARGV > 1 && $quiet == 0;
 		while (<$FILE>) {
 			chomp;
 			push(@rawlines, $_);
@@ -1165,14 +1207,23 @@ sub possible {
 my $prefix = '';
 
 sub report {
-	if (defined $tst_only && $_[0] !~ /\Q$tst_only\E/) {
+	my ($level, $msg) = @_;
+	if (defined $tst_only && $msg !~ /\Q$tst_only\E/) {
 		return 0;
 	}
-	my $line = $prefix . $_[0];
 
-	$line = (split('\n', $line))[0] . "\n" if ($terse);
+	my $output = '';
+	$output .= BOLD if $color;
+	$output .= $prefix;
+	$output .= RED if $color && $level eq 'ERROR';
+	$output .= MAGENTA if $color && $level eq 'WARNING';
+	$output .= $level . ':';
+	$output .= RESET if $color;
+	$output .= ' ' . $msg . "\n";
+
+	$output = (split('\n', $output))[0] . "\n" if ($terse);
 
-	push(our @report, $line);
+	push(our @report, $output);
 
 	return 1;
 }
@@ -1180,13 +1231,13 @@ sub report_dump {
 	our @report;
 }
 sub ERROR {
-	if (report("ERROR: $_[0]\n")) {
+	if (report("ERROR", $_[0])) {
 		our $clean = 0;
 		our $cnt_error++;
 	}
 }
 sub WARN {
-	if (report("WARNING: $_[0]\n")) {
+	if (report("WARNING", $_[0])) {
 		our $clean = 0;
 		our $cnt_warn++;
 	}
@@ -2259,6 +2310,11 @@ sub process {
 			}
 		}
 
+		if ($line =~ /^.\s*(Q(?:S?LIST|SIMPLEQ|TAILQ)_HEAD)\s*\(\s*[^,]/ &&
+		    $line !~ /^.typedef/) {
+		    ERROR("named $1 should be typedefed separately\n" . $herecurr);
+		}
+
 # Need a space before open parenthesis after if, while etc
 		if ($line=~/\b(if|while|for|switch)\(/) {
 			ERROR("space required before the open parenthesis '('\n" . $herecurr);
@@ -2864,30 +2920,31 @@ sub process {
 		}
 	}
 
+	if ($is_patch && $chk_signoff && $signoff == 0) {
+		ERROR("Missing Signed-off-by: line(s)\n");
+	}
+
 	# If we have no input at all, then there is nothing to report on
 	# so just keep quiet.
 	if ($#rawlines == -1) {
-		exit(0);
+		return 1;
 	}
 
 	# In mailback mode only produce a report in the negative, for
 	# things that appear to be patches.
 	if ($mailback && ($clean == 1 || !$is_patch)) {
-		exit(0);
+		return 1;
 	}
 
 	# This is not a patch, and we are are in 'no-patch' mode so
 	# just keep quiet.
 	if (!$chk_patch && !$is_patch) {
-		exit(0);
+		return 1;
 	}
 
 	if (!$is_patch) {
 		ERROR("Does not appear to be a unified-diff format patch\n");
 	}
-	if ($is_patch && $chk_signoff && $signoff == 0) {
-		ERROR("Missing Signed-off-by: line(s)\n");
-	}
 
 	print report_dump();
 	if ($summary && !($clean == 1 && $quiet == 1)) {
diff --git a/scripts/cocci-macro-file.h b/scripts/cocci-macro-file.h
index 7e200a1023..e485cdccae 100644
--- a/scripts/cocci-macro-file.h
+++ b/scripts/cocci-macro-file.h
@@ -92,29 +92,19 @@ struct {                                                                \
 /*
  * Tail queue definitions.
  */
-#define Q_TAILQ_HEAD(name, type, qual)                                  \
-struct name {                                                           \
-        qual type *tqh_first;           /* first element */             \
-        qual type *qual *tqh_last;      /* addr of last next element */ \
-}
 #define QTAILQ_HEAD(name, type)                                         \
-struct name {                                                           \
-        type *tqh_first;      /* first element */                       \
-        type **tqh_last;      /* addr of last next element */           \
+union name {                                                            \
+        struct type *tqh_first;       /* first element */               \
+        QTailQLink tqh_circ;          /* link for last element */       \
 }
 
 #define QTAILQ_HEAD_INITIALIZER(head)                                   \
-        { NULL, &(head).tqh_first }
+        { .tqh_circ = { NULL, &(head).tqh_circ } }
 
-#define Q_TAILQ_ENTRY(type, qual)                                       \
-struct {                                                                \
-        qual type *tqe_next;            /* next element */              \
-        qual type *qual *tqe_prev;      /* address of previous next element */\
-}
 #define QTAILQ_ENTRY(type)                                              \
-struct {                                                                \
-        type *tqe_next;       /* next element */                        \
-        type **tqe_prev;      /* address of previous next element */    \
+union {                                                                 \
+        struct type *tqe_next;        /* next element */                \
+        QTailQLink tqe_circ;          /* link for prev element */       \
 }
 
 /* From glib */
diff --git a/scripts/fix-multiline-comments.sh b/scripts/fix-multiline-comments.sh
new file mode 100755
index 0000000000..93f9b10669
--- /dev/null
+++ b/scripts/fix-multiline-comments.sh
@@ -0,0 +1,62 @@
+#! /bin/sh
+#
+# Fix multiline comments to match CODING_STYLE
+#
+# Copyright (C) 2018 Red Hat, Inc.
+#
+# Author: Paolo Bonzini
+#
+# Usage: scripts/fix-multiline-comments.sh [-i] FILE...
+#
+# -i edits the file in place (requires gawk 4.1.0).
+#
+# Set the AWK environment variable to choose the awk interpreter to use
+# (default 'awk')
+
+if test "$1" = -i; then
+  # gawk extension
+  inplace="-i inplace"
+  shift
+fi
+${AWK-awk} $inplace 'BEGIN { indent = -1 }
+{
+    line = $0
+    # apply a star to the indent on lines after the first
+    if (indent != -1) {
+        if (line == "") {
+            line = sp " *"
+        } else if (substr(line, 1, indent + 2) == sp "  ") {
+            line = sp " *" substr(line, indent + 3)
+        }
+    }
+
+    is_lead = (line ~ /^[ \t]*\/\*/)
+    is_trail = (line ~ /\*\//)
+    if (is_lead && !is_trail) {
+        # grab the indent at the start of a comment, but not for
+        # single-line comments
+        match(line, /^[ \t]*\/\*/)
+        indent = RLENGTH - 2
+        sp = substr(line, 1, indent)
+    }
+
+    # the regular expression filters out lone /*, /**, or */
+    if (indent != -1 && !(line ~ /^[ \t]*(\/\*+|\*\/)[ \t]*$/)) {
+        if (is_lead) {
+            # split the leading /* or /** on a separate line
+            match(line, /^[ \t]*\/\*+/)
+            lead = substr(line, 1, RLENGTH)
+            match(line, /^[ \t]*\/\*+[ \t]*/)
+            line = lead "\n" sp " *" substr(line, RLENGTH)
+        }
+        if (is_trail) {
+            # split the trailing */ on a separate line
+            match(line, /[ \t]*\*\//)
+            line = substr(line, 1, RSTART - 1) "\n" sp " */"
+        }
+    }
+    if (is_trail) {
+        indent = -1
+    }
+    print line
+}' "$@"
diff --git a/scripts/gtester-cat b/scripts/gtester-cat
deleted file mode 100755
index 061a952cad..0000000000
--- a/scripts/gtester-cat
+++ /dev/null
@@ -1,26 +0,0 @@
-#!/bin/sh
-#
-# Copyright IBM, Corp. 2012
-#
-# Authors:
-#  Anthony Liguori <aliguori@us.ibm.com>
-#
-# This work is licensed under the terms of the GNU GPLv2 or later.
-# See the COPYING file in the top-level directory.
-
-cat <<EOF
-<?xml version="1.0"?>
-<gtester>
- <info>
-  <package>qemu</package>
-  <version>0.0</version>
-  <revision>rev</revision>
- </info>
-EOF
-
-sed \
-  -e '/<?xml/d' \
-  -e '/^<gtester>$/d' \
-  -e '/<info>/,/<\/info>/d' \
-  -e '$b' \
-  -e '/^<\/gtester>$/d' "$@"
diff --git a/scripts/tap-driver.pl b/scripts/tap-driver.pl
new file mode 100755
index 0000000000..5e59b5db49
--- /dev/null
+++ b/scripts/tap-driver.pl
@@ -0,0 +1,378 @@
+#! /usr/bin/env perl
+# Copyright (C) 2011-2013 Free Software Foundation, Inc.
+# Copyright (C) 2018 Red Hat, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+# ---------------------------------- #
+#  Imports, static data, and setup.  #
+# ---------------------------------- #
+
+use warnings FATAL => 'all';
+use strict;
+use Getopt::Long ();
+use TAP::Parser;
+use Term::ANSIColor qw(:constants);
+
+my $ME = "tap-driver.pl";
+my $VERSION = "2018-11-30";
+
+my $USAGE = <<'END';
+Usage:
+  tap-driver [--test-name=TEST] [--color={always|never|auto}]
+             [--verbose] [--show-failures-only]
+END
+
+my $HELP = "$ME: TAP-aware test driver for QEMU testsuite harness." .
+           "\n" . $USAGE;
+
+# It's important that NO_PLAN evaluates "false" as a boolean.
+use constant NO_PLAN => 0;
+use constant EARLY_PLAN => 1;
+use constant LATE_PLAN => 2;
+
+use constant DIAG_STRING => "#";
+
+# ------------------- #
+#  Global variables.  #
+# ------------------- #
+
+my $testno = 0;     # Number of test results seen so far.
+my $bailed_out = 0; # Whether a "Bail out!" directive has been seen.
+my $failed = 0;     # Final exit code
+
+# Whether the TAP plan has been seen or not, and if yes, which kind
+# it is ("early" is seen before any test result, "late" otherwise).
+my $plan_seen = NO_PLAN;
+
+# ----------------- #
+#  Option parsing.  #
+# ----------------- #
+
+my %cfg = (
+  "color" => 0,
+  "verbose" => 0,
+  "show-failures-only" => 0,
+);
+
+my $color = "auto";
+my $test_name = undef;
+
+# Perl's Getopt::Long allows options to take optional arguments after a space.
+# Prevent --color by itself from consuming other arguments
+foreach (@ARGV) {
+  if ($_ eq "--color" || $_ eq "-color") {
+    $_ = "--color=$color";
+  }
+}
+
+Getopt::Long::GetOptions
+  (
+    'help' => sub { print $HELP; exit 0; },
+    'version' => sub { print "$ME $VERSION\n"; exit 0; },
+    'test-name=s' => \$test_name,
+    'color=s'  => \$color,
+    'show-failures-only' => sub { $cfg{"show-failures-only"} = 1; },
+    'verbose' => sub { $cfg{"verbose"} = 1; },
+  ) or exit 1;
+
+if ($color =~ /^always$/i) {
+  $cfg{'color'} = 1;
+} elsif ($color =~ /^never$/i) {
+  $cfg{'color'} = 0;
+} elsif ($color =~ /^auto$/i) {
+  $cfg{'color'} = (-t STDOUT);
+} else {
+  die "Invalid color mode: $color\n";
+}
+
+# ------------- #
+#  Prototypes.  #
+# ------------- #
+
+sub colored ($$);
+sub decorate_result ($);
+sub extract_tap_comment ($);
+sub handle_tap_bailout ($);
+sub handle_tap_plan ($);
+sub handle_tap_result ($);
+sub is_null_string ($);
+sub main ();
+sub report ($;$);
+sub stringify_result_obj ($);
+sub testsuite_error ($);
+
+# -------------- #
+#  Subroutines.  #
+# -------------- #
+
+# If the given string is undefined or empty, return true, otherwise
+# return false.  This function is useful to avoid pitfalls like:
+#   if ($message) { print "$message\n"; }
+# which wouldn't print anything if $message is the literal "0".
+sub is_null_string ($)
+{
+  my $str = shift;
+  return ! (defined $str and length $str);
+}
+
+sub stringify_result_obj ($)
+{
+  my $result_obj = shift;
+  if ($result_obj->is_unplanned || $result_obj->number != $testno)
+    {
+      return "ERROR";
+    }
+  elsif ($plan_seen == LATE_PLAN)
+    {
+      return "ERROR";
+    }
+  elsif (!$result_obj->directive)
+    {
+      return $result_obj->is_ok ? "PASS" : "FAIL";
+    }
+  elsif ($result_obj->has_todo)
+    {
+      return $result_obj->is_actual_ok ? "XPASS" : "XFAIL";
+    }
+  elsif ($result_obj->has_skip)
+    {
+      return $result_obj->is_ok ? "SKIP" : "FAIL";
+    }
+  die "$ME: INTERNAL ERROR"; # NOTREACHED
+}
+
+sub colored ($$)
+{
+  my ($color_string, $text) = @_;
+  return $color_string . $text . RESET;
+}
+
+sub decorate_result ($)
+{
+  my $result = shift;
+  return $result unless $cfg{"color"};
+  my %color_for_result =
+    (
+      "ERROR" => BOLD.MAGENTA,
+      "PASS"  => GREEN,
+      "XPASS" => BOLD.YELLOW,
+      "FAIL"  => BOLD.RED,
+      "XFAIL" => YELLOW,
+      "SKIP"  => BLUE,
+    );
+  if (my $color = $color_for_result{$result})
+    {
+      return colored ($color, $result);
+    }
+  else
+    {
+      return $result; # Don't colorize unknown stuff.
+    }
+}
+
+sub report ($;$)
+{
+  my ($msg, $result, $explanation) = (undef, @_);
+  if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/)
+    {
+      # Output on console might be colorized.
+      $msg = decorate_result($result);
+      if ($result =~ /^(?:PASS|XFAIL|SKIP)/)
+        {
+          return if $cfg{"show-failures-only"};
+        }
+      else
+        {
+          $failed = 1;
+        }
+    }
+  elsif ($result eq "#")
+    {
+      $msg = "  ";
+    }
+  else
+    {
+      die "$ME: INTERNAL ERROR"; # NOTREACHED
+    }
+  $msg .= " $explanation" if defined $explanation;
+  print $msg . "\n";
+}
+
+sub testsuite_error ($)
+{
+  report "ERROR", "- $_[0]";
+}
+
+sub handle_tap_result ($)
+{
+  $testno++;
+  my $result_obj = shift;
+
+  my $test_result = stringify_result_obj $result_obj;
+  my $string = $result_obj->number;
+
+  my $description = $result_obj->description;
+  $string .= " $test_name" unless is_null_string $test_name;
+  $string .= " $description" unless is_null_string $description;
+
+  if ($plan_seen == LATE_PLAN)
+    {
+      $string .= " # AFTER LATE PLAN";
+    }
+  elsif ($result_obj->is_unplanned)
+    {
+      $string .= " # UNPLANNED";
+    }
+  elsif ($result_obj->number != $testno)
+    {
+      $string .= " # OUT-OF-ORDER (expecting $testno)";
+    }
+  elsif (my $directive = $result_obj->directive)
+    {
+      $string .= " # $directive";
+      my $explanation = $result_obj->explanation;
+      $string .= " $explanation"
+        unless is_null_string $explanation;
+    }
+
+  report $test_result, $string;
+}
+
+sub handle_tap_plan ($)
+{
+  my $plan = shift;
+  if ($plan_seen)
+    {
+      # Error, only one plan per stream is acceptable.
+      testsuite_error "multiple test plans";
+      return;
+    }
+  # The TAP plan can come before or after *all* the TAP results; we speak
+  # respectively of an "early" or a "late" plan.  If we see the plan line
+  # after at least one TAP result has been seen, assume we have a late
+  # plan; in this case, any further test result seen after the plan will
+  # be flagged as an error.
+  $plan_seen = ($testno >= 1 ? LATE_PLAN : EARLY_PLAN);
+  # If $testno > 0, we have an error ("too many tests run") that will be
+  # automatically dealt with later, so don't worry about it here.  If
+  # $plan_seen is true, we have an error due to a repeated plan, and that
+  # has already been dealt with above.  Otherwise, we have a valid "plan
+  # with SKIP" specification, and should report it as a particular kind
+  # of SKIP result.
+  if ($plan->directive && $testno == 0)
+    {
+      my $explanation = is_null_string ($plan->explanation) ?
+                        undef : "- " . $plan->explanation;
+      report "SKIP", $explanation;
+    }
+}
+
+sub handle_tap_bailout ($)
+{
+  my ($bailout, $msg) = ($_[0], "Bail out!");
+  $bailed_out = 1;
+  $msg .= " " . $bailout->explanation
+    unless is_null_string $bailout->explanation;
+  testsuite_error $msg;
+}
+
+sub extract_tap_comment ($)
+{
+  my $line = shift;
+  if (index ($line, DIAG_STRING) == 0)
+    {
+      # Strip leading `DIAG_STRING' from `$line'.
+      $line = substr ($line, length (DIAG_STRING));
+      # And strip any leading and trailing whitespace left.
+      $line =~ s/(?:^\s*|\s*$)//g;
+      # Return what is left (if any).
+      return $line;
+    }
+  return "";
+}
+
+sub main ()
+{
+  my $iterator = TAP::Parser::Iterator::Stream->new(\*STDIN);
+  my $parser = TAP::Parser->new ({iterator => $iterator });
+
+  while (defined (my $cur = $parser->next))
+    {
+      # Parsing of TAP input should stop after a "Bail out!" directive.
+      next if $bailed_out;
+
+      if ($cur->is_plan)
+        {
+          handle_tap_plan ($cur);
+        }
+      elsif ($cur->is_test)
+        {
+          handle_tap_result ($cur);
+        }
+      elsif ($cur->is_bailout)
+        {
+          handle_tap_bailout ($cur);
+        }
+      elsif ($cfg{"verbose"})
+        {
+          my $comment = extract_tap_comment ($cur->raw);
+          report "#", "$comment" if length $comment;
+       }
+    }
+  # A "Bail out!" directive should cause us to ignore any following TAP
+  # error.
+  if (!$bailed_out)
+    {
+      if (!$plan_seen)
+        {
+          testsuite_error "missing test plan";
+        }
+      elsif ($parser->tests_planned != $parser->tests_run)
+        {
+          my ($planned, $run) = ($parser->tests_planned, $parser->tests_run);
+          my $bad_amount = $run > $planned ? "many" : "few";
+          testsuite_error (sprintf "too %s tests run (expected %d, got %d)",
+                                   $bad_amount, $planned, $run);
+        }
+    }
+}
+
+# ----------- #
+#  Main code. #
+# ----------- #
+
+main;
+exit($failed);
+
+# Local Variables:
+# perl-indent-level: 2
+# perl-continued-statement-offset: 2
+# perl-continued-brace-offset: 0
+# perl-brace-offset: 0
+# perl-brace-imaginary-offset: 0
+# perl-label-offset: -2
+# cperl-indent-level: 2
+# cperl-brace-offset: 0
+# cperl-continued-brace-offset: 0
+# cperl-label-offset: -2
+# cperl-extra-newline-before-brace: t
+# cperl-merge-trailing-else: nil
+# cperl-continued-statement-offset: 2
+# End:
diff --git a/scripts/tap-merge.pl b/scripts/tap-merge.pl
new file mode 100755
index 0000000000..59e3fa5007
--- /dev/null
+++ b/scripts/tap-merge.pl
@@ -0,0 +1,110 @@
+#! /usr/bin/env perl
+# Copyright (C) 2018 Red Hat, Inc.
+#
+# Author: Paolo Bonzini <pbonzini@redhat.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+# ---------------------------------- #
+#  Imports, static data, and setup.  #
+# ---------------------------------- #
+
+use warnings FATAL => 'all';
+use strict;
+use Getopt::Long ();
+use TAP::Parser;
+
+my $ME = "tap-merge.pl";
+my $VERSION = "2018-11-30";
+
+my $HELP = "$ME: merge multiple TAP inputs from stdin.";
+
+use constant DIAG_STRING => "#";
+
+# ----------------- #
+#  Option parsing.  #
+# ----------------- #
+
+Getopt::Long::GetOptions
+  (
+    'help' => sub { print $HELP; exit 0; },
+    'version' => sub { print "$ME $VERSION\n"; exit 0; },
+  );
+
+# -------------- #
+#  Subroutines.  #
+# -------------- #
+
+sub main ()
+{
+  my $iterator = TAP::Parser::Iterator::Stream->new(\*STDIN);
+  my $parser = TAP::Parser->new ({iterator => $iterator });
+  my $testno = 0;     # Number of test results seen so far.
+  my $bailed_out = 0; # Whether a "Bail out!" directive has been seen.
+
+  while (defined (my $cur = $parser->next))
+    {
+      if ($cur->is_bailout)
+        {
+          $bailed_out = 1;
+          print DIAG_STRING . " " . $cur->as_string . "\n";
+          next;
+        }
+      elsif ($cur->is_plan)
+        {
+          $bailed_out = 0;
+          next;
+        }
+      elsif ($cur->is_test)
+        {
+          $bailed_out = 0 if $cur->number == 1;
+          $testno++;
+          $cur = TAP::Parser::Result::Test->new({
+                          ok => $cur->ok,
+                          test_num => $testno,
+                          directive => $cur->directive,
+                          explanation => $cur->explanation,
+                          description => $cur->description
+                  });
+        }
+      elsif ($cur->is_version)
+        {
+          next if $testno > 0;
+        }
+      print $cur->as_string . "\n" unless $bailed_out;
+    }
+  print "1..$testno\n";
+}
+
+# ----------- #
+#  Main code. #
+# ----------- #
+
+main;
+
+# Local Variables:
+# perl-indent-level: 2
+# perl-continued-statement-offset: 2
+# perl-continued-brace-offset: 0
+# perl-brace-offset: 0
+# perl-brace-imaginary-offset: 0
+# perl-label-offset: -2
+# cperl-indent-level: 2
+# cperl-brace-offset: 0
+# cperl-continued-brace-offset: 0
+# cperl-label-offset: -2
+# cperl-extra-newline-before-brace: t
+# cperl-merge-trailing-else: nil
+# cperl-continued-statement-offset: 2
+# End: