New test: man page cross-ref against --help

New hack/xref-helpmsgs-manpages script, added to CI 'gate'
task, runs 'podman [subcommand] --help' and cross-references
against man pages in docs/source/markdown/podman*.1.md

See #5453 and #5460 for instances of the problems the
script has found.

The careful reader will find an alarming number of special-case
bypasses. These are a tradeoff I am making: to get perfect
coverage with no handwaving, it would be necessary to make
drastic changes to some man pages, and I believe those would
be counterproductive.

Signed-off-by: Ed Santiago <santiago@redhat.com>

1 files changed, 307 insertions, 0 deletions

diff --git a/hack/xref-helpmsgs-manpages b/hack/xref-helpmsgs-manpages
new file mode 100755
index 000000000..00db3c8de
--- /dev/null
+++ b/hack/xref-helpmsgs-manpages
@@ -0,0 +1,307 @@
+#!/usr/bin/perl
+#
+# xref-helpmsgs-manpages - cross-reference --help options against man pages
+#
+package LibPod::CI::XrefHelpmsgsManpages;
+
+use v5.14;
+use utf8;
+
+use strict;
+use warnings;
+
+(our $ME = $0) =~ s|.*/||;
+our $VERSION = '0.1';
+
+# For debugging, show data structures using DumpTree($var)
+#use Data::TreeDumper; $Data::TreeDumper::Displayaddress = 0;
+
+###############################################################################
+# BEGIN user-customizable section
+
+# Path to podman executable
+my $Default_Podman = './bin/podman';
+my $PODMAN = $ENV{PODMAN} || $Default_Podman;
+
+# Path to podman markdown source files (of the form podman-*.1.md)
+my $Markdown_Path = 'docs/source/markdown';
+
+# END   user-customizable section
+###############################################################################
+
+use FindBin;
+
+###############################################################################
+# BEGIN boilerplate args checking, usage messages
+
+sub usage {
+    print  <<"END_USAGE";
+Usage: $ME [OPTIONS]
+
+$ME recursively runs 'podman --help' against
+all subcommands; and recursively reads podman-*.1.md files
+in $Markdown_Path, then cross-references that each --help
+option is listed in the appropriate man page and vice-versa.
+
+$ME invokes '\$PODMAN' (default: $Default_Podman).
+
+Exit status is zero if no inconsistencies found, one otherwise
+
+OPTIONS:
+
+  -v, --verbose  show verbose progress indicators
+  -n, --dry-run  make no actual changes
+
+  --help         display this message
+  --version      display program name and version
+END_USAGE
+
+    exit;
+}
+
+# Command-line options.  Note that this operates directly on @ARGV !
+our $debug   = 0;
+our $verbose = 0;
+sub handle_opts {
+    use Getopt::Long;
+    GetOptions(
+        'debug!'     => \$debug,
+        'verbose|v'  => \$verbose,
+
+        help         => \&usage,
+        version      => sub { print "$ME version $VERSION\n"; exit 0 },
+    ) or die "Try `$ME --help' for help\n";
+}
+
+# END   boilerplate args checking, usage messages
+###############################################################################
+
+############################## CODE BEGINS HERE ###############################
+
+# The term is "modulino".
+__PACKAGE__->main()                                     unless caller();
+
+# Main code.
+sub main {
+    # Note that we operate directly on @ARGV, not on function parameters.
+    # This is deliberate: it's because Getopt::Long only operates on @ARGV
+    # and there's no clean way to make it use @_.
+    handle_opts();                      # will set package globals
+
+    # Fetch command-line arguments.  Barf if too many.
+    die "$ME: Too many arguments; try $ME --help\n"                 if @ARGV;
+
+    my $help = podman_help();
+    my $man  = podman_man('podman');
+
+    my $retval = xref_by_help($help, $man)
+        +        xref_by_man($help, $man);
+
+    exit !!$retval;
+}
+
+##################
+#  xref_by_help  #  Find keys in '--help' but not in man
+##################
+sub xref_by_help {
+    my ($help, $man, @subcommand) = @_;
+    my $errs = 0;
+
+    for my $k (sort keys %$help) {
+        if (exists $man->{$k}) {
+            if (ref $help->{$k}) {
+                $errs += xref_by_help($help->{$k}, $man->{$k}, @subcommand, $k);
+            }
+            # Otherwise, non-ref is leaf node such as a --option
+        }
+        else {
+            my $man = $man->{_path} || 'man';
+            warn "$ME: podman @subcommand --help lists $k, but $k not in $man\n";
+            ++$errs;
+        }
+    }
+
+    return $errs;
+}
+
+#################
+#  xref_by_man  #  Find keys in man pages but not in --help
+#################
+#
+# In an ideal world we could share the functionality in one function; but
+# there are just too many special cases in man pages.
+#
+sub xref_by_man {
+    my ($help, $man, @subcommand) = @_;
+
+    my $errs = 0;
+
+    # FIXME: this generates way too much output
+    for my $k (grep { $_ ne '_path' } sort keys %$man) {
+        if (exists $help->{$k}) {
+            if (ref $man->{$k}) {
+                $errs += xref_by_man($help->{$k}, $man->{$k}, @subcommand, $k);
+            }
+        }
+        elsif ($k ne '--help' && $k ne '-h') {
+            my $man = $man->{_path} || 'man';
+
+            # Special case: podman-inspect serves dual purpose (image, ctr)
+            my %ignore = map { $_ => 1 } qw(-l -s -t --latest --size --type);
+            next if $man =~ /-inspect/ && $ignore{$k};
+
+            # Special case: the 'trust' man page is a mess
+            next if $man =~ /-trust/;
+
+            # Special case: '--net' is an undocumented shortcut
+            next if $k eq '--net' && $help->{'--network'};
+
+            # Special case: these are actually global options
+            next if $k =~ /^--(cni-config-dir|runtime)$/ && $man =~ /-build/;
+
+            # Special case: weirdness with Cobra and global/local options
+            next if $k eq '--namespace' && $man =~ /-ps/;
+
+            # Special case: these require compiling with 'varlink' tag,
+            # which doesn't happen in CI gating task.
+            next if $k eq 'varlink';
+            next if "@subcommand" eq 'system' && $k eq 'service';
+
+            warn "$ME: podman @subcommand: $k in $man, but not --help\n";
+            ++$errs;
+        }
+    }
+
+    return $errs;
+}
+
+
+#################
+#  podman_help  #  Parse output of 'podman [subcommand] --help'
+#################
+sub podman_help {
+    my %help;
+    open my $fh, '-|', $PODMAN, @_, '--help'
+        or die "$ME: Cannot fork: $!\n";
+    my $section = '';
+    while (my $line = <$fh>) {
+        # Cobra is blessedly consistent in its output:
+        #    Usage: ...
+        #    Available Commands:
+        #       ....
+        #    Flags:
+        #       ....
+        #
+        # Start by identifying the section we're in...
+        if ($line =~ /^Available\s+(Commands):/) {
+            $section = lc $1;
+        }
+        elsif ($line =~ /^(Flags):/) {
+            $section = lc $1;
+        }
+
+        # ...then track commands and options. For subcommands, recurse.
+        elsif ($section eq 'commands') {
+            if ($line =~ /^\s{1,4}(\S+)\s/) {
+                my $subcommand = $1;
+                print "> podman @_ $subcommand\n"               if $debug;
+                $help{$subcommand} = podman_help(@_, $subcommand)
+                    unless $subcommand eq 'help';       # 'help' not in man
+            }
+        }
+        elsif ($section eq 'flags') {
+            # Handle '--foo' or '-f, --foo'
+            if ($line =~ /^\s{1,10}(--\S+)\s/) {
+                print "> podman @_ $1\n"                        if $debug;
+                $help{$1} = 1;
+            }
+            elsif ($line =~ /^\s{1,10}(-\S),\s+(--\S+)\s/) {
+                print "> podman @_ $1, $2\n"                    if $debug;
+                $help{$1} = $help{$2} = 1;
+            }
+        }
+    }
+    close $fh
+        or die "$ME: Error running 'podman @_ --help'\n";
+
+    return \%help;
+}
+
+
+################
+#  podman_man  #  Parse contents of podman-*.1.md
+################
+sub podman_man {
+    my $command = shift;
+    my $subpath = "$Markdown_Path/$command.1.md";
+    my $manpath = "$FindBin::Bin/../$subpath";
+    print "** $subpath \n"                              if $debug;
+
+    my %man = (_path => $subpath);
+    open my $fh, '<', $manpath
+        or die "$ME: Cannot read $manpath: $!\n";
+    my $section = '';
+    my @most_recent_flags;
+    while (my $line = <$fh>) {
+        chomp $line;
+        next unless $line;		# skip empty lines
+
+        # .md files designate sections with leading double hash
+        if ($line =~ /^##\s*(GLOBAL\s+)?OPTIONS/) {
+            $section = 'flags';
+        }
+        elsif ($line =~ /^\#\#\s+(SUB)?COMMANDS/) {
+            $section = 'commands';
+        }
+        elsif ($line =~ /^\#\#/) {
+            $section = '';
+        }
+
+        # This will be a table containing subcommand names, links to man pages.
+        # The format is slightly different between podman.1.md and subcommands.
+        elsif ($section eq 'commands') {
+            # In podman.1.md
+            if ($line =~ /^\|\s*\[podman-(\S+?)\(\d\)\]/) {
+                $man{$1} = podman_man("podman-$1");
+            }
+
+            # In podman-<subcommand>.1.md
+            elsif ($line =~ /^\|\s+(\S+)\s+\|\s+\[\S+\]\((\S+)\.1\.md\)/) {
+                $man{$1} = podman_man($2);
+            }
+        }
+
+        # Flags should always be of the form '**-f**' or '**--flag**',
+        # possibly separated by comma-space.
+        elsif ($section eq 'flags') {
+            # e.g. 'podman run --ip6', documented in man page, but nonexistent
+            if ($line =~ /^not\s+implemented/i) {
+                delete $man{$_} for @most_recent_flags;
+            }
+
+            @most_recent_flags = ();
+            # Handle any variation of '**--foo**, **-f**'
+            while ($line =~ s/^\*\*((--[a-z0-9-]+)|(-.))\*\*(,\s+)?//g) {
+                $man{$1} = 1;
+
+                # Keep track of them, in case we see 'Not implemented' below
+                push @most_recent_flags, $1;
+            }
+        }
+    }
+    close $fh;
+
+    # Special case: the 'image trust' man page tries hard to cover both set
+    # and show, which means it ends up not being machine-readable.
+    if ($command eq 'podman-image-trust') {
+        my %set  = %man;
+        my %show = %man;
+        $show{$_} = 1 for qw(--raw -j --json);
+        return +{ set => \%set, show => \%show }
+    }
+
+    return \%man;
+}
+
+
+1;