source: MondoRescue/branches/3.2/mindi/mindi-get-perl-modules@ 3386

#!/usr/bin/perl -w
#
# $Id$
# Copyright B. Cornec 2005-2013
# Provided under the GPL v2
#
# Get perl modules required by mindi and mondo and that should be on the restore media
#
use strict;

use MondoRescue::File;
use Data::Dumper;
use File::Basename;
use ProjectBuilder::Base;
use Getopt::Long qw(:config auto_abbrev no_ignore_case);

=pod

=head1 NAME

mindi-get-perl-modules keeps track of the perl modules that should be on your restore media

=head1 DESCRIPTION

mindi-get-perl-modules keeps track of the perl modules that should be on your restore media by analyzing the references made to them in the scripts passed as parameters and returning all the modules needed to have them work correctly.

=head1 SYNOPSIS

mindi-get-perl-modules /path/to/perl-script ...

=head1 ARGUMENTS

=over 4

=item B</path/to/perl-script> 

This is the path of the perl script to analyze and for which we want its perl modules in dependence to be included

=back

=head1 WEB SITES

The main Web site of the project is available at L<http://www.mondorescue.org>. Bug reports should be filled using the trac instance of the project at L<http://trac.mondorescue.org/>.

=head1 USER MAILING LIST

For community exchanges around MondoRescue please use the list L<http://sourceforge.net/mailarchive/forum.php?forum_name=mondo-devel>

=head1 AUTHORS

The MondoRescue team lead by Bruno Cornec L<mailto:bruno@mondorescue.org>.

=head1 COPYRIGHT

MondoRescue is distributed under the GPL v2.0 license or later,
described in the file C<COPYING> included with the distribution.

=cut

# Globals
my %files;
my %found;
my %opts;
my @includes;
my $req;
my %args;

GetOptions(
     "verbose|v+" => \$opts{'v'},
);

pb_syntax_init("mindi-get-perl-modules Version PBVER-rPBREV\n");

$pbdebug = $opts{'v'};
$pbdebug = 0 if (not defined $pbdebug);

# Remove non exiting directories from @INC
# and thus avoid perl warnings
#
pb_log(1,"Searching originally in ");
pb_log(1,join " - ", @INC);
pb_log(1,"\n");

foreach my $d (@INC) {
    $d = mr_file_read_all_link($d) if (-l $d);
    push @includes,$d if (-d $d);
}

pb_log(1,"Searching finally in    ");
pb_log(1,join " - ", @INC);
pb_log(1,"\n");

# deduplicate entry list
if (defined $ARGV[0]) {
    %args = map { $_, 1 } @ARGV;
} else {
    pb_syntax();
}

pb_temp_init();

my $tmpf = "$ENV{'PBTMP'}/mpgm.$$";

open(TMPF,"> $tmpf") || die "Unable to create $tmpf: !$\n";
print TMPF "# To include module corresponding to perl -w\n";
print TMPF "use warnings;\n";
print TMPF "# To include module used by Data:Dumper in a masked way for this script\n";
print TMPF "use bytes;\n";
close(TMPF);

foreach my $f (keys %args,"$tmpf") {
    pb_log(1,"Get perl modules on $f\n");
    $req = mr_get_perl_modules($f);
    foreach my $k (keys %$req) {
        $files{$k} = $req->{$k};
    }
    pb_log(1,"After mr_get_perl_modules on $f we got:".Dumper(\%files)."\n");
}
unlink("$tmpf");

foreach my $f (sort keys %files) {
    print "$f\n";
}

exit 0;

