lsqa.pl

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