introducing lsqa.pl [ --help | -? ] [ --head | -h ] [ --body | -b ] [ --lines | ...
[xfstests-dev.git] / 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