File Coverage

blib/lib/Distribution/Metadata.pm

Criterion	Covered	Total	%
statement	154	245	62.8
branch	39	84	46.4
condition	12	42	28.5
subroutine	38	43	88.3
pod	14	14	100.0
total	257	428	60.0

package Distribution::Metadata;
use 5.008001;
use strict;
use warnings;
use CPAN::DistnameInfo;
use CPAN::Meta;
use Config;
use Cwd ();
use ExtUtils::Packlist;
use File::Basename qw(basename dirname);
use File::Find 'find';
use File::Spec::Functions qw(catdir catfile);
use JSON ();
use Module::Metadata;
use constant DEBUG => $ENV{PERL_DISTRIBUTION_METADATA_DEBUG};

my $SEP = qr{/|\\}; # path separater
my $ARCHNAME = $Config{archname};

our $VERSION = "0.05";

our $CACHE;

sub new_from_file {
    my ($class, $file, %option) = @_;
    $class->_new(%option, _module => {file => $file});
}

sub new_from_module {
    my ($class, $module, %option) = @_;
    $class->_new(%option, _module => {name => $module});
}

sub _new {
    my ($class, %option) = @_;
    my $module = $option{_module};
    my $inc = $option{inc} || \@INC;
    $inc = $class->_abs_path($inc);
    $inc = $class->_fill_archlib($inc) if $option{fill_archlib};
    my $metadata = $module->{file}
        ? Module::Metadata->new_from_file($module->{file}, inc => $inc)
        : Module::Metadata->new_from_module($module->{name}, inc => $inc);

    my $self = bless {}, $class;
    return $self unless $metadata;

    $module->{file} = $metadata->filename;
    $module->{name} = $metadata->name;
    $module->{version} = $metadata->version;

    my ($packlist, $files) = $class->_find_packlist($module->{file}, $inc);
    if ($packlist) {
        $self->{packlist} = $packlist;
        $self->{files}    = $files;
    } else {
        return $self;
    }

    my ($main_module, $lib) = $self->_guess_main_module($packlist);
    if ($main_module) {
        $self->{main_module} = $main_module;
        if ($main_module eq "perl") {
            $self->{main_module_version} = $^V;
            $self->{main_module_file} = $^X;
            $self->{dist} = "perl";
            my $version = "" . $^V;
            $version =~ s/v//;
            $self->{distvname} = "perl-$version";
            $self->{version} = $version;
            return $self;
        }
    } else {
        return $self;
    }

    my $archlib = catdir($lib, $ARCHNAME);
    my $main_metadata = Module::Metadata->new_from_module(
        $main_module, inc => [$archlib, $lib]
    );

    my ($find_module, $find_version);
    if ($main_metadata) {
        $self->{main_module_version} = $main_metadata->version;
        $self->{main_module_file} = $main_metadata->filename;
        $find_module = $main_metadata->name;
        $find_version = $main_metadata->version;
    } else {
        $find_module = $module->{name};
        $find_version = $module->{version};
    }

    my ($meta_directory, $install_json, $install_json_hash, $mymeta_json) = $class->_find_meta(
        $main_module, $find_module, $find_version,
        catdir($archlib, ".meta")
    );
    $self->{meta_directory}    = $meta_directory;
    $self->{install_json}      = $install_json;
    $self->{install_json_hash} = $install_json_hash;
    $self->{mymeta_json}       = $mymeta_json;
    $self;
}

