#!/usr/local/bin/perl

# Version: 2005/01/27

#
# Run through all the files on a system, looking for perl programs.
# when found, see what modules are used.
#
# Create a test program for use in evaluating perl installations 
# that haven't gone live yet.
#
# Copyright (C) 1999 David Muir Sharnoff.  License hereby
# granted for anyone to use, modify or redistribute this module at 
# their own risk.  Please feed useful changes back to muir@idiom.com.
#

my @dirs = qw( 
	/
);
my @prune = qw(
	/cgi/usr/local/lib/perl.*
	/cgi/usr/lib/perl.*
	/cgi/usr/old/lib/perl.*
	/cgi/old/lib/perl.*
	/proc
	/tmp
	/var/tmp
);

my $prunere;
{
	my $x = join('$|^', @prune);
	$prunere = qr/^$x$/;
}

my $match = qr/^\#\!\s*(\S*perl\S*)/;

use File::Find;
use File::Slurp;
use POSIX qw(O_WRONLY O_RDONLY); 

my $scriptcount;
my $pmcount;
my %count;
my %perls;
my %modules_found;
my %pmfound;
my %examples;

if (-t STDOUT) {
	die "STDOUT should be redirected to a file or something\n";
}

find(\&mod, @dirs);

print <<END;

	# perl module installation tester

	BEGIN { print "this should print OKAY\n"; }

	print "scripts scanned: $scriptcount\n";
	print "private modules scanned: $pmcount\n";

	\$| = 1;
END

print STDERR "scripts scanned: $scriptcount\n";
print STDERR "private modules scanned: $pmcount\n";

for my $m (sort keys %modules_found) {

	my $totalcount;
	my $em = '';
	for my $p (sort keys %perls) {
		if ($count{$modules_found{$m}{$p}}) {
			my $path = $modules_found{$m}{$p};
			my $c = $count{$path};
			$totalcount += $c;
			$em .= "\t\t$path\t$c\n";
		}
	}
	my $ex = join("\n\t\t",@{$examples{$m}});
	next unless $totalcount;
	print <<END;

######################################### $m
	open(RESULTS, "-|") or do {
		\$SIG{__WARN__} = \\&nothing;
		close(STDIN);
		open(STDERR, ">&STDOUT");
		select(STDOUT);
		require $m;
		print "\\na-okay\\n";
		exit(0);
	};
	\$okay = 0; \$last = '';
	while(<RESULTS>) {
		if (/^a-okay\$/) {
			\$okay = 1;
			last;
		}
		\$last = \$_;
	}
	close(RESULTS);
	unless (\$okay) {
		\$last =~ s/\\(\\\@INC contains.*\\) //;
		print <<MSG;
$m
	Failed with: \$last
	This is important because it was used $totalcount times:
$em
	For example:
		$ex

MSG
	}

END

}
print <<END;

	print "OKAY\n";

END

if (-e $0) {
	my $x = read_file($0);
	print "__END__\n$x";
}

