- obsolete

[packages/rpm.git] / perl.prov

#!/usr/bin/perl
use strict;

# perl.prov - find information about perl modules for RPM
# $Id$

# It's questionable if we should provide perl(Foo::Bar) for modules
# from outside @INC (possibly shipped with some applications).
# I think we should not, and provide them only for the perl.req script,
# while it scans files in that particular application.


# check if we are called directly
if ($0 =~ m#(?:^|/)perl.prov$#) {
	my $prov = new RPM::PerlReq;
	# process @ARGV or STDIN
	foreach ( @ARGV ? @ARGV : <> ) {
		chomp;
		next if -l || !-f _;                # skip non-files and symlinks
		next if m#/usr/(?:share/doc|src)/#; # lot of false alarms; warning: we omit ^ here
		next if !m#\.p[ml]$#;               # we only care about *.pm and *.pl files
		$prov->process_file($_);
	}
	$prov->print_result;
}


package RPM::PerlReq;
use Safe;

sub new {
	my $class = shift;
	my $self = {
		inc => [
			sort { length $b cmp length $a } grep m#^/#,
			map { y#/#/#s; s#/$##; $_ } @INC
		],
		provide => {},
		safe    => Safe->new,
		@_,
	};
	bless $self, $class;
}

# print out what we found
sub print_result {
	my $self = shift;
	for (sort keys %{ $self->{provide} }) {
		print "perl($_)"
		  . (length $self->{provide}->{$_} ? " = $self->{provide}->{$_}" : '')
		  . "\n";
	}
}

sub process_file {
	my $self = shift;
	my $file = shift;
	my ( $package, $version );

	# if the file lives under @INC, we can
	# obtain the package name from it's path
	for (@{ $self->{inc} }) {
		if ($file =~ m#\Q$_\E/(.+)$#) {    # we can't use ^ here
			$package = $1;

			if ($package !~ s/\.pm$//) {    # it's a *.pl
			#	$package =~ m#([^/]+)$#;
			#	$provide{$1} = '';
				return 1;
			}

			$package =~ s#/#::#g;
			last;
		}
	}

	# it can be a *.pl oustide @INC
	return if /\.pl$/;

	local *FILE;
	open FILE, $file or die "$0: cannot open file `$file': $!";

	while (<FILE>) {

		# skip the documentation
		next
		  if m/^=(?:head1|head2|pod|item|begin|for|over)\b/
		     ... ( m/^=(?:cut|end)\b/ || $. == 1 );

		# skip the data section
		last if m/^__(?:DATA|END)__$/;

		# search for the package name
		if (
			!defined $package
			&& ( my ($pack) = m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ )
			&& $1 ne 'main'
			&& match_the_path( $file, $1 )
		  )
		{
			$package = $pack;
		}

		if ( !defined $version && /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) {
			( $version = $self->{safe}->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g;
			if ( defined $version
				&& length $version
				&& $version =~ /[^\d\._abcdefgh]/ )
			{
				warn "$0: weird version number in $file: [$version]\n";
				$version = '';
			}
		}
	}

	unless ( defined $package ) {
		warn "$0: weird, cannot determine the package name for `$file'\n";
		return 0;
	}

	$self->{provide}->{$package} = $version;

	close FILE or die "$0: cannot close file `$file': $!";

	1;
}


# Returns C<true> if the package name matches the path,
# so you can use() it.  C<false> otherwise.
sub match_the_path {
	my ( $file, $pack ) = @_;
	$pack =~ s#::#/#g;
	$file =~ /\Q$pack\E(?:\.pm)?$/;
}


1;

# vim: ts=4 sw=4 noet noai nosi cin