lsqa.pl

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