lsqa.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Copyright (c) 2008 Silicon Graphics, Inc.  All Rights Reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License as
   7 # published by the Free Software Foundation.
   8 #
   9 # This program is distributed in the hope that it would be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write the Free Software Foundation,
  16 # Inc.,  51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  17 #
  18
  19 # Print headers of given tests
  20 # Accepted parameter types:
  21 # - nothing - list all tests from all subdirectories in tests/*
  22 # - tests/DIR - list all tests from DIR
  23 # - tests/DIR/123 - show header from single test
  24
  25 use strict;
  26
  27 use Getopt::Long;
  28
  29 sub help();
  30 sub get_qa_header($);
  31 sub get_qa_tests;
  32
  33 my %opt;
  34
  35 my @oa = (
  36     ['--help|?',     "Show this help message.",
  37      \$opt{'help'}],
  38     ['--head|h',     "Shows only the head of the QA test",
  39     \$opt{'head'}],
  40     ['--body|b',     "Shows only the body of the QA test.",
  41     \$opt{'body'}],
  42     ['--one-line|1', "Output everything on a single line.",
  43     \$opt{'oneline'}],
  44     );
  45
  46 # black magic
  47 GetOptions(map { @{$_}[0] => @{$_}[2] } @oa);
  48
  49 if ($opt{'help'}) {
  50     die help();
  51 }
  52
  53 my @qatests;
  54
  55 if (!@ARGV) {
  56     my $d="tests";
  57     opendir(DIR, $d);
  58     map { push @qatests,get_qa_tests("$d/$_") if -d "$d/$_" } readdir(DIR);
  59     closedir(DIR);
  60 }
  61
  62 foreach (@ARGV) {
  63     push @qatests,$_ if -f && /\d{3}$/;
  64     push @qatests,get_qa_tests($_) if -d;
  65 }
  66
  67 foreach (@qatests) {
  68     my @h = get_qa_header($_);
  69
  70     if ($opt{'head'}) {
  71         @h = shift @h;
  72     } elsif ($opt{'body'}) {
  73         shift @h;
  74         shift @h
  75     }
  76
  77     if ($opt{'oneline'}) {
  78         print map {s/\n/ /; $_} @h;
  79         print "\n";
  80     } else {
  81         print @h;
  82     }
  83
  84     print "--------------------------------------------------\n" unless (@qatests < 2);
  85 }
  86
  87 sub help() {
  88     my $sa = '';
  89     foreach (@oa) {
  90         #       local $_ = @{$_}[0];
  91         @{$_}[0] =~ s/=(.*)$//;
  92         @{$_}[0] =~ s/\|/ \| -/;
  93         @{$_}[0] =~ s/^/\[ /;
  94         @{$_}[0] =~ s/$/ \] /;
  95         $sa .= @{$_}[0];
  96     }
  97
  98     print "Usage: $0\t$sa\n";
  99     foreach (@oa) {
 100         $$_[0] =~ s/\|/\t\|/;
 101         print "\t$$_[0]\t$$_[1]\n";
 102     }
 103 }
 104
 105 sub get_qa_header($) {
 106     my $f = shift || die "need an argument";
 107     my @l;
 108
 109     open(my $FH, $f) || die "couldn't open '$f': $!";
 110     while (<$FH>) {
 111         #ignore.
 112         m/^#\!/                 and next; #shebang
 113         m/^#\s*\-{10}/          and last; #dashed lines
 114         m/^#\s*copyright/i      and last; #copyright lines
 115
 116         s/^# *//;
 117
 118         push @l, $_;
 119     }
 120     close($FH);
 121     return @l;
 122 }
 123
 124 sub get_qa_tests {
 125     my $d = shift || $ENV{'PWD'};
 126
 127     opendir(my $DIR, $d) || die "can't opendir $d: $!";
 128     my @qa = sort grep { m/^\d\d\d$/ && -f "$d/$_" } readdir($DIR);
 129     closedir($DIR);
 130     return map { $_ = "$d/$_" } @qa;
 131 }