[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; warning: we ignore ^ here
	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";
#	warn  "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/?(.+)$# ) { # warning: we ignore ^ 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$/;

	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 "$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;
	}

	$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)?$/;
}

# 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
1e13d1eb	24	next if m#/usr/(?:doc\|src)/#; # lot of false alarms; warning: we ignore ^ here
9618a052	25	next if !m#\.p[ml]$#; # we only care about .pm and .pl files
bacf7ded	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";
1e13d1eb	32	# warn "perl($_)" . ( length $provide{$_} ? " = $provide{$_}" : '' ) . "\n";
bacf7ded	33	}
bacf7ded	34
bacf7ded	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) {
1e13d1eb	46	if ( $file =~ m#\Q$_\E/?(.+)$# ) { # warning: we ignore ^ here
bacf7ded	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
c276b4e2	78	&& ( my ($pack) = m/^\s(?:\{\s)?package\s+([_:a-zA-Z0-9]+?):\s;/ )
bacf7ded	79	&& $1 ne 'main'
	80	&& match_the_path( $file, $1 )
	81	)
	82	{
	83	$package = $pack;
	84	}
	85
	86	if ( !defined $version && /([\$])(([\w\:\'])\bVERSION)\b.*\=/ ) {
	87	( $version = $safe->reval($_) ) =~ s/^\s+\|alpha\|beta\|\s+$//g;
	88	if ( defined $version
	89	&& length $version
	90	&& $version =~ /[^\d\._abcdefgh]/ )
	91	{
1e13d1eb	92	warn "$0: weird version number in $file: [$version]\n";
bacf7ded	93	$version = '';
	94	}
	95	}
	96	}
	97
	98	unless ( defined $package ) {
52fe5f29	99	warn "$0: weird, cannot determine the package name for `$file'\n";
bacf7ded	100	return 0;
	101	}
	102
	103	$provide{$package} = $version;
	104
1e13d1eb	105	close FILE or die "$0: cannot close file `$file': $!";
bacf7ded	106
	107	1;
	108	}
	109
	110
bdd77f75	111	# Returns C<true> if the package name matches the path,
bdd77f75	112	# so you can use() it. C<false> otherwise.
bacf7ded	113	sub match_the_path {
	114	my ( $file, $pack ) = @_;
	115	$pack =~ s#::#/#g;
	116	$file =~ /\Q$pack\E(?:\.pm)?$/;
	117	}
	118
	119	# vim: ts=4 sw=4 noet noai nosi cin