view release on metacpan or  search on metacpan

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

    foreach my $key (keys(%$inchash)) {
        my $newkey = $key;
        $newkey =~ s"^(?:(?:$inc)/?)""sg if File::Spec->file_name_is_absolute($newkey);

        $rv->{$newkey} = {
            'used_by' => [],
            'file'    => $inchash->{$key},
            'type'    => _gettype($inchash->{$key}),
            'key'     => $key
        };
    }

    foreach my $dl_file (@$dl_shared_objects) {
        my $key = $dl_file;
        $key =~ s"^(?:(?:$inc)/?)""s;

        $rv->{$key} = {
            'used_by' => [],
            'file'    => $dl_file,
            'type'    => 'shared',
            'key'     => $key
        };
    }

    return $rv;
}

sub _extract_info {
    my ($fname) = @_;

    use vars qw(%inchash @dl_shared_objects @incarray);

    unless (do $fname) {
        die "error extracting info from DataFeed file: ",
            $@ || "can't read $fname: $!";
    }

    my %ih = %inchash;
    my @dso = @dl_shared_objects;
    my @ia = @incarray;
    return (\%ih, \@dso, \@ia);
}

sub _gettype {
    my $name = shift;
    my $dlext = quotemeta(dl_ext());

    return 'autoload' if $name =~ /(?:\.ix|\.al)$/i;
    return 'module'   if $name =~ /\.p[mh]$/i;
    return 'shared'   if $name =~ /\.$dlext$/i;
    return 'data';
}

# merge all keys from $rv_sub into the $rv mega-ref
sub _merge_rv {
    my ($rv_sub, $rv) = @_;

    my $key;
    foreach $key (keys(%$rv_sub)) {
        my %mark;
        if ($rv->{$key} and _not_dup($key, $rv, $rv_sub)) {
            warn "Different modules for file '$key' were found.\n"
                . " -> Using '" . _abs_path($rv_sub->{$key}{file}) . "'.\n"
                . " -> Ignoring '" . _abs_path($rv->{$key}{file}) . "'.\n";
            $rv->{$key}{used_by} = [
                grep (!$mark{$_}++,
                    @{ $rv->{$key}{used_by} },
                    @{ $rv_sub->{$key}{used_by} })
            ];
            @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
            $rv->{$key}{file} = $rv_sub->{$key}{file};
        }
        elsif ($rv->{$key}) {
            $rv->{$key}{used_by} = [
                grep (!$mark{$_}++,
                    @{ $rv->{$key}{used_by} },
                    @{ $rv_sub->{$key}{used_by} })
            ];
            @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
        }
        else {
            $rv->{$key} = {
                used_by => [ @{ $rv_sub->{$key}{used_by} } ],
                file    => $rv_sub->{$key}{file},
                key     => $rv_sub->{$key}{key},
                type    => $rv_sub->{$key}{type}
            };

            @{ $rv->{$key}{used_by} } = grep length, @{ $rv->{$key}{used_by} };
        }
    }
}

sub _not_dup {
    my ($key, $rv1, $rv2) = @_;
    if (File::Spec->case_tolerant()) {
        return lc(_abs_path($rv1->{$key}{file})) ne lc(_abs_path($rv2->{$key}{file}));
    }
    else {
        return _abs_path($rv1->{$key}{file}) ne _abs_path($rv2->{$key}{file});
    }
}

sub _abs_path {
    return join(
        '/',
        Cwd::abs_path(File::Basename::dirname($_[0])),
        File::Basename::basename($_[0]),
    );
}


sub _warn_of_runtime_loader {
    my $module = shift;
    return if $SeenRuntimeLoader{$module}++;
    $module =~ s/\.pm$//;
    $module =~ s|/|::|g;
    warn "# Use of runtime loader module $module detected.  Results of static scanning may be incomplete.\n";
    return;
}

sub _warn_of_missing_module {
    my $module = shift;
    my $warn = shift;
    return if not $warn;
    return if not $module =~ /\.p[ml]$/;
    warn "# Could not find source file '$module' in \@INC or \@IncludeLibs. Skipping it.\n"
      if not -f $module;
}

sub _get_preload1 {
    my $pm = shift;
    my $preload = $Preload{$pm} or return();
    if ($preload eq 'sub') {
        $pm =~ s/\.p[mh]$//i;
        return  _glob_in_inc($pm, 1);
    }
    elsif (UNIVERSAL::isa($preload, 'CODE')) {
        return $preload->($pm);
    }
    return @$preload;
}

sub _get_preload {
    my ($pm, $seen) = @_;
    $seen ||= {};
    $seen->{$pm}++;
    my @preload;

    foreach $pm (_get_preload1($pm))
    {
        next if $seen->{$pm};
        $seen->{$pm}++;
        push @preload, $pm, _get_preload($pm, $seen);