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