[packages/rpm.git] / perl.prov

#!/usr/bin/perl
use Safe;
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.

# This shoud be provided as a library -- the same functionality is
# needed by the perl.req script.

my %provide;
my @inc = sort { length $b cmp length $a } grep m#^/.+#, @INC;
my $safe = new Safe;

# process @ARGV or STDIN
foreach ( @ARGV ? @ARGV : <> ) {
	chomp;
	next if !-f || -l;                # skip non-files and symlinks
	next if m#^/usr/(?:doc|src)/#;    # lot of false alarms
	next if !m#\.p[ml]$#;             # we only care about *.pm and *.pl files
	process_file($_) if -f;
}

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


############################################################
#####   functions                                      #####
############################################################

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

	# if the file lives under @INC, we can
	# obtain the package name from it's path
	for (@inc) {
		if ( $file =~ m#^\Q$_\E/?(.+)$# ) {
			$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$/;

	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 = $safe->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g;
			if ( defined $version
				&& length $version
				&& $version =~ /[^\d\._abcdefgh]/ )
			{
				warn "perl.prov: weird version number in $file: [$version]\n";
				$version = '';
			}
		}
	}

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

	$provide{$package} = $version;

	close FILE or die "perl.prov: cannot close file `$file': $!";

	1;
}


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

# vim: ts=4 sw=4 noet noai nosi cin
Commit	Line	Data
bacf7ded	1	#!/usr/bin/perl
	2	use Safe;
	3	use strict;
	4
	5	# perl.prov - find information about perl modules for RPM
	6	# $Id$
	7
	8	# It's questionable if we should provide perl(Foo::Bar) for modules
	9	# from outside @INC (possibly shipped with some applications).
	10	# I think we should not, and provide them only for the perl.req script,
	11	# while it scans files in that particular application.
	12
	13	# This shoud be provided as a library -- the same functionality is
	14	# needed by the perl.req script.
	15
	16	my %provide;
	17	my @inc = sort { length $b cmp length $a } grep m#^/.+#, @INC;
	18	my $safe = new Safe;
	19
	20	# process @ARGV or STDIN
	21	foreach ( @ARGV ? @ARGV : <> ) {
	22	chomp;
	23	next if !-f \|\| -l; # skip non-files and symlinks
	24	next if m#^/usr/(?:doc\|src)/#; # lot of false alarms
	25	next if !m#\.p[ml]$#; # we only care about .pm and .pl files
	26	process_file($_) if -f;
	27	}
	28
	29	# print out what we found
	30	for ( sort keys %provide ) {
	31	print "perl($_)" . ( length $provide{$_} ? " = $provide{$_}" : '' ) . "\n";
	32	}
	33
	34
	35	############################################################
	36	##### functions #####
	37	############################################################
	38
	39	sub process_file {
	40	my $file = shift;
	41	my ( $package, $version );
	42
	43	# if the file lives under @INC, we can
	44	# obtain the package name from it's path
	45	for (@inc) {
	46	if ( $file =~ m#^\Q$_\E/?(.+)$# ) {
	47	$package = $1;
	48
	49	if ( $package !~ s/\.pm$// ) { # it's a *.pl
	50	# $package =~ m#([^/]+)$#;
	51	# $provide{$1} = '';
	52	return 1;
	53	}
	54
	55	$package =~ s#/#::#g;
	56	last;
	57	}
	58	}
	59
	60	# it can be a *.pl oustide @INC
	61	return if /\.pl$/;
	62
	63	open FILE, $file or die "$0: cannot open file `$file': $!";
	64
65	while (<FILE>) {
66
67	# skip the documentation
68	next
6f2d9086	69	if m/^=(?:head1\|head2\|pod\|item\|begin\|for\|over)\b/
6f2d9086	70	... ( m/^=(?:cut\|end)\b/ \|\| $. == 1 );
bacf7ded	71
	72	# skip the data section
	73	last if m/^__(?:DATA\|END)__$/;
	74
	75	# search for the package name
	76	if (
	77	!defined $package
	78	&& ( my ($pack) =
	79	m/^\s(?:\{\s)?package\s+([_:a-zA-Z0-9]+?):\s;/ )
	80	&& $1 ne 'main'
	81	&& match_the_path( $file, $1 )
	82	)
	83	{
	84	$package = $pack;
	85	}
	86
	87	if ( !defined $version && /([\$])(([\w\:\'])\bVERSION)\b.*\=/ ) {
	88	( $version = $safe->reval($_) ) =~ s/^\s+\|alpha\|beta\|\s+$//g;
	89	if ( defined $version
	90	&& length $version
	91	&& $version =~ /[^\d\._abcdefgh]/ )
	92	{
	93	warn "perl.prov: weird version number in $file: [$version]\n";
	94	$version = '';
	95	}
	96	}
	97	}
	98
	99	unless ( defined $package ) {
	100	warn "$0: weird, I can't determine the package name for `$file'\n";
	101	return 0;
	102	}
	103
	104	$provide{$package} = $version;
	105
	106	close FILE or die "perl.prov: cannot close file `$file': $!";
	107
	108	1;
	109	}
	110
	111
	112	# Returns true if the package name matches the patch,
	113	# so you can use() it. False otherwise.
	114	sub match_the_path {
	115	my ( $file, $pack ) = @_;
	116	$pack =~ s#::#/#g;
	117	$file =~ /\Q$pack\E(?:\.pm)?$/;
	118	}
	119
	120	# vim: ts=4 sw=4 noet noai nosi cin