sub _guess_main_module {
    my ($self, $packlist) = @_;
    my @piece = File::Spec->splitdir( dirname($packlist) );
    if ($piece[-1] eq $ARCHNAME) {
        return ("perl", undef);
    }

    my (@module, @lib);
    for my $i ( 1 .. ($#piece-2) ) {
        if ($piece[$i] eq $ARCHNAME && $piece[$i+1] eq "auto") {
            @module = @piece[ ($i+2) .. $#piece ];
            @lib    = @piece[ 0      .. ($i-1)  ];
            last;
        }
    }
    return unless @module;
    return ( _fix_module_name( join("::", @module) ), catdir(@lib) );
}

# ugly workaround for case insensitive filesystem
# eg: if you install 'Version::Next' module and later 'version' module,
# then version's packlist is located at Version/.packlist! (capital V!)
# Maybe there are a lot of others...
my @fix_module_name = qw(version Version::Next);
sub _fix_module_name {
    my $module_name = shift;
    if (my ($fix) = grep { $module_name =~ /^$_$/i } @fix_module_name) {
        $fix;
    } else {
        $module_name;
    }
}

sub _fill_archlib {
    my ($class, $incs) = @_;
    my %incs = map { $_ => 1 } @$incs;
    my @out;
    for my $inc (@$incs) {
        push @out, $inc;
        next if $inc =~ /$ARCHNAME$/o;
        my $archlib = catdir($inc, $ARCHNAME);
        if (-d $archlib && !$incs{$archlib}) {
            push @out, $archlib;
        }
    }
    \@out;
}

my $decode_install_json = sub {
    my $file = shift;
    my $content = do { open my $fh, "<", $file or next; local $/; <$fh> };
    JSON::decode_json($content);
};
sub _decode_install_json {
    my ($class, $file, $dir) = @_;
    if ($CACHE) {
        $CACHE->{install_json}{$dir}{$file} ||= $decode_install_json->($file);
    } else {
        $decode_install_json->($file);
    }
}
sub _find_meta {
    my ($class, $main_module, $module, $version, $dir) = @_;
    return unless -d $dir;

    my @install_json;
    if ($CACHE and $CACHE->{install_json_collected}{$dir}) {
        @install_json = keys %{$CACHE->{install_json}{$dir}};
    } else {
        @install_json = do {
            opendir my $dh, $dir or die "opendir $dir: $!";
            my @meta_dir = grep { !/^[.]{1,2}$/ } readdir $dh;
            grep -f, map { catfile($dir, $_, "install.json") } @meta_dir;
        };
        if ($CACHE) {
            $CACHE->{install_json}{$dir}{$_} ||= undef for @install_json;
            $CACHE->{install_json_collected}{$dir}++;
        }
    }

    # to speed up, first try distribution which just $module =~ s/::/-/gr;
    my $naive = do { my $dist = $main_module; $dist =~ s/::/-/g; $dist };
    @install_json = (
        (sort { $b cmp $a } grep {  /^$naive/ } @install_json),
        (sort { $b cmp $a } grep { !/^$naive/ } @install_json),
    );

    my ($meta_directory, $install_json, $install_json_hash, $mymeta_json);
    INSTALL_JSON_LOOP:
    for my $file (@install_json) {
        my $hash = $class->_decode_install_json($file, $dir);

        # name VS target ? When LWP, name is LWP, and target is LWP::UserAgent
        # So name is main_module!
        my $name = $hash->{name} || "";
        next if $name ne $main_module;
        my $provides = $hash->{provides} || +{};
        for my $provide (sort keys %$provides) {
            if ($provide eq $module
                && ($provides->{$provide}{version} || "") eq $version) {
                $meta_directory = dirname($file);
                $install_json = $file;
                $mymeta_json  = catfile($meta_directory, "MYMETA.json");
                $install_json_hash = $hash;
                last INSTALL_JSON_LOOP;
            }
        }
        DEBUG and warn "==> failed to find $module $version in $file\n";
    }

    return ($meta_directory, $install_json, $install_json_hash, $mymeta_json);
}

sub _naive_packlist {
    my ($class, $module_file, $inc) = @_;
    for my $i (@$inc) {
        if (my ($path) = $module_file =~ /$i $SEP (.+)\.pm /x) {
            my $archlib = $i =~ /$ARCHNAME$/o ? $i : catdir($i, $ARCHNAME);
            my $try = catfile( $archlib, "auto", $path, ".packlist" );
            return $try if -f $try;
        }
    }
    return;
}

# It happens that .packlist files are symlink path.
# eg: OSX,
# in .packlist: /var/folders/...
# but /var/folders/.. is a symlink to /private/var/folders
my $extract_files = sub {
    my $packlist = shift;
    [
        map  { Cwd::abs_path($_) } grep { -f }
        sort keys %{ ExtUtils::Packlist->new($packlist) || +{} }
    ];
};
sub _extract_files {
    my ($class, $packlist) = @_;
    if ($CACHE) {
        $CACHE->{packlist}{$packlist} ||= $extract_files->($packlist);
    } else {
        $extract_files->($packlist);
    }
}

sub _core_packlist {
    my ($self, $inc) = @_;
    for my $dir (grep -d, @$inc) {
        opendir my $dh, $dir or die "Cannot open dir $dir: $!\n";
        my ($packlist) = map { catfile($dir, $_) } grep {$_ eq ".packlist"} readdir $dh;
        return $packlist if $packlist;
    }
    return;
}

sub _find_packlist {
    my ($class, $module_file, $inc) = @_;

    if ($CACHE and my $core_packlist = $CACHE->{core_packlist}) {
        my $files = $class->_extract_files($core_packlist);
        if (grep {$module_file eq $_} @$files) {
            return ($core_packlist, $files);
        }
    }

    # to speed up, first try packlist which is naively guessed by $module_file
    if (my $naive_packlist = $class->_naive_packlist($module_file, $inc)) {
        my $files = $class->_extract_files($naive_packlist);
        if ( grep { $module_file eq $_ } @$files ) {
            DEBUG and warn "-> naively found packlist: $module_file\n";
            return ($naive_packlist, $files);
        }
    }

    my @packlists;
    if ($CACHE and $CACHE->{packlist_collected}) {
        @packlists = keys %{ $CACHE->{packlist} };
    } else {
        if (my $core_packlist = $class->_core_packlist($inc)) {
            push @packlists, $core_packlist;
            $CACHE->{core_packlist} = $core_packlist if $CACHE;
        }
        find sub {
            return unless -f;
            return unless $_ eq ".packlist";
            push @packlists, $File::Find::name;
        }, grep -d, map { catdir($_, "auto") } @{$class->_fill_archlib($inc)};
        if ($CACHE) {
            $CACHE->{packlist}{$_} ||= undef for @packlists;
            $CACHE->{packlist_collected}++;
        }
    }

    for my $try (@packlists) {
        my $files = $class->_extract_files($try);
        if (grep { $module_file eq $_ } @$files) {
            return ($try, $files);
        }
    }
    return;
}

sub _abs_path {
    my ($class, $dirs) = @_;
    my @out;
    for my $dir (grep -d, @$dirs) {
        my $abs = Cwd::abs_path($dir);
        $abs =~ s/$SEP+$//;
        push @out, $abs if $abs;
    }
    \@out;
}

sub packlist            { shift->{packlist} }
sub meta_directory      { shift->{meta_directory} }
sub install_json        { shift->{install_json} }
sub mymeta_json         { shift->{mymeta_json} }
sub main_module         { shift->{main_module} }
sub main_module_version { shift->{main_module_version} }
sub main_module_file    { shift->{main_module_file} }
sub files               { shift->{files} }
sub install_json_hash   { shift->{install_json_hash} }

sub mymeta_json_hash {
    my $self = shift;
    return unless my $mymeta_json = $self->mymeta_json;
    $self->{mymeta_json_hash} ||= CPAN::Meta->load_file($mymeta_json)->as_struct;
}

sub _distnameinfo {
    my $self = shift;
    return unless my $hash = $self->install_json_hash;
    $self->{_distnameinfo} ||= CPAN::DistnameInfo->new( $hash->{pathname} );
}

for my $attr (qw(dist version cpanid distvname pathname)) {
    no strict 'refs';
    *$attr = sub {
        my $self = shift;
        return $self->{$attr} if exists $self->{$attr}; # for 'perl' distribution
        return unless $self->_distnameinfo;
        $self->_distnameinfo->$attr;
    };
}

# alias
sub name   { shift->dist }
sub author { shift->cpanid }

1;

__END__