sub mr_get_perl_modules {

my $f = shift;
my %newly_found;
my $require;

return($require) if (not defined $f);
$require = mr_process_file($f);

pb_log(1,"Requires on $f found:\n");
pb_log(1,Dumper($require));
pb_log(1,"---------------\n");

my $cpt = keys %$require;

# Exit recursion
return($require) if ($cpt == 0);

foreach my $m (keys %$require) {
    (my $mod = $m) =~ s|::|/|g;
    # Already found
    next if (exists $found{$mod});
    foreach my $d (@includes) {
        pb_log(1,"Looking at $m in $d\n");
        if (-f "$d/$mod.pm") {
            $files{"$d/$mod.pm"} = $mod;
            $found{$mod} = "$d/$mod.pm";
            $newly_found{"$d/$mod.pm"} = $mod;
            pb_log(1,"Found $mod in $d/$mod.pm\n");
            last;
        }
    }
    print STDERR "ERROR: Unable to find $mod. Your perl setup may be incorrect\n" if (not exists $found{$mod});
}
                    
pb_log(1,"Files found:\n");
pb_log(1,Dumper(\%files));
pb_log(2,Dumper(\%found));
pb_log(1,"---------------\n");

pb_log(1,"New Files found:\n");
pb_log(1,Dumper(\%newly_found));
pb_log(1,"---------------\n");

my $foundrec;

$cpt = keys %newly_found;
if ($cpt != 0) {
    # Recurse on what we just found
    foreach my $f (keys %newly_found) {
        $foundrec = mr_get_perl_modules($f);
        foreach my $k (keys %$foundrec) {
            $files{$k} = $foundrec->{$k};
        }
    }

    # Cleanup
    foreach my $k (keys %newly_found) {
        delete $newly_found{$k};
    }
}

pb_log(1,"End of mr_get_perl_modules on $f we got:".Dumper(\%files)."\n");

return(\%files);
}

# Adapted From /usr/lib/rpm/mageia/perl.req
# by Ken Estes Mail.com kestes@staff.mail.com
# used under the GPL

