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 use strict;
  19
  20 use Getopt::Long;
  21
  22 sub help();
  23 sub get_qa_header($);
  24 sub get_qa_tests();
  25
  26 my %opt;
  27
  28 my @oa = (
  29     ['--help|?',     "Show this help message.",
  30      \$opt{'help'}],
  31     ['--head|h',     "Shows only the head of the QA test",
  32     \$opt{'head'}],
  33     ['--body|b',     "Shows only the body of the QA test.",
  34     \$opt{'body'}],
  35     ['--one-line|1', "Output everything on a single line.",
  36     \$opt{'oneline'}],
  37     );
  38
  39 # black magic
  40 GetOptions(map { @{$_}[0] => @{$_}[2] } @oa);
  41
  42 if ($opt{'help'}) {
  43     die help();
  44 }
  45
  46 my @qatests = map {sprintf("%03d", $_)} @ARGV;
  47 @qatests = get_qa_tests() unless (@qatests);
  48
  49 foreach (@qatests) {
  50     my @h = get_qa_header($_);
  51
  52     if ($opt{'head'}) {
  53         @h = shift @h;
  54     } elsif ($opt{'body'}) {
  55         shift @h;
  56         shift @h
  57     }
  58
  59     if ($opt{'oneline'}) {
  60         print map {s/\n/ /; $_} @h;
  61         print "\n";
  62     } else {
  63         print @h;
  64     }
  65
  66     print "--------------------------------------------------\n" unless (@qatests < 2);
  67 }
  68
  69 sub help() {
  70     my $sa = '';
  71     foreach (@oa) {
  72         #       local $_ = @{$_}[0];
  73         @{$_}[0] =~ s/=(.*)$//;
  74         @{$_}[0] =~ s/\|/ \| -/;
  75         @{$_}[0] =~ s/^/\[ /;
  76         @{$_}[0] =~ s/$/ \] /;
  77         $sa .= @{$_}[0];
  78     }
  79
  80     print "Usage: $0\t$sa\n";
  81     foreach (@oa) {
  82         $$_[0] =~ s/\|/\t\|/;
  83         print "\t$$_[0]\t$$_[1]\n";
  84     }
  85 }
  86
  87 sub get_qa_header($) {
  88     my $f = shift || die "need an argument";
  89     my @l;
  90
  91     open(my $FH, $f) || die "couldn't open '$f': $!";
  92     while (<$FH>) {
  93         #ignore.
  94         m/^#\!/                 and next; #shebang
  95         m/^#\s*\-{10}/          and last; #dashed lines
  96         m/^#\s*copyright/i      and last; #copyright lines
  97
  98         s/^# *//;
  99
 100         push @l, $_;
 101     }
 102     close($FH);
 103     return @l;
 104 }
 105
 106 sub get_qa_tests() {
 107     my $d = shift || $ENV{'PWD'};
 108
 109     opendir(my $DIR, $d) || die "can't opendir $d: $!";
 110     my @qa = grep {m/^\d\d\d$/ && -f "$d/$_" } readdir($DIR);
 111     closedir($DIR);
 112
 113     return @qa;
 114 }
 115