summaryrefslogtreecommitdiffstats
path: root/scripts/hxtool-conv.pl
blob: eede40b3462279e6814e53c9d029459c17773a91 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
#!/usr/bin/perl -w
#
# Script to convert .hx file STEXI/ETEXI blocks to SRST/ERST
#
# Copyright (C) 2020 Linaro
#
# This work is licensed under the terms of the GNU GPL, version 2 or
# (at your option) any later version. See the COPYING file in the
# top-level directory.

# This script was only ever intended as a one-off conversion operation.
# Please excuse the places where it is a bit hacky.
# Some manual intervention after the conversion is expected, as are
# some warnings from makeinfo.
# Warning: this script is not idempotent: don't try to run it on
# a .hx file that already has SRST/ERST sections.

# Expected usage:
# scripts/hxtool-conv.pl file.hx > file.hx.new

use utf8;

my $reading_texi = 0;
my $texiblock = '';
my @tables = ();

sub update_tables($) {
    my ($texi) = @_;
    # Update our list of open table directives: every @table
    # line in the texi fragment is added to the list, and every
    # @end table line means we remove an entry from the list.
    # If this fragment had a completely self contained table with
    # both the @table and @end table lines, this will be a no-op.
    foreach (split(/\n/, $texi)) {
        push @tables, $_ if /^\@table/;
        pop @tables if /^\@end table/;
    }
}

sub only_table_directives($) {
    # Return true if every line in the fragment is a start or end table directive
    my ($texi) = @_;
    foreach (split(/\n/, $texi)) {
        return 0 unless /^\@table/ or /^\@end table/;
    }
    return 1;
}

sub output_rstblock($) {
    # Write the output to /tmp/frag.texi, wrapped in whatever current @table
    # lines we need.
    my ($texi) = @_;

    # As a special case, if this fragment is only table directives and
    # nothing else, update our set of open table directives but otherwise
    # ignore it. This avoids emitting an empty SRST/ERST block.
    if (only_table_directives($texi)) {
        update_tables($texi);
        return;
    }

    open(my $fragfh, '>', '/tmp/frag.texi');
    # First output the currently active set of open table directives
    print $fragfh join("\n", @tables);
    # Next, update our list of open table directives.
    # We need to do this before we emit the closing table directives
    # so that we emit the right number if this fragment had an
    # unbalanced set of directives.
    update_tables($texi);
    # Then emit the texi fragment itself.
    print $fragfh "\n$texi\n";
    # Finally, add the necessary closing table directives.
    print $fragfh "\@end table\n" x scalar @tables;
    close $fragfh;

    # Now invoke makeinfo/pandoc on it and slurp the results into a string
    open(my $fh, '-|', "makeinfo --force -o - --docbook "
         . "-D 'qemu_system_x86 QEMU_SYSTEM_X86_MACRO' "
         . "-D 'qemu_system     QEMU_SYSTEM_MACRO'  /tmp/frag.texi "
         . " | pandoc  -f docbook -t rst")
        or die "can't start makeinfo/pandoc: $!";

    binmode $fh, ':encoding(utf8)';

    print "SRST\n";

    # Slurp the whole thing into a string so we can do multiline
    # string matches on it.
    my $rst = do {
        local $/ = undef;
        <$fh>;
    };
    $rst =~ s/^-  − /-  /gm;
    $rst =~ s/“/"/gm;
    $rst =~ s/”/"/gm;
    $rst =~ s/‘/'/gm;
    $rst =~ s/’/'/gm;
    $rst =~ s/QEMU_SYSTEM_MACRO/|qemu_system|/g;
    $rst =~ s/QEMU_SYSTEM_X86_MACRO/|qemu_system_x86|/g;
    $rst =~ s/(?=::\n\n +\|qemu)/.. parsed-literal/g;
    $rst =~ s/:\n\n::$/::/gm;

    # Fix up the invalid reference format makeinfo/pandoc emit:
    # `Some string here <#anchorname>`__
    # should be:
    # :ref:`anchorname`
    $rst =~ s/\`[^<`]+\<\#([^>]+)\>\`__/:ref:`$1`/gm;
    print $rst;

    close $fh or die "error on close: $!";
    print "ERST\n";
}

# Read the whole .hx input file.
while (<>) {
    # Always print the current line
    print;
    if (/STEXI/) {
        $reading_texi = 1;
        $texiblock = '';
        next;
    }
    if (/ETEXI/) {
        $reading_texi = 0;
        # dump RST version of block
        output_rstblock($texiblock);
        next;
    }
    if ($reading_texi) {
        # Accumulate the texi into a string
        # but drop findex entries as they will confuse makeinfo
        next if /^\@findex/;
        $texiblock .= $_;
    }
}

die "Unexpectedly still in texi block at EOF" if $reading_texi;
n class="hl esc">\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 }); STDOUT->autoflush(1); 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: