#!/usr/bin/perl
# The CPAN purity test.
# Copyright 2006 by Joey Hess <joey@kitenet.net>
# Licensed under the same terms as perl itself (GPL/Artistic).
use strict;
use warnings;
use Getopt::Long;

sub usage {
    die "usage: cpan-purity [--verbose] [--mine=regexp] -- program arg
+s\n";
}

GetOptions(
    "verbose" => \$ENV{CPAN_PURITY_VERBOSE},
    "mine=s" => \$ENV{CPAN_PURITY_MINE},
) && @ARGV || usage();

use File::Temp q{tempdir};
my $tempdir = tempdir(CLEANUP => 1);
if (! defined $tempdir) {
    die "failed to create temp directory, cannot run!";
}
if (exists $ENV{PERL5LIB}) {
    $ENV{PERL5LIB}.=":$tempdir";
}
else {
    $ENV{PERL5LIB}=$tempdir;
}
open (OUT, ">$tempdir/CPANPurity.pm") || 
    die "write $tempdir/CPANPurity.pm: $!";
print OUT <DATA>;
close OUT;

my $prog=shift;
if ($prog =~/perl/) {
    if ((! grep { $_ eq "-e" } @ARGV) || (grep { $_ =~ /^(-m|-M)$/ } @
+ARGV)) {
        die "Sorry, I your perl command line is too complex for me.\n"
+;
        
    }
    $ENV{CPAN_PURITY_ONELINER}=1;
    $prog=shift;
}
else {
    if (! -x $prog) {
        foreach my $dir (split(":", $ENV{PATH})) {
            if (-x "$dir/$prog") {
                $prog="$dir/$prog";
                last;
            }
        }
    }
    die "Cannot find $prog in the PATH..\n" unless -x $prog;

    open (PROG, $prog) || die "can't read $prog: $!";
    my $code;
    {
        local $/=undef;
        $code=<PROG>;
    }
    close PROG;
    if ($code=~/^#\s*!.*perl.*-T/) {
        print "Forcing $prog to run without taint checking..\n";
        $code=~s/(^#\s*!.*perl.*)-T/$1/;
        $prog="$tempdir/proggy";
        open(PROG, ">$prog") || die "write $prog: $!";
        print PROG $code;
        close PROG;
        chmod(0755, $prog) || die "chmod $prog: $!";
    }
}

if (! exists $ENV{CPAN_PURITY_TEST}) {
    $ENV{CPAN_PURITY_TEST}=1;
    system("perl", "-mCPANPurity", $prog, @ARGV);
}

__DATA__
# CPANPurity module
sub countfile {
    my $file=shift;
    my $owner=shift;
    
    my $lines=0;
    open (IN, "$file") || warn "can't read $file: $!";
    while (<IN>) {
        $lines++;
    }
    close IN;
    $lines=" "x(5-length($lines)).$lines;
    print "** $owner: [$lines lines] $file\n" if $ENV{CPAN_PURITY_VERB
+OSE};
    return $lines;
}

END {
    my $skip=qr/CPANPurity\.pm/;
    my $mine=$skip;
    if (exists $ENV{CPAN_PURITY_MINE} &&
        length $ENV{CPAN_PURITY_MINE}) {
        $ENV{CPAN_PURITY_MINE}=~s/::/\//g;
        $mine=qr/$ENV{CPAN_PURITY_MINE}/i;
    }
    
    my $liblines=0;
    my $mylines=0;
    my $libfiles=0;
    my $myfiles=0;
    foreach my $lib (keys %INC) {
        next if $lib=~/$skip/;
        if ($lib=~/$mine/) {
            $mylines+=countfile($INC{$lib}, "mine");
            $myfiles++;
        }
        else {
            $liblines+=countfile($INC{$lib}, "CPAN");
            $libfiles++;
        }
    }

    if (! $ENV{CPAN_PURITY_ONELINER}) {
        $mylines+=countfile($0, "mine");
        $myfiles++
    }
    else {
        $mylines++;
        print "** Looks like that was a perl one-liner..\n";
    }

    my $percent=0;
    if ($mylines > 0) {
        $percent=($liblines / ($mylines+$liblines)) * 100;
        $percent=~s/(\.\d\d).*/$1/;
    }

    print <<"EOF"
** CPAN Prurity test results: $percent% pure CPAN code.
** $liblines lines in $libfiles files were from CPAN, and $mylines lin
+es in $myfiles files were not.
EOF
}

1
[download]