sub mr_process_file {
  
my $file = shift;
my %line;
my %list_req;
my $current_line = undef;
my $tag = undef;

return(\%list_req) if (not defined $file);

pb_log(2, "START Analyze $file\n");
# In a recursive configuration we need a var as file handle
open(my $fh, "$file") || return(\%list_req);
while (my $line = <$fh>) {

    # skip the "= <<" block

    pb_log(2, "LINE: $line");
    if ( ( $line =~ m/^\s*\$(.*)\s*=\s*<<\s*["'](.*)['"]/i) ||
        ($line =~ m/^\s*\$(.*)\s*=\s*<<\s*(.*);/i) ) {
        $tag = $2;
        while (my $l = <$fh>) {
            pb_log(2, "LINE-tag: $l");
            ( $l =~ /^$tag/) && last;
        }
    }

    pb_log(2, "PHASE 2: $line");
    # skip the documentation

    # we should not need to have item in this if statement (it
    # properly belongs in the over/back section) but people do not
    # read the perldoc.

    if ( ($line =~ m/^=(head1|head2|pod|item)/) .. ($line =~ m/^=(cut)/) ) {
        pb_log(2, "PHASE 2bis:$line");
        next;
    }
    pb_log(2, "PHASE 3:\n");

    if ( ($line =~ m/^=(over)/) .. ($line =~ m/^=(back)/) ) {
        next;
    }
    pb_log(2, "PHASE 4:\n");
    
    # skip the data section
    if ($line =~ m/^__(DATA|END)__$/) {
        last;
    }
    pb_log(2, "PHASE 5:\n");

    # Each keyword can appear multiple times.  Don't
    #  bother with datastructures to store these strings,
    #  if we need to print it print it now.

    if ($line =~  m/^\s*\$RPM_Requires\s*=\s*["'](.*)['"]/i) {
        foreach my $l (split(/\s+/, $1)) {
            print "$l\n";
            }
    }
    pb_log(2, "PHASE 6:\n");

    if ( 

# ouch could be in a eval, perhaps we do not want these since we catch
# an exception they must not be required

#   eval { require Term::ReadLine } or die $@;
#   eval "require Term::Rendezvous;" or die $@;
#   eval { require Carp } if defined $^S; # If error/warning during compilation,


    ($line =~ m/^(\s*)         # we hope the inclusion starts the line
        (require|use)\s+(?!\{)     # do not want 'do bracket' loops
        # quotes around name are always legal
        [\'\"]?([^\;\ \'\"\t]*)[\'\"]?[\t\;\ ]
        # the syntax for 'use' allows version requirements
        \s*([.0-9]*)
        /x)
    ) {
        pb_log(2, "REQUIRE FOUND ***\n");
        my ($whitespace, $statement, $module, $version) = ($1, $2, $3,$4);
        my $usebase;

        # we only consider require statements that are flush against
        # the left edge. any other require statements give too many
        # false positives, as they are usually inside of an if statement
        # as a fallback module or a rarely used option

        ($whitespace !~ /^\s*$/ && $statement eq "require") && next;

        pb_log(2, "REQUIRE AV *** $whitespace, $statement, $module, $version ***\n");
        # if there is some interpolation of variables just skip this
        # dependency, we do not want
        #        do "$ENV{LOGDIR}/$rcfile";

        ($module =~ m/\$/) && next;

        # skip if the phrase was "use of" -- shows up in gimp-perl, et al
        next if $module eq 'of';

        # if the module ends in a comma we probaly caught some
        # documentation of the form 'check stuff,\n do stuff, clean
        # stuff.' there are several of these in the perl distribution

        ($module  =~ m/[,>]$/) && next;

        # if the module name starts in a dot it is not a module name.
        # Is this necessary?  Please give me an example if you turn this
        # back on.

        #      ($module =~ m/^\./) && next;

        # if the module ends with .pm strip it to leave only basename.
        # starts with /, which means its an absolute path to a file
        if ($module =~ m(^/)) {
            print "$module\n";
            next;
        }

        # as seen in some perl scripts
        # use base qw(App::CLI Class::Accessor::Chained::Fast App::CLI::Command);
        if ($module eq 'base') {
            $list_req{$module} = $version;
            $line{$module} = $current_line;
            ($module = $line) =~ s/use\s*base\s*//;
            $module =~ s/qw\((.*)\)\s*;/$1/;
            $module =~ s/qw(.)(.*)\1\s*;/$2/;
            $module =~ s/\s*;$//;
            $module =~ s/#.*//;
            $usebase = 1;
        }
        # sometimes people do use POSIX qw(foo), or use POSIX(qw(foo)) etc
        # we can strip qw.*$, as well as (.*$:
        $module =~ s/qw.*$//;
        $module =~ s/\(.*$//;

        $module =~ s/\.pm$//;

        # some perl programmers write 'require URI/URL;' when 
        # they mean 'require URI::URL;'

        $module =~ s/\//::/;

        # trim off trailing parenthesis if any.  Sometimes people pass
        # the module an empty list.
    
        $module =~ s/\(\s*\)$//;

        # if module is a number then both require and use interpret that
        # to mean that a particular version of perl is specified. Don't
        # add a dependency, though, since the rpm will already require
        # perl-base at the build version (via find-requires)
        next if $module =~ /^v?\d/;

        # ph files do not use the package name inside the file.
        # perlmodlib  documentation says:
        #       the .ph files made by h2ph will probably end up as
        #       extension modules made by h2xs.
        # so do not spend much effort on these.

        # there is no easy way to find out if a file named systeminfo.ph
        # will be included with the name sys/systeminfo.ph so only use the
        # basename of *.ph files

        ($module  =~ m/\.ph$/) && next;

        # if the module was loaded trough base, we need to split the list
        if ($usebase) {
            my $current_line = $line;
            foreach my $l (split(/\s+/, $module)) {
                next unless $l;
                $list_req{$l} = $version;
                $line{$l} = $current_line;
            }
        } else {
            $list_req{$module}=$version;
            $line{$module}=$current_line;
        }
        pb_log(2, "REQUIRE FIN *** ".Dumper(\%list_req)." ***\n");
    }
}

close($fh) || die("$0: Could not close file: '$file' : $!\n");

return(\%list_req);
}