The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Carton::Lock;
use strict;
use Config;
use Carton::Dist;
use Carton::Dist::Core;
use Carton::Package;
use Carton::Index;
use Carton::Util;
use CPAN::Meta;
use CPAN::Meta::Requirements;
use File::Find ();
use Module::CoreList;
use Moo;

has version => (is => 'ro');
has modules => (is => 'ro', default => sub { +{} });

use constant CARTON_LOCK_VERSION => '0.9';

sub from_file {
    my($class, $file) = @_;

    my $data = Carton::Util::load_json($file);
    return $class->new($data);
}

sub write {
    my($self, $file) = @_;
    Carton::Util::dump_json({ %$self }, $file);
}

sub distributions {
    map Carton::Dist->new($_), values %{$_[0]->modules}
}

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

    for my $meta (values %{$_[0]->modules}) {
        if ($meta->{provides}{$module}) {
            return Carton::Dist->new( $self->modules->{$meta->{name}} );
        }
    }

    return;
}

sub find_or_core {
    my($self, $module) = @_;
    $self->find($module) || $self->find_in_core($module);
}

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

    if (exists $Module::CoreList::version{$]}{$module}) {
        my $version = $Module::CoreList::version{$]}{$module}; # maybe undef
        return Carton::Dist::Core->new(name => $module, version => $version);
    }

    return;
}

sub index {
    my $self = shift;

    my $index = Carton::Index->new;
    for my $package ($self->packages) {
        $index->add_package($package);
    }

    return $index;
}

sub packages {
    my $self = shift;

    my @packages;
    while (my($name, $metadata) = each %{$self->modules}) {
        while (my($package, $provides) = each %{$metadata->{provides}}) {
            # TODO what if duplicates?
            push @packages, Carton::Package->new($package, $provides->{version}, $metadata->{pathname});
        }
    }

    return @packages;
}

sub write_index {
    my($self, $file) = @_;

    open my $fh, ">", $file or die $!;
    $self->index->write($fh);
}

sub build_from_local {
    my($class, $path, $prereqs) = @_;

    my $installs = $class->find_installs($path, $prereqs);

    return $class->new(
        modules => $installs,
        version => CARTON_LOCK_VERSION,
    );
}

sub find_installs {
    my($class, $path, $prereqs) = @_;

    my $libdir = "$path/lib/perl5/$Config{archname}/.meta";
    return {} unless -e $libdir;

    my $reqs = CPAN::Meta::Requirements->new;
    $reqs->add_requirements($prereqs->requirements_for($_, 'requires'))
      for qw( configure build runtime test develop );

    my @installs;
    my $wanted = sub {
        if ($_ eq 'install.json') {
            push @installs, [ $File::Find::name, "$File::Find::dir/MYMETA.json" ];
        }
    };
    File::Find::find($wanted, $libdir);

    my %installs;
    for my $file (@installs) {
        my $module = Carton::Util::load_json($file->[0]);
        my $mymeta = -f $file->[1] ? CPAN::Meta->load_file($file->[1])->as_struct({ version => "2" }) : {};
        if ($reqs->accepts_module($module->{name}, $module->{provides}{$module->{name}}{version})) {
            if (my $exist = $installs{$module->{name}}) {
                my $old_ver = version->new($exist->{provides}{$module->{name}}{version});
                my $new_ver = version->new($module->{provides}{$module->{name}}{version});
                if ($new_ver >= $old_ver) {
                    $installs{ $module->{name} } = { %$module, mymeta => $mymeta };
                } else {
                    # Ignore same distributions older than the one we have
                }
            } else {
                $installs{ $module->{name} } = { %$module, mymeta => $mymeta };
            }
        } else {
            # Ignore installs because cpanfile doesn't accept it
        }
    }

    return \%installs;
}

1;