sub mod {
	if ($File::Find::name =~ /$prunere/o) {
		$File::Find::prune = 1;
		return;
	}

	return 1 unless -x $_;
	return 1 unless -f _;
	return 0 if -l $_;

	sysopen(FILE, $_, O_RDONLY) or warn "open $File::Find::name: $!";
	my $x = <FILE>;
	return 1 unless $x =~ m,$match,o;
	
	# it's a perl program!

	my $perl = $1;

	$scriptcount++;
	
	unless ($perls{$perl}) {
		$perls{$perl} = [ getINC($perl) ];
	}

	while(<FILE>) {
		using($perl,$1,$File::Find::dir,$File::Find::name) 
			if /\buse\s+([-a-zA-Z0-9_':"]+)/;
		using($perl,$1,$File::Find::dir,$File::Find::name) 
			if /\brequire\s+([-a-zA-Z0-9_':"]+)/;
	}
}

sub using
{
	my ($perl, $used, $scriptdir, $thisfile) = @_;
	return if $used =~ /^\$/;
	$used =~ s/;$//;

	my $fname;
	if ($used =~ /^"(.*?)\.(.+)"$/) {
		if ($2 eq 'pm') {
			# regular module
#			$used = $1 ;
			$fname = "$1.pm";
		} else {
#			$used = "$1.$2";
			$fname = "$1.$2";
		}
	} else {
		$fname = "$used.pm";
	}
#	print "used = $used\n";
	
	if ($modules_found{$used}{$perl}) {
		$count{$modules_found{$used}{$perl}}++;
		return;
	}
	return if exists $pmfound{$used,$scriptdir};
	
	my $found;
	my $standard;
	my (@pos) = permutations($fname);
	for my $dirs (@{$perls{$perl}}) {
		next if $dirs eq '.';
		next unless $dirs;
		for my $pos (@pos) {
#			print "\tchecking $dirs/$pos\n";
			next unless -e "$dirs/$pos";
			$standard = "$dirs/$pos";
			$modules_found{$used}{$perl} = $standard;
			$count{$standard} = 1;
			push(@{$examples{$used}}, $thisfile)
				if $#{$examples{$used}} < 3;
			last;
		}
	}
#	print "count{$standard} = 1\n";

	unless ($standard) {
		for my $pos (@pos) {
			next unless -e "$scriptdir/$pos";
			$found = "$scriptdir/$pos";
			$pmfound{$used,$scriptdir} = $found;
			$pmcount++;
			last;
		}
	}

# 	Uncomment the following to read around inside the
#	installed perl modules.
#
#	$found = $standard unless $found;

	return unless $found;

	local(*USED);
	sysopen(USED, $found, O_RDONLY) or warn "open $used: $!";
	while(<USED>) {
		using($perl,$1,$scriptdir,$found) if /\buse\s+([-a-zA-Z0-9_':"]+)/;
		using($perl,$1,$scriptdir,$found) if /\brequire\s+([-a-zA-Z0-9_':"]+)/;
	}
	close(USED);
}

sub permutations
{
	my ($fname, $depth) = @_;
	my @r;
	return "." if $depth > 4;
	if (($fname =~ /^(.+?)\:\:(.+)$/) || ($fname =~ /^(.+)'(.+)$/)) {
		for my $p1 (permutations($1, $depth+1)) {
			for my $p2 (permutations($2, $depth+1)) {
				push(@r, "$p1/$p2", "$p1\:\:$p2");
			}
		}
#		print "permutations($fname) = @r.\n";
		return (@r);
	} else {
#		print "permutations($fname) = self\n";
		return ($fname);
	}
}

sub getINC
{
	my ($perl) = @_;
	return unless -x $perl;
	my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, 
                $atime, $mtime, $ctime, $blksize, $blocks) = stat($perl);
	my $ppid = $$;
	my $pid = fork();
	die "fork failed: $!" unless defined $pid;
	if ($pid) {
		# parent
		waitpid($pid,0);
		my (@inc) = split(' ',read_file("/tmp/pinc$$"));
		unlink("/tmp/pinc$$");
#		print "got inc = @inc\n";
		return (@inc);
	} else {
		($<, $>) = ($uid, $uid);
		system(qq($perl -e 'print "\@INC\n"' > /tmp/pinc$ppid));
		exit(0);
	}
}

__END__

=head1 NAME

find_used_modules - figure out which perl modules are 
actually used on your system.

=head1 DESCRIPTION

See README

=head1 README

find_used_modules looks over your entire system and figures out
which modules people are using.  It then builds a perl script that
can be used to test to make sure that all those modules are 
available.  

The purpose of all this is to allow perl to be upgraded without
breaking too many installed perl programs.

=head1 PREREQUISITES

This script requires C<File::Find> and C<File::Slurp>.

=pod OSNAMES

Unix

=pod SCRIPT CATEGORIES

CPAN
Unix/System_administration

=cut