__PACKAGE__->table("distribution");
__PACKAGE__->add_columns(
"id", { data_type => "integer", is_auto_increment => 1, is_nullable => 0 },
"author", { data_type => "text", is_nullable => 0 },
"archive", { data_type => "text", is_nullable => 0 },
"source", { data_type => "text", is_nullable => 0 },
"mtime", { data_type => "integer", is_nullable => 0 },
"sha256", { data_type => "text", is_nullable => 0 },
"md5", { data_type => "text", is_nullable => 0 },
"metadata", { data_type => "text", is_nullable => 0 },
);
__PACKAGE__->set_primary_key("id");
__PACKAGE__->add_unique_constraint( "author_archive_unique", [ "author", "archive" ] );
__PACKAGE__->has_many(
"packages",
"Pinto::Schema::Result::Package",
{ "foreign.distribution" => "self.id" },
{ cascade_copy => 0, cascade_delete => 0 },
);
__PACKAGE__->has_many(
"prerequisites",
"Pinto::Schema::Result::Prerequisite",
{ "foreign.distribution" => "self.id" },
{ cascade_copy => 0, cascade_delete => 0 },
);
__PACKAGE__->has_many(
"registrations",
"Pinto::Schema::Result::Registration",
{ "foreign.distribution" => "self.id" },
{ cascade_copy => 0, cascade_delete => 0 },
);
'""' => 'to_string',
'cmp' => 'string_compare'
);
our $VERSION = '0.09992_01';
__PACKAGE__->inflate_column(
'metadata' => {
inflate => sub { CPAN::Meta->load_json_string( $_[0] ) },
deflate => sub { $_[0]->as_string( { version => "2" } ) }
}
);
sub FOREIGNBUILDARGS {
my ( $class, $args ) = @_;
$args ||= {};
$args->{source} ||= 'LOCAL';
return $args;
}
sub register {
my ( $self, %args ) = @_;
my $stack = $args{stack};
my $force = $args{force} || 0;
my $pin = $args{pin} || 0;
my $can_intermingle = $stack->repo->config->intermingle;
my $did_register = 0;
$stack->assert_is_open;
$stack->assert_not_locked;
for my $pkg ($self->packages) {
if (not $pkg->can_index) {
my $file = $pkg->file || '';
debug( sub {"Package $pkg in file $file is not indexable. Skipping registration"} );
next;
}
my $where = {package_name => $pkg->name};
my $incumbent = $stack->head->find_related(registrations => $where);
if (not defined $incumbent) {
debug( sub {"Registering package $pkg on stack $stack"} );
$pkg->register(stack => $stack, pin => $pin);
$did_register++;
next;
}
elsif (not $can_intermingle) {
my $dist = $incumbent->distribution;
if ($dist->id == $self->id and $incumbent->is_pinned == $pin) {
debug( sub {"Distribution $dist is already fully registered"} );
last;
}
}
my $incumbent_pkg = $incumbent->package;
if ( $incumbent_pkg == $pkg ) {
debug( sub {"Package $pkg is already on stack $stack"} );
$incumbent->pin && $did_register++ if $pin and not $incumbent->is_pinned;
next;
}
if ( $incumbent->is_pinned ) {
my $pkg_name = $incumbent_pkg->name;
my $dist = $incumbent->distribution;
$force ? whine "Forcibly changing $dist to $self"
: throw "Unable to register distribution $self: $pkg_name is pinned to $incumbent_pkg";
}
whine "Downgrading package $incumbent_pkg to $pkg on stack $stack"
if $incumbent_pkg > $pkg;
if ( $can_intermingle ) {
$incumbent->delete;
}
else {
$incumbent->distribution->unregister(stack => $stack, force => $force);
}
$pkg->register(stack => $stack, pin => $pin);
$did_register++;
}
$stack->mark_as_changed if $did_register;
return $did_register;
}
sub unregister {
my ( $self, %args ) = @_;
my $stack = $args{stack};
my $force = $args{force};
my $did_unregister = 0;
my $conflicts = 0;
$stack->assert_is_open;
$stack->assert_not_locked;
my $rs = $self->registrations( { revision => $stack->head->id } );
for my $reg ( $rs->all ) {
if ( $reg->is_pinned and not $force ) {
my $pkg = $reg->package;
whine "Cannot unregister package $pkg because it is pinned to stack $stack";
$conflicts++;
next;
}
$did_unregister++;
}
throw "Unable to unregister distribution $self from stack $stack" if $conflicts;
$rs->delete;
$stack->mark_as_changed if $did_unregister;
return $did_unregister;
}
sub pin {
my ( $self, %args ) = @_;
my $stack = $args{stack};
$stack->assert_not_locked;
my $rev = $stack->head;
$rev->assert_is_open;
my $where = { revision => $rev->id, is_pinned => 0 };
my $regs = $self->registrations($where);
return 0 if not $regs->count;
$regs->update( { is_pinned => 1 } );
$stack->mark_as_changed;
return 1;
}
sub unpin {
my ( $self, %args ) = @_;
my $stack = $args{stack};
$stack->assert_not_locked;
my $rev = $stack->head;
$rev->assert_is_open;
my $where = { revision => $rev->id, is_pinned => 1 };
my $regs = $self->registrations($where);
return 0 if not $regs->count;
$regs->update( { is_pinned => 0 } );
$stack->mark_as_changed;
return 1;
}
has distname_info => (
isa => 'CPAN::DistnameInfo',
init_arg => undef,
handles => {
name => 'dist',
vname => 'distvname',
version => 'version',
maturity => 'maturity'
},
default => sub { CPAN::DistnameInfo->new( $_[0]->path ) },
lazy => 1,
);
has is_devel => (
is => 'ro',
isa => 'Bool',
init_arg => undef,
default => sub { $_[0]->maturity() eq 'developer' },
lazy => 1,
);
sub path {
my ($self) = @_;
return join '/', ( substr( $self->author, 0, 1 ), substr( $self->author, 0, 2 ), $self->author, $self->archive );
}
sub native_path {
my ( $self, @base ) = @_;
@base = ( $self->repo->config->authors_id_dir ) if not @base;
return Path::Class::file(
@base,
substr( $self->author, 0, 1 ),
substr( $self->author, 0, 2 ),
$self->author, $self->archive
);
}
sub uri {
my ( $self, $base ) = @_;
return 'UNKNOWN' if $self->is_local;
$base ||= $self->source;
return URI->new( "$base/authors/id/" . $self->path )->canonical;
}
sub is_local {
my ($self) = @_;
return $self->source eq 'LOCAL';
}
sub package {
my ( $self, %args ) = @_;
my $pkg_name = $args{name};
my $where = { name => $pkg_name };
my $attrs = { key => 'name_distribution_unique' };
my $pkg = $self->find_related( 'packages', $where, $attrs ) or return;
if ( my $stk_name = $args{stack} ) {
return $pkg->registration( stack => $stk_name ) ? $pkg : ();
}
return $pkg;
}
sub registered_stacks {
my ($self) = @_;
my %stacks;
for my $reg ( $self->registrations ) {
$stacks{ $reg->stack } = $reg->stack;
}
return values %stacks;
}
sub main_module {
my ($self) = @_;
my @pkgs = sort { length $a->name <=> length $b->name } $self->packages;
my $dist_name = $self->name;
$dist_name =~ s/-/::/g;
for my $pkg (@pkgs) {
return $pkg if $pkg->can_index && $pkg->name eq $dist_name;
}
for my $pkg (@pkgs) {
return $pkg if $pkg->can_index;
}
return $pkgs[0] if @pkgs;
return undef;
}
sub package_count {
my ($self) = @_;
return scalar $self->packages;
}
sub prerequisite_specs {
my ($self) = @_;
return map { $_->as_target } $self->prerequisites;
}
sub as_target {
my ($self) = @_;
return Pinto::Target::Distribution->new( path => $self->path );
}
sub string_compare {
my ( $dist_a, $dist_b ) = @_;
my $pkg = __PACKAGE__;
throw "Can only compare $pkg objects"
if not( itis( $dist_a, $pkg ) && itis( $dist_b, $pkg ) );
return 0 if $dist_a->id == $dist_b->id;
my $r = ( $dist_a->archive cmp $dist_b->archive );
return $r;
}
sub to_string {
my ( $self, $format ) = @_;
my %fspec = (
'd' => sub { $self->name },
'D' => sub { $self->vname },
'V' => sub { $self->version },
'm' => sub { $self->is_devel ? 'd' : 'r' },
'M' => sub { my $m = $self->main_module; $m ? $m->name : '' },
'h' => sub { $self->path },
'H' => sub { $self->native_path },
'f' => sub { $self->archive },
's' => sub { $self->is_local ? 'l' : 'f' },
'S' => sub { $self->source },
'a' => sub { $self->author },
'u' => sub { $self->uri },
'c' => sub { $self->package_count },
);
$format ||= $self->default_format;
return String::Format::stringf( $format, %fspec );
}
sub default_format {
my ($self) = @_;
return '%a/%f',
}
__PACKAGE__->meta->make_immutable;
1;