introducing lsqa.pl [ --help | -? ] [ --head | -h ] [ --body | -b ] [ --lines | ...

[xfstests-dev.git] / lsqa.pl

diff --git a/lsqa.pl b/lsqa.pl
new file mode 100755 (executable)
index 0000000..d43afd2
--- /dev/null
+++ b/lsqa.pl
@@ -0,0 +1,99 @@
+#!/usr/bin/perl -w
+use strict;
+
+use Getopt::Long;
+
+sub help();
+sub get_qa_header($);
+sub get_qa_tests();
+
+my %opt;
+
+my @oa = (
+    ['--help|?',     "Show this help message.",
+     \$opt{'help'}],
+    ['--head|h',     "Shows only the head of the QA test",
+    \$opt{'head'}],
+    ['--body|b',     "Shows only the body of the QA test.",
+    \$opt{'body'}],
+    ['--one-line|1', "Output everything on a single line.",
+    \$opt{'oneline'}],
+    );
+
+# black magic
+GetOptions(map { @{$_}[0] => @{$_}[2] } @oa);
+
+if ($opt{'help'}) {
+    die help();
+}
+
+my @qatests = map {sprintf("%03d", $_)} @ARGV;
+@qatests = get_qa_tests() unless (@qatests);
+
+foreach (@qatests) {
+    my @h = get_qa_header($_);
+
+    if ($opt{'head'}) {
+       @h = shift @h;
+    } elsif ($opt{'body'}) {
+       shift @h;
+       shift @h
+    }
+
+    if ($opt{'oneline'}) {
+       print map {s/\n/ /; $_} @h;
+       print "\n";
+    } else {
+       print @h;
+    }
+
+    print "--------------------------------------------------\n" unless (@qatests < 2);
+}
+
+sub help() {
+    my $sa = '';
+    foreach (@oa) {
+       #       local $_ = @{$_}[0];
+       @{$_}[0] =~ s/=(.*)$//;
+       @{$_}[0] =~ s/\|/ \| -/;
+       @{$_}[0] =~ s/^/\[ /;
+       @{$_}[0] =~ s/$/ \] /;
+       $sa .= @{$_}[0];
+    }
+
+    print "Usage: $0\t$sa\n";
+    foreach (@oa) {
+       $$_[0] =~ s/\|/\t\|/;
+       print "\t$$_[0]\t$$_[1]\n";
+    }
+}
+
+sub get_qa_header($) {
+    my $f = shift || die "need an argument";
+    my @l;
+
+    open(my $FH, $f) || die "couldn't open '$f': $!";
+    while (<$FH>) {
+       #ignore.
+       m/^#\!/                 and next; #shebang
+       m/^#\s*\-{10}/          and last; #dashed lines
+       m/^#\s*copyright/i      and last; #copyright lines
+
+       s/^# *//;
+
+       push @l, $_;
+    }
+    close($FH);
+    return @l;
+}
+
+sub get_qa_tests() {
+    my $d = shift || $ENV{'PWD'};
+
+    opendir(my $DIR, $d) || die "can't opendir $d: $!";
+    my @qa = grep {m/^\d\d\d$/ && -f "$d/$_" } readdir($DIR);
+    closedir($DIR);
+
+    return @qa;
+}
+