X-Git-Url: http://git.pld-linux.org/?p=packages%2Frpm.git;a=blobdiff_plain;f=perl.prov;h=a494480010caf026594bf8edb15fbf22dc243e03;hp=f36ca18c609eb05080ec3aa94a6946419cc44da6;hb=e20230178f20195f064c83ebc294347a2f2429d1;hpb=6f2d9086b9ef8deb29d1c77152446764e36e19c3

diff --git a/perl.prov b/perl.prov
index f36ca18..a494480 100644
--- a/perl.prov
+++ b/perl.prov
@@ -1,5 +1,4 @@
 #!/usr/bin/perl
-use Safe;
 use strict;
 
 # perl.prov - find information about perl modules for RPM
@@ -10,45 +9,63 @@ use strict;
 # 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;
+# 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;
 
-# 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;
+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
-for ( sort keys %provide ) {
-	print "perl($_)" . ( length $provide{$_} ? " = $provide{$_}" : '' ) . "\n";
+sub print_result {
+	my $self = shift;
+	for (sort keys %{ $self->{provide} }) {
+		print "perl($_)"
+		  . (length $self->{provide}->{$_} ? " = $self->{provide}->{$_}" : '')
+		  . "\n";
+	}
 }
 
-
-############################################################
-#####   functions                                      #####
-############################################################
-
 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 (@inc) {
-		if ( $file =~ m#^\Q$_\E/?(.+)$# ) {
+	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} = '';
+			if ($package !~ s/\.pm$//) {    # it's a *.pl
+			#	$package =~ m#([^/]+)$#;
+			#	$provide{$1} = '';
 				return 1;
 			}
 
@@ -60,6 +77,7 @@ sub process_file {
 	# it can be a *.pl oustide @INC
 	return if /\.pl$/;
 
+	local *FILE;
 	open FILE, $file or die "$0: cannot open file `$file': $!";
 
 	while (<FILE>) {
@@ -75,8 +93,7 @@ sub process_file {
 		# search for the package name
 		if (
 			!defined $package
-			&& ( my ($pack) =
-				m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ )
+			&& ( my ($pack) = m/^\s*(?:\{\s*)?package\s+([_:a-zA-Z0-9]+?):*\s*;/ )
 			&& $1 ne 'main'
 			&& match_the_path( $file, $1 )
 		  )
@@ -85,36 +102,39 @@ sub process_file {
 		}
 
 		if ( !defined $version && /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) {
-			( $version = $safe->reval($_) ) =~ s/^\s+|alpha|beta|\s+$//g;
+			( $version = $self->{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";
+				warn "$0: weird version number in $file: [$version]\n";
 				$version = '';
 			}
 		}
 	}
 
 	unless ( defined $package ) {
-		warn "$0: weird, I can't determine the package name for `$file'\n";
+		warn "$0: weird, cannot determine the package name for `$file'\n";
 		return 0;
 	}
 
-	$provide{$package} = $version;
+	$self->{provide}->{$package} = $version;
 
-	close FILE or die "perl.prov: cannot close file `$file': $!";
+	close FILE or die "$0: cannot close file `$file': $!";
 
 	1;
 }
 
 
-# Returns true if the package name matches the patch,
-# so you can use() it.  False otherwise.
+# 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