File Coverage

blib/lib/Module/ScanDeps/Static.pm

Criterion	Covered	Total	%
statement	140	279	50.1
branch	34	142	23.9
condition	27	88	30.6
subroutine	23	29	79.3
pod	3	12	25.0
total	227	550	41.2

package Module::ScanDeps::Static;

use strict;
use warnings;

our $VERSION = '1.001';

use 5.010;

use Carp;
use Data::Dumper;
use English qw{ -no_match_vars };
use ExtUtils::MM;
use Getopt::Long;
use JSON::PP;
use Module::CoreList;
use Pod::Usage;
use Pod::Find qw{ pod_where };
use Readonly;
use IO::Scalar;
use List::Util qw{ max };
use version;

use parent qw{ Class::Accessor::Fast };

__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors(
  qw{
    json raw text handle include_require core
    add_version perlreq require path separator min_core_version
  }
);

# booleans
Readonly my $TRUE  => 1;
Readonly my $FALSE => 0;

# shell success/failure
Readonly my $SUCCESS => 0;
Readonly my $FAILURE => 1;

# chars
Readonly my $COMMA        => q{,};
Readonly my $DOUBLE_COLON => q{::};
Readonly my $EMPTY        => q{};
Readonly my $NEWLINE      => qq{\n};
Readonly my $SLASH        => q{/};
Readonly my $SPACE        => q{ };

Readonly my $DEFAULT_MIN_CORE_VERSION => '5.8.9';

our $HAVE_VERSION = eval {
  require version;
  return $TRUE;
};

caller or __PACKAGE__->main();

########################################################################
sub new {
########################################################################
  my ( $class, $args ) = @_;

  $args = $args || {};

  my %options = %{$args};

  foreach my $k ( keys %options ) {
    my $v = $options{$k};

    delete $options{$k};

    $k =~ s/-/_/gxsm;

    $options{$k} = $v;
  }

  # defaults
  $options{'core'}             //= $TRUE;
  $options{'include_require'}  //= $FALSE;
  $options{'add_version'}      //= $TRUE;
  $options{'min_core_version'} //= $DEFAULT_MIN_CORE_VERSION;

  my $self = $class->SUPER::new( \%options );

  $self->set_perlreq( {} );
  $self->set_require( {} );

  return $self;
}

########################################################################
sub make_path_from_module {
########################################################################
  my ( $self, $module ) = @_;

  my $file = join $SLASH, split /$DOUBLE_COLON/xsm, $module;

  return "$file.pm";
}

