X-Git-Url: https://git.tld-linux.org/?a=blobdiff_plain;f=perl.prov;h=6e98f9a4ae03d8f6d931ad221c3a90974a4cfb87;hb=HEAD;hp=8f1a79d599aacdeb249789ebe93504ebc62aa106;hpb=685372ccad422be5593dabe2ed2d89f19037e7ca;p=packages%2Frpm.git diff --git a/perl.prov b/perl.prov deleted file mode 100644 index 8f1a79d..0000000 --- a/perl.prov +++ /dev/null @@ -1,140 +0,0 @@ -#!/usr/bin/perl -use strict; - -# perl.prov - find information about perl modules for RPM -# $Id: perl.prov,v 1.10 2004/05/05 17:13:54 radek Exp $ - -# 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 () { - - # 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 if the package name matches the path, -# so you can use() it. C 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