tests/tests-lib/perl5/mancheck_utils.pm

   1 #
   2 # This is probably horrific code to any Perl coder.  I'm sorry,
   3 # I'm not one.  It runs.
   4 #
   5 # Proposed Coding Standard:
   6 #
   7 #     * Subroutines starting with test_ should be TAP tests
   8 #       utilizing ok(), is(), etc... and return the number
   9 #       of tests run if they get that far (could exit early
  10 #       from a BAIL_OUT())
  11 #
  12 use File::Basename;
  13 use Test::More;
  14 use afstest qw(src_path obj_path);
  15
  16 sub check_command_binary {
  17     my $c = shift(@_);
  18     if (! -e "$c") {
  19         BAIL_OUT("Cannot find $c");
  20     }
  21 }
  22
  23 #
  24 # Run the command help to determine the list of sub-commands.
  25 #
  26 sub lookup_sub_commands {
  27     my ($srcdir, $command) = @_;
  28
  29     my $fullpathcommand = "$srcdir/$command";
  30     check_command_binary($fullpathcommand);
  31
  32     # build up our list of available commands from the help output
  33     open(HELPOUT, "$fullpathcommand help 2>&1 |") or BAIL_OUT("can't fork: $!");
  34     my @subcommlist;
  35     my @comm;
  36     while (<HELPOUT>) {
  37         # Skip the header thingy
  38         next if /Commands are/;
  39         # Skip the version subcommand, it's always present but not interesting
  40         next if /^version/;
  41         @comm = split();
  42         push(@subcommlist, $comm[0]);
  43     }
  44     close HELPOUT;
  45     @subcommlist = sort(@subcommlist);
  46     return @subcommlist;
  47 }
  48
  49 # TAP test: test_command_man_pages
  50 #
  51 # Test if a man page exists for each command sub-command.
  52 # Runs one test per sub-command.
  53 #
  54 # Arguments:
  55 #
  56 #                  srcdir : A path to the OpenAFS source directory,
  57 #                           such as /tmp/1.4.14
  58 #
  59 #                 command : the name of the command (e.g. vos)
  60 #
  61 #             subcommlist : a list of sub-commands for command
  62 #
  63 sub test_command_man_pages {
  64     my ($srcdir, $command, @subcommlist) = @_;
  65
  66     # The following is because File::Find makes no sense to me
  67     # for this purpose, and actually seems totally misnamed
  68     my $found = 0;
  69     my $subcommand = "";
  70     my $frex = "";
  71     # Since we don't know what man section it might be in,
  72     # search all existing man page files for a filename match
  73     my @mandirglob = glob("$srcdir/doc/man-pages/man[1-8]/*");
  74     # For every subcommand, see if command_subcommand.[1-8] exists
  75     # in our man page source dir.
  76     foreach (@subcommlist) {
  77         my $subcommand = $_;
  78         $found = 0;
  79         my $frex = $command . '_' . $subcommand . '.[1-8]';
  80         # diag("Looking for $frex");
  81         foreach my $x (@mandirglob) {
  82             # diag("TRYING: $x");
  83             $x = basename($x);
  84             if ($x =~ /$frex$/) {
  85                 # diag("FOUND");
  86                 $found = 1;
  87                 last;
  88             }
  89         }
  90         ok($found eq 1, "existence of man page for $command" . "_$subcommand");
  91     }
  92 }
  93
  94 #
  95 # Setup the test plan and run all of the tests for the given command suite.
  96 #
  97 # Call like so:
  98 # run_manpage_tests("src/ptserver", "pts");
  99 #
 100 sub run_manpage_tests($$) {
 101     my ($subdir, $command) = @_;
 102
 103     my $srcdir = src_path();
 104     my $objdir = obj_path();
 105
 106     my @sub_commands = lookup_sub_commands("$objdir/$subdir", $command);
 107     die("No subcommands found in $objdir/$subdir/$command?") unless(@sub_commands);
 108
 109     plan tests => scalar @sub_commands;
 110
 111     test_command_man_pages($srcdir, $command, @sub_commands);
 112 }
 113 1;