########################################################################
sub get_module_version {
########################################################################
  my ( $self, $module_w_version, @include_path ) = @_;

  if ( !@include_path ) {
    @include_path = @INC;
  }

  my ( $module, $version ) = split /\s+/xsm, $module_w_version;

  my %module_version = (
    module  => $module,
    version => $version,
    path    => undef,
  );

  return \%module_version
    if $version;

  $module_version{'file'} = $self->make_path_from_module($module);

  foreach my $prefix (@include_path) {

    my $path = $prefix . $SLASH . $module_version{'file'};
    next if !-e $path;

    $module_version{'path'} = $path;

    $module_version{'version'}
      = eval { return ExtUtils::MM->parse_version($path) // 0; };

    last;
  }

  return \%module_version;
}

########################################################################
sub is_core {
########################################################################
  my ( $self, $module_w_version ) = @_;

  my ( $module, $version ) = split /\s/xsm, $module_w_version;

  my $core = $FALSE;

  my @ms = Module::CoreList->find_modules(qr/\A$module\z/xsm);

  if (@ms) {
    my $first_release = Module::CoreList->first_release($module);

    my $first_release_version = version->parse($first_release);
    my $min_core_version      = $self->get_min_core_version;

    # consider a module core if its first release was less than some
    # version of Perl. This is done because CPAN testers don't seem to
    # test modules against Perls that are older than 5.8.9 - however,
    # some modules like JSON::PP did not appear until > 5.10

    # print {*STDERR} "$module: $first_release_version $min_core_version\n";

    $core = version->parse($first_release_version)
      <= version->parse($min_core_version) ? 1 : 0;

  }

  # print {*STDERR} "$module: [$core]\n";

  return $core;
}

########################################################################
sub parse_line { ## no critic (Subroutines::ProhibitExcessComplexity)
########################################################################
  my ( $self, $line ) = @_;

  my $fh = $self->get_handle;

  # skip the "= <<" block
  if ( $line =~ /\A\s*(?:my\s*)?\$(?:.*)\s*=\s*<<\s*(["'`])(.+?)\1/xsm
    || $line =~ /\A\s*(?:my\s*)?\$(.*)\s*=\s*<<(\w+)\s*;/xsm ) {
    my $tag = $2;

    while ( $line = <$fh> ) {
      chomp $line;

      last if $line eq $tag;
    }

    $line = <$fh>;

    return if !$line;

  }

  # skip q{} quoted sections - just hope we don't have curly brackets
  # within the quote, nor an escaped hash mark that isn't a comment
  # marker, such as occurs right here. Draw the line somewhere.
  if ( $line =~ /\A.*\Wq[qxwr]?\s*([{([#|\/])[^})\]#|\/]*$/xsm
    && $line !~ /\A\s*require|use\s/xsm ) {
    my $tag = $1;

    $tag =~ tr/{\(\[\#|\//})]#|\//;
    $tag = quotemeta $tag;

    while ( $line = <$fh> ) {
      last if $line =~ /$tag/xsm;
    }

    return if !$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 =~ /\A=(head[\d]|pod|for|item)/xsm ) {

    while ( $line = <$fh> ) {
      last if $line =~ /\A^=cut/xsm;
    }

    return if !$line;
  }

  if ( $line =~ /\A=over/xsm ) {
    while ( $line = <$fh> ) {
      last if /\A=back/xsm;
    }

    return if !$line;
  }

  # skip the data section
  return if $line =~ /\A__(DATA|END)__/xsm;

  my $modver_re = qr/[.\d]+/xsm;

  #
  # The (require|use) match further down in this subroutine will match lines
  # within a multi-line print or return statements.  So, let's skip over such
  # statements whose content should not be loading modules anyway. -BEF-
  #
  if ( $line =~ /print(?:\s+|\s+\S+\s+)\<\<\s*(["'`])(.+?)\1/xsm
    || $line =~ /print(\s+|\s+\S+\s+)\<\<(\w+)/xsm
    || $line =~ /return(\s+)\<\<(\w+)/xsm ) {

    my $tag = $2;
    while ( $line = <$fh> ) {
      chomp $line;
      last if $line eq $tag;
    }

    $line = <$fh>;

    return if !$line;
  }

  # Skip multiline print and assign statements
  if ( $line =~ /\$\S+\s*=\s*(")([^"\\]|(\\.))*\z/xsm
    || $line =~ /\$\S+\s*=\s*(')([^'\\]|(\\.))*\z/xsm
    || $line =~ /print\s+(")([^"\\]|(\\.))*\z/xsm
    || $line =~ /print\s+(')([^'\\]|(\\.))*\z/xsm ) {

    my $quote = $1;

    while ( $line = <$fh> ) {
      last if $line =~ /\A([^\\$quote]|(\\.))*$quote/xsm;
    }

    $line = <$fh>;

    return if !$line;
  }

  # 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,

  ## no critic (ProhibitComplexRegexes, RequireBracesForMultiline)
  if (
    ( $line =~ /\A(\s*) # we hope the inclusion starts the line
         (require|use)\s+(?![{])      # do not want 'do {' loops
         # quotes around name are always legal
         ['"]?([\w:.\/]+?)['"]?[\t; ]
         # the syntax for 'use' allows version requirements
         # the latter part is for "use base qw(Foo)" and friends special case
         \s*($modver_re|(qw\s*[{(\/'"]\s*|['"])[^})\/"'\$]*?\s*[})\/"'])?/xsm
    )
  ) {

    #    \s*($modver_re|(qw\s*[(\/'"]\s*|['"])[^)\/"'\$]*?\s*[)\/"'])?

    my ( $whitespace, $statement, $module, $version ) = ( $1, $2, $3, $4 );

    $version //= $EMPTY;

    #print {*STDERR} "$whitespace, $statement, $module, $version\n";

    # fix misidentification of version when use parent qw{ Foo };
    #
    # Pragmatism dictates that I just identify the misidentification
    # instead of trying to make the regexp above even more
    # complicated...

    if ( $statement eq 'use' && $module =~ /(parent|base)/xsm ) {
      if ( $version =~ /\A\s*qw?\s*['"{(\/]\s*([^'")}\/]+)\s*['")}\/]/xsm ) {
        $module  = $1;
        $version = $EMPTY;
      }
      elsif ( $version =~ /\A\s*['"]([^"']+)['"]\s*\z/xsm ) {
        $module  = $1;
        $version = $EMPTY;
      }
    }

    #print {*STDERR} "$whitespace, $statement, $module, $version\n";

    #

    # we only consider require statements that are flushed 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

    if ( !$self->get_include_require ) {
      return $line if $whitespace ne $EMPTY && $statement eq 'require';
    }
    elsif ( $statement eq 'require' ) {
      return $line if $line =~ /\$/xsm; # eval?
    }

    # if there is some interpolation of variables just skip this
    # dependency, we do not want
    #        do "$ENV{LOGDIR}/$rcfile";

    return $line if $module =~ /\$/xsm;

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

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

    return $line if $module =~ /[,>]\z/xsm;

    # 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 starts with /, it is an absolute path to a file
    if ( $module =~ /\A\//xsm ) {
      $self->add_require($module);
      return $line;
    }

    # sometimes people do use POSIX qw(foo), or use POSIX(qw(foo)) etc.
    # we can strip qw.*$, as well as (.*$:
    $module =~ s/qw.*\z//xsm;
    $module =~ s/[(].*\z//xsm;

    # if the module ends with .pm, strip it to leave only basename.
    $module =~ s/[.]pm\z//xsm;

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

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

    # trim off trailing parentheses if any.  Sometimes people pass
    # the module an empty list.

    $module =~ s/[(]\s*[)]$//xsm;

    if ( $module =~ /\Av?([\d._]+)\z/xsm ) {
      # if module is a number then both require and use interpret that
      # to mean that a particular version of perl is specified

      my $ver = $1;

      $self->get_perlreq->{'perl'} = $ver;

      return $line;

    }

    # 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 expend 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

    return $line if $module =~ /[.]ph\z/xsm;

    # use base|parent qw(Foo) dependencies
    if ( $statement eq 'use'
      && ( $module eq 'base' || $module eq 'parent' ) ) {
      $self->add_require( $module, $version );
      #print {*STDERR}
      #  "statement: $statement module: $module, version: $version\n";

      if ( $version =~ /\Aqw\s*[{(\/'"]\s*([^)}\/"']+?)\s*[})\/"']/xsm ) {
        foreach ( split $SPACE, $1 ) {
          $self->add_require( $line, undef );
        }
      }
      elsif ( $version =~ /(["'])([^"']+)\1/xsm ) {
        $self->add_require( $2, undef );
      }

      return $line;
    }

    if ( $version && $version !~ /\A$modver_re\z/oxsm ) {
      $version = undef;
    }
    #print {*STDERR}
    #  "statement: $statement module: $module, version: $version\n";

    my @module_list = split /\s+/xsm, $module;

    if ( @module_list > 1 ) {
      for (@module_list) {
        $self->add_require( $_, $EMPTY );
      }
    }
    else {
      $self->add_require( $module, $version );
    }
  }

  return $line;
}

########################################################################
sub parse {
########################################################################
  my ( $self, $script ) = @_;

  if ( my $file = $self->get_path ) {
    chomp $file;

    open my $fh, '<', $file ## no critic (InputOutput::RequireBriefOpen)
      or croak "could not open file '$file' for reading: $OS_ERROR";

    $self->set_handle($fh);
  }

  if ( !$self->get_handle && $script ) {
    $self->set_handle( IO::Scalar->new($script) );
  }
  elsif ( !$self->get_handle ) {
    open my $fh, '<&STDIN'  ## no critic (InputOutput::RequireBriefOpen)
      or croak 'could not open STDIN';

    $self->set_handle($fh);
  }

  my $fh = $self->get_handle;

  while ( my $line = <$fh> ) {
    last if !$self->parse_line($line);
  }

  # only close the file if we opened...
  if ( $self->get_path ) {
    close $fh
      or croak 'could not close file ' . $self->get_path . "$OS_ERROR\n";
  }

  my @sorted_dependencies = sort keys %{ $self->get_require };

  return @sorted_dependencies;
}

########################################################################
#
# To be honest, I'm really not sure what the code below should do
# other than simply put the version number in the hash. I can only
# surmise that if the original script was running in the context of a
# list of perl scripts in a project AND one script specified an older
# version of a module, then that version is replace with the newer
# version.
#
# In our implementation here, the typical use case (I think) will be
# for an instance of Module::ScanDeps::Static to parse one
# script. However, it is possible for the instance to scan multiple
# files by calling "parse()" iteratively, accumulating the
# dependencies along the way. In that case this method's actions
# appear to be relevant.
#
# Thinking through the above use case and the way it is being
# implemented might indicate a "bug", or at least a design flaw. Take
# the case where two Perl scripts (presumably in the same project
# considering that this utility was written for packaging RPMs)
# require different versions of the same module. Rare, and odd, but
# possible - although one might wonder why the author of these scripts
# didn't resolve any conflicts between the modules so that he could
# use one version of said module.
#
# In any event this method enforces a single version of the module
# (the highest) as the answer to the question what version of
# __fill_in_the_blank__ module do I require?
#
# The original method did not attempt to find the version of the
# module on the system where this script was being executed. This
# implementation does try to do that if you've sent the "add_version"
# option to a true value.
########################################################################

########################################################################
sub add_require {
########################################################################
  my ( $self, $module, $newver ) = @_;

  $module =~ s/\A\s*//xsm;
  $module =~ s/\s*\z//xsm;

  my $require = $self->get_require;

  my $oldver = $require->{$module};

  if ($oldver) {
    if ( $HAVE_VERSION && $newver && version->new($oldver) < $newver ) {
      $require->{$module} = $newver;
    }
  }
  elsif ( !$newver ) {
    my $m = {};

    if ( $self->get_add_version ) {
      $m = $self->get_module_version($module);
    }

    $require->{$module} = $m->{'version'} // $EMPTY;
  }
  else {
    $require->{$module} = $newver;
  }

  return $self;
}

########################################################################
sub format_json {
########################################################################
  my ( $self, @requirements ) = @_;

  my %perlreq = %{ $self->get_perlreq };

  my %requires = %{ $self->get_require };

  if ( exists $perlreq{'perl'} ) {
    my $perl_version = $perlreq{'perl'};

    if ( !$perl_version && $self->get_add_version ) {
      $perl_version = $PERL_VERSION;
    }

    push @requirements,
      {
      name    => 'perl',
      version => $perl_version // $EMPTY
      };
  }

  foreach my $m ( sort keys %requires ) {

    next if !$self->get_core && $self->is_core($m);

    push @requirements,
      {
      name    => $m,
      version => $requires{$m}
      };
  }

  my $json = JSON::PP->new->pretty;

  return wantarray ? @requirements : $json->encode( \@requirements );
}

########################################################################
sub get_dependencies {
########################################################################
  my ( $self, %options ) = @_;

  if ( $self->get_json ) {
    return scalar $self->format_json;
  }
  elsif ( $self->get_text || $self->get_raw ) {
    return $self->format_text;
  }
  else {
    return $self->format_json;
  }
}

########################################################################
sub format_text {
########################################################################
  my ($self) = @_;

  my @requirements = $self->format_json;
  return if !@requirements;

  my $str = $EMPTY;

  my $max_len = 2 + max map { length $_->{'name'} } @requirements;

  my @output;

  foreach my $module (@requirements) {
    my ( $name, $version ) = @{$module}{qw{ name version }};

    my $separator = $self->get_separator;
    my $format    = "%-${max_len}s%s'%s',";

    if ( $self->get_raw ) {
      $separator = $SPACE;
      $format    = "%-${max_len}s%s%s";
    }
    else {
      $name = "'$name'";
    }

    push @output, sprintf $format, $name, $separator, $version // $EMPTY;
  }

  return join $NEWLINE, @output, $EMPTY;
}

########################################################################
sub to_rpm {
########################################################################
  my ($self) = @_;

  my @rpm_deps = ();

  foreach my $perlver ( sort keys %{ $self->get_perlreq } ) {
    push @rpm_deps, "perl >= $perlver";
  }

  my %require = %{ $self->get_require };

  foreach my $module ( sort keys %require ) {
    next if !$self->get_core && $self->is_core($module);

    if ( !$require{$module} ) {
      my $m;

      if ( $self->get_add_version ) {
        $m = $self->get_module_version($module);
        if ( $m->{'version'} ) {
          $require{$module} = $m->{'version'};

          push @rpm_deps, "perl($module) >= %s", $m->{'version'};
        }
      }

      if ( !$m || !$m->{'version'} ) {
        push @rpm_deps, "perl($module)";
      }
    }
    else {
      push @rpm_deps, "perl($module) >= $require{$module}";
    }
  }

  return join $EMPTY, @rpm_deps;
}

########################################################################
sub main {
########################################################################

  my %options = (
    core               => $TRUE,
    'add-version'      => $TRUE,
    'include-require'  => $TRUE,
    'json'             => $FALSE,
    'text'             => $TRUE,
    'separator'        => q{ => },
    'min-core-version' => '5.8.9',
  );

  GetOptions(
    \%options,              'json|j',
    'text|t',               'core!',
    'min-core-version|m=s', 'add-version|a!',
    'include-require|i!',   'help|h',
    'separator|s=s',        'version|v',
    'raw|r',
  );

  # print {*STDERR} Dumper( \%options );

  if ( $options{'version'} ) {
    pod2usage(
      -exitval  => 1,
      -input    => pod_where( { -inc => 1 }, __PACKAGE__ ),
      -sections => 'VERSION|NAME|AUTHOR',
      -verbose  => 99,
    );
  }

  if ( $options{'help'} ) {
    pod2usage(
      -exitval  => 1,
      -input    => pod_where( { -inc => 1 }, __PACKAGE__ ),
      -sections => 'USAGE|VERSION',
      -verbose  => 99,
    );
  }

  $options{'path'} = shift @ARGV;

  my $scanner = Module::ScanDeps::Static->new( {%options} );
  $scanner->parse;

  if ( $options{'json'} ) {
    print $scanner->get_dependencies( format => 'json' );
  }
  else {
    print $scanner->get_dependencies( format => 'text' );
  }

  exit $SUCCESS;
}

1;

__END__