summaryrefslogtreecommitdiffstats
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: