X-Git-Url: http://git.pld-linux.org/?a=blobdiff_plain;f=perl.prov;h=a494480010caf026594bf8edb15fbf22dc243e03;hb=afbc3b99fdbe6e58dcb5d01fc1e15d974a5575a2;hp=2319092bfc7eca1d84985036247831f289aa2b58;hpb=ee27fa621f6cff05d9e178cefd161e840f768d7c;p=packages%2Fperl.git

diff --git a/perl.prov b/perl.prov
index 2319092..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; warning: we ignore ^ here
-	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";
-#	warn  "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/?(.+)$# ) { # warning: we ignore ^ here
+	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>) {
@@ -84,7 +102,7 @@ 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]/ )
@@ -100,7 +118,7 @@ sub process_file {
 		return 0;
 	}
 
-	$provide{$package} = $version;
+	$self->{provide}->{$package} = $version;
 
 	close FILE or die "$0: cannot close file `$file': $!";
 
@@ -108,12 +126,15 @@ sub process_file {
 }
 
 
-# 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