introducing lsqa.pl [ --help | -? ] [ --head | -h ] [ --body | -b ] [ --lines | -l ] [ --one-line | -1 ]

[ --help | -? ] 	Show this help message.
	[ --head | -h ] 	Shows only the head of the QA test
	[ --body | -b ] 	Shows only the body of the QA test.
	[ --lines | -l ] 	Outputs everything in n lines
	[ --one-line | -1 ] 	Same as --lines=1.
Merge of master-melb:xfs-cmds:30646a by kenmcd.

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;
+}
+