view release on metacpan or  search on metacpan

t/maintainer/dependencies.t  view on Meta::CPAN

of hashes of the form

    {
      line => $line,
      file => $file,
    }

pointing at the precise location in the source code where the
dependency was found.  Only dependencies against a real C<.pm> file
are accounted for (not C<.so>, not C<.bs>); also,
L</@maintainer_dependencies> are not listed if found in
C<t/maintainer>.

=cut

sub list_deps {
    my $retval;
    foreach my $file (@_) {
        die "Cannot open $file: $!" unless defined
            (my $fd = IO::File->new($file, "<"));
        # Here we go again with your usual half-assed Perl parser...
        LINE: while(my $line = $fd->getline) {
            CHUNK: foreach my $pm (Module::ScanDeps::scan_line($line),
                                   scan_line_some_more($line, $file, $fd)) {
                next LINE if skip_pod($file, $fd, $pm);

                next CHUNK unless ($pm =~ m/\.pm$/);
                my $module = file2mod($pm);
                next CHUNK if
                    ($file =~ m/\bt\b\W+\bmaintainer\b/ &&
                     grep { $module eq $_ } @maintainer_dependencies);
                # Works around bug #25547 on rt.cpan.org:
                next CHUNK if ($module eq "File::Glob") &&
                    ($line !~ m/Glob/);

                # Now ask Module::ScanDeps to find the actual module
                # on disk.  If not found (or found within our own
                # distribution), then count as a false positive.
                my %rv;
                Module::ScanDeps::add_deps(rv => \%rv, modules => [ $pm ]);
                next CHUNK unless (exists($rv{$pm}) &&
                                   exists($rv{$pm}->{file}));
                next CHUNK if is_our_own_file($rv{$pm}->{file});

                push(@{$retval->{$module}},
                     { file => $file,
                       line => $fd->input_line_number });
            }
            skip_here_document($file, $fd, $line);
        }
    }
    return $retval;
}

=head2 skip_pod($filename, $fd, $pm)

=head2 skip_here_document($filename, $fd, $line)

Both functions advance $fd, an instance of L<IO::Handle>, to skip past
non-Perl source code constructs, and return true if they indeed did
skip something (or throw an exception if they tried and failed).  $pm
is a token returned by L<Module::ScanDeps/scan_line>; $line is a line
of the Perl source file. $filename is only used to construct the text
of error messages.

=cut

sub skip_pod {
    my ($file, $fd, $pm) = @_;
    return unless $pm eq '__POD__';
    my $podline = $fd->input_line_number;
    while (<$fd>) { return 1 if (/^=cut/) }
    die <<"MESSAGE";
Could not find end of POD at $file line $podline
MESSAGE
}

sub skip_here_document {
    my ($file, $fd, $line) = @_;
    # Regex mostly lifted from Emacs' cperl-mode.el, which may or may
    # not be accurate.  The case of multiple here-docs on the same
    # line is not accounted for.
    $line =~ s/#.*$//g; # Snip comments
    return unless
        ($line =~ m/  (.*)
                      <<  \s*
                      (?: '(.*?)' | "(.*?)" | ([A-Za-z][A-Za-z0-9_]*) )
                      /x);
    my $leadingstuff = $1;
    my $heredelim = $2 || $3 || $4;
    # Eval'ed here-docs don't count, they are treated as real code (!):
    return if ($leadingstuff =~ m/eval\s*$/);
    my $hereline = $fd->input_line_number;
    while (<$fd>) { return 1 if (/^\Q$heredelim\E/) }
    die <<"MESSAGE";
Could not find end of here document ($heredelim) at $file line $hereline
MESSAGE
}

=head2 scan_line_some_more($line, $filename, $fd)

Works like L<Module::ScanDeps/scan_line>, and works around the
limitations thereof by detecting more forms of dependencies.  $fd is
available in case the code wants to slurp more lines in order to get
hold of a complete Perl statement.  $filename is only used to generate
error messages.

=cut

sub scan_line_some_more {
    local $_ = shift;
    my ($file, $fd) = @_;

    my $lineno = $fd->input_line_number;
    my @retval;

    # Catalyst mojo constructs:
    if (m|use \s+ Catalyst \s+ |x) {
        until (m/ use \s+ Catalyst \s+ (.*);/sx) {
            my $nextline = <$fd>;
            die <<"MESSAGE" if ! defined $nextline;