view release on metacpan or  search on metacpan

local/lib/perl5/Module/ScanDeps.pm  view on Meta::CPAN

    return [
        $loader_file,
        map { my $mod="$prefix$_"; $mod =~ s{::}{/}g; "$mod.pm" }
        grep { length and !/^q[qw]?$/ and !/-/ }
        split /[^\w:-]+/, $loadee
        #should skip any module name that contains '-', not split it in two
    ];
}

sub scan_chunk {
    my $chunk = shift;

    # Module name extraction heuristics {{{
    my $module = eval {
        $_ = $chunk;
        s/^\s*//;

        # TODO: There's many more of these "loader" type modules on CPAN!
        # scan for the typical module-loader modules
        my $loaders = "asa base parent prefork POE encoding maybe only::matching Mojo::Base";
        # grab pre-calculated regexp or re-build it (and cache it)
        my $loader_regexp = $LoaderRegexp{$loaders} || _build_loader_regexp($loaders);
        if ($_ =~ $loader_regexp) { # $1 == loader, $2 == loadee
          my $retval = _extract_loader_dependency($1, $2);
          return $retval if $retval;
        }

        $loader_regexp = $LoaderRegexp{"Catalyst"} || _build_loader_regexp("Catalyst", "Catalyst::Plugin");
        if ($_ =~ $loader_regexp) { # $1 == loader, $2 == loadee
          my $retval = _extract_loader_dependency($1, $2, "Catalyst::Plugin");
          return $retval if $retval;
        }

        return [ 'Class/Autouse.pm',
            map { s{::}{/}g; "$_.pm" }
              grep { length and !/^:|^q[qw]?$/ } split(/[^\w:]+/, $1) ]
          if /^use \s+ Class::Autouse \b \s* (.*)/sx
              or /^Class::Autouse \s* -> \s* autouse \s* (.*)/sx;

        return $1 if /^(?:use|no|require) \s+ ([\w:\.\-\\\/\"\']+)/x;
        return $1
          if /^(?:use|no|require) \s+ \( \s* ([\w:\.\-\\\/\"\']+) \s* \)/x;

        if (   s/^eval\s+\"([^\"]+)\"/$1/
            or s/^eval\s*\(\s*\"([^\"]+)\"\s*\)/$1/)
        {
            return $1 if /^\s* (?:use|no|require) \s+ ([\w:\.\-\\\/\"\']*)/x;
        }

        if (/(<[^>]*[^\$\w>][^>]*>)/) {
            my $diamond = $1;
            return "File/Glob.pm" if $diamond =~ /[*?\[\]{}~\\]/;
        }

        return "DBD/$1.pm"    if /\b[Dd][Bb][Ii]:(\w+):/;

        # check for stuff like
        #   decode("klingon", ...)
        #   open FH, "<:encoding(klingon)", ...
        if (my ($args) = /\b(?:open|binmode)\b(.*)/) {
            my @mods;
            push @mods, qw( PerlIO.pm PerlIO/encoding.pm Encode.pm ), _find_encoding($1)
                if $args =~ /:encoding\((.*?)\)/;
            push @mods, qw( PerlIO.pm PerlIO/via.pm )
                if $args =~ /:via\(/;
            return \@mods if @mods;
        }
        if (/\b(?:en|de)code\(\s*['"]?([-\w]+)/) {
            return [qw( Encode.pm ), _find_encoding($1)]; 
        }

        return $1 if /\b do \s+ ([\w:\.\-\\\/\"\']*)/x;

        if ($SeenTk) {
            my @modules;
            while (/->\s*([A-Z]\w+)/g) {
                push @modules, "Tk/$1.pm";
            }
            while (/->\s*Scrolled\W+([A-Z]\w+)/g) {
                push @modules, "Tk/$1.pm";
                push @modules, "Tk/Scrollbar.pm";
            }
            if (/->\s*setPalette/g) {
                push @modules,
                  map { "Tk/$_.pm" }
                  qw( Button Canvas Checkbutton Entry
                      Frame Label Labelframe Listbox
                      Menubutton Menu Message Radiobutton
                      Scale Scrollbar Spinbox Text );
            }
            return \@modules;
        }

        # Module::Runtime
        return $1 if /\b(?:require_module|use_module|use_package_optimistically) \s* \( \s* ([\w:"']+)/x;

        # Test::More
        return $1 if /\b(?:require_ok|use_ok) \s* \( \s* ([\w:"']+)/x;

        return;
    };

    # }}}

    return unless defined($module);
    return wantarray ? @$module : $module->[0] if ref($module);

    $module =~ s/^['"]//;
    return unless $module =~ /^\w/;

    $module =~ s/\W+$//;
    $module =~ s/::/\//g;
    return if $module =~ /^(?:[\d\._]+|'.*[^']|".*[^"])$/;

    $module .= ".pm" unless $module =~ /\./;
    return $module;
}

sub _find_encoding {
    return unless $] >= 5.008 and eval { require Encode; %Encode::ExtModule };