syntax.t 3.25 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
#!/usr/bin/perl -w
use strict;

use Test::More;
use Getopt::Std;

sub usage {
    my $exit = shift;
    $exit = 0 if !defined $exit;
    print "Usage: $0 [ package ] ...\n";
    print "\tpackages are read from debian/control if not given as arguments\n";
    exit $exit;
}

my %opts;
getopts('h', \%opts)
    or usage();

usage(0) if $opts{h};

sub getpackages {
    my @p;
    my $c = "debian/control";
    -f $c or BAIL_OUT("no packages listed and $c not found");
    open(C, '<', $c) or BAIL_OUT("opening $c for reading failed:$!");
    while (<C>) {
        chomp;
        /^\s*Package:\s+(\S+)/ and push @p, $1;
    }
    close C or BAIL_OUT("closing $c failed: $!");
    return @p;
}

34
sub readskip {
35 36
    my $skip = "debian/tests/pkg-perl/syntax-skip";
    $skip = "debian/tests/pkg-perl/skip-syntax" if ! -r $skip;
37
    -r $skip or return ();
38 39
    my @ret = readfile($skip);
    return @ret ? @ret : ( undef );
40 41
}

42 43 44 45 46 47
sub readextra {
    my $file = 'debian/tests/pkg-perl/syntax-extra';
    -r $file or return ();
    readfile($file);
}

48 49 50 51
sub readfile {
    my $file = shift;
    open (S, '<', $file)
        or BAIL_OUT("$file exists but can't be read");
52 53 54 55 56 57 58 59 60 61 62 63

    my @ret;
    while (<S>) {
        chomp;
        next if !/\S/;
        next if /^\s*#/;
        push @ret, qr/\Q$_\E/;
    }
    close S;
    return @ret;
}

64 65 66 67
my @packages = @ARGV ? @ARGV : getpackages();

usage() if !@packages;

68
plan tests => 4 * scalar @packages;
69

70 71
my @extra_check = readextra();

72 73
my @to_skip = readskip();

74 75 76 77 78
for my $package (@packages) {
    SKIP: {
        ok(!system(qq(dpkg-query --list "$package" >/dev/null 2>&1)),
            "Package $package is known to dpkg");

79 80 81 82
        skip "$package not installed", 3 if $?;

        my @status_info = qx{dpkg-query --status "$package"};
        ok(@status_info, "Got status information for package $package");
83 84
        skip "$package has Suggestions and no explicit skip list", 2
            if grep /^Suggests:/, @status_info and ! @to_skip;
85 86 87 88 89 90 91 92

        my @files = qx{dpkg-query --listfiles "$package" 2>/dev/null};

        ok(@files, "Got file list for package $package");

        skip "nothing to test", 1 if !@files;

        my @pms;
93
        F: for (@files) {
94
            next if !m{^/}; # skip diversions
95
            chomp;
96 97 98 99 100 101 102

            my $is_extra = 0;
            for my $check_re (@extra_check) {
                $is_extra++, last if /$check_re/;
            }
            next if !/\.pm$/ and !$is_extra;

103
            for my $skip_re (@to_skip) {
104 105
                # undef special cased to mean 'an empty explicit skip list'
                last if !defined $skip_re;
106 107
                note "skipping $_", next F if /$skip_re/;
            }
108 109 110 111
            my $oninc = 0;
            for my $incdir (@INC) {
                    $oninc++, last if /^\Q$incdir/;
            }
112 113
            # 'extra files' don't need to be on @INC
            next if !$oninc and !$is_extra;
114 115 116 117 118
            push @pms, $_;
        }

        skip "no perl modules to test in $package", 1 if !@pms;

119
        subtest "all modules in $package pass the syntax check" => sub {
120 121 122 123 124 125 126 127 128
            plan tests => scalar @pms;
            for (@pms) {
                my @out = grep !/syntax OK/, qx($^X -wc $_ 2>&1);
                note(@out) if @out;
                ok(!$?, "$^X -wc $_ exited successfully");
            }
        }
    }
}