Debbugs/Package.pm

   1 # This module is part of debbugs, and
   2 # is released under the terms of the GPL version 3, or any later
   3 # version (at your option). See the file README and COPYING for more
   4 # information.
   5 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
   6
   7 package Debbugs::Package;
   8
   9 =head1 NAME
  10
  11 Debbugs::Package -- OO interface to packages
  12
  13 =head1 SYNOPSIS
  14
  15    use Debbugs::Package;
  16    Debbugs::Package->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
  17
  18 =head1 DESCRIPTION
  19
  20
  21
  22 =cut
  23
  24 use Mouse;
  25 use strictures 2;
  26 use v5.10; # for state
  27 use namespace::autoclean;
  28
  29 use List::AllUtils  qw(uniq pairmap);
  30 use Debbugs::Config qw(:config);
  31 use Debbugs::Version::Source;
  32 use Debbugs::Version::Binary;
  33
  34 extends 'Debbugs::OOBase';
  35
  36 has name => (is => 'ro', isa => 'Str',
  37              required => 1,
  38             );
  39
  40 has type => (is => 'bare', isa => 'Str',
  41              lazy => 1,
  42              builder => '_build_type',
  43              clearer => '_clear_type',
  44              reader => '_type',
  45              writer => '_set_type',
  46             );
  47
  48 sub _build_type {
  49     my $self = shift;
  50     if ($self->name !~ /^src:/) {
  51         return 'binary';
  52     }
  53 }
  54
  55 sub qualified_name {
  56     my $self = shift;
  57     return
  58         # src: if source, nothing if binary
  59         ($self->_type eq 'source' ? 'src:':'') .
  60         $self->name;
  61 }
  62
  63 sub url {
  64     my $self = shift;
  65     return $config{web_domain}.'/'.$self->qualified_name;
  66 }
  67
  68 around BUILDARGS => sub {
  69     my $orig = shift;
  70     my $class = shift;
  71     my %args;
  72     if (@_==1 and ref($_[0]) eq 'HASH') {
  73         %args = %{$_[0]};
  74     } else {
  75         %args = @_;
  76     }
  77     $args{name} //= '(unknown)';
  78     if ($args{name} =~ /src:(.+)/) {
  79         $args{name} = $1;
  80         $args{type} = 'source';
  81     } else {
  82         $args{type} = 'binary' unless
  83             defined $args{type};
  84     }
  85     return $class->$orig(%args);
  86 };
  87
  88 sub is_source {
  89     return $_[0]->_type eq 'source'
  90 }
  91
  92 sub is_binary {
  93     return $_[0]->_type eq 'binary'
  94 }
  95
  96 has valid => (is => 'ro', isa => 'Bool',
  97               lazy => 1,
  98               builder => '_build_valid',
  99               writer => '_set_valid',
 100              );
 101
 102 sub _build_valid {
 103     my $self = shift;
 104     if ($self->_valid_versioninfo > 0) {
 105         return 1;
 106     }
 107     return 0;
 108 }
 109
 110 # this contains source name, source version, binary name, binary version, arch,
 111 # and dist which have been selected from the database. It is used to build
 112 # versions and anything else which are known as required.
 113 has 'valid_version_info' =>
 114     (is => 'bare', isa => 'ArrayRef',
 115      traits => ['Array'],
 116      lazy => 1,
 117      builder => '_build_valid_versioninfo',
 118      predicate => '_has_valid_versioninfo',
 119      clearer => '_clear_valid_versioninfo',
 120      handles => {'_get_valid_versioninfo' => 'get',
 121                  '_grep_valid_versioninfo' => 'grep',
 122                  '_valid_versioninfo' => 'elements',
 123                 },
 124     );
 125
 126 sub _build_valid_versioninfo {
 127     my $self = shift;
 128     my $pkgs = $self->_get_valid_version_info_from_db;
 129     for my $invalid_version (@{$pkgs->{$self->qualified_name}->{invalid_versions}}) {
 130         $self->_mark_invalid_version($invalid_version,1);
 131     }
 132     return $pkgs->{$self->qualified_name}->{valid_version_info} // [];
 133 }
 134
 135 state $common_dists = [@{$config{distributions}}];
 136 sub _get_valid_version_info_from_db {
 137     my $self;
 138     if ((@_ % 2) == 1 and
 139         blessed($_[0])) {
 140         $self = shift;
 141     }
 142     my %args = @_;
 143     my @packages;
 144     my $s; # schema
 145     if (defined $self) {
 146         if ($self->has_schema) {
 147             $s = $self->schema;
 148         } else {
 149             $s = $args{schema};
 150         }
 151         @packages = $self->qualified_name;
 152     } else {
 153         $s = $args{schema};
 154         @packages = @{$args{packages}};
 155     }
 156     if (not defined $s) {
 157         confess("get_info_from_db not implemented without schema");
 158     }
 159     my %src_packages;
 160     my %src_ver_packages;
 161     my %bin_packages;
 162     my %bin_ver_packages;
 163     # split packages into src/ver, bin/ver, src, and bin so we can select them
 164     # from the database
 165     local $_;
 166     for my $pkg (@packages) {
 167         if (ref($pkg)) {
 168             if ($pkg->[0] =~ /^src:(.+)$/) {
 169                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 170                     $src_ver_packages{$1}{$ver} = 0;
 171                 }
 172             } else {
 173                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 174                     $bin_ver_packages{$pkg->[0]}{$ver} = 0;
 175                 }
 176             }
 177         } elsif ($pkg =~ /^src:(.+)$/) {
 178             $src_packages{$1} = 0;
 179         } else {
 180             $bin_packages{$pkg} = 0;
 181         }
 182     }
 183     # calculate searches for packages where we want specific versions. We
 184     # calculate this here so add_result_to_package can stomp over
 185     # %src_ver_packages and %bin_ver_packages
 186     my @src_ver_search;
 187     for my $sp (keys %src_ver_packages) {
 188         push @src_ver_search,
 189             (-and => {'src_pkg.pkg' => $sp,
 190                       'me.ver' => [keys %{$src_ver_packages{$sp}}],
 191                      },
 192              );
 193     }
 194
 195     my @bin_ver_search;
 196     for my $sp (keys %bin_ver_packages) {
 197         push @bin_ver_search,
 198             (-and => {'bin_pkg.pkg' => $sp,
 199                       'me.ver' => [keys %{$bin_ver_packages{$sp}}],
 200                      },
 201              );
 202     }
 203     my $packages = {};
 204     sub _default_pkg_info {
 205         return {name => $_[0],
 206                 type => $_[1]//'source',
 207                 valid => $_[2]//1,
 208                 valid_version_info => [],
 209                 invalid_versions => {},
 210                };
 211     }
 212     sub add_result_to_package {
 213         my ($pkgs,$rs,$svp,$bvp,$sp,$bp) = @_;
 214         while (my $pkg = $rs->next) {
 215             my $n = 'src:'.$pkg->{src_pkg};
 216             if (not exists $pkgs->{$n}) {
 217                 $pkgs->{$n} =
 218                     _default_pkg_info($pkg->{src_pkg});
 219             }
 220             push @{$pkgs->{$n}{valid_version_info}},
 221                {%$pkg};
 222             $n = $pkg->{bin_pkg};
 223             if (not exists $pkgs->{$n}) {
 224                 $pkgs->{$n} =
 225                     _default_pkg_info($pkg->{bin_pkg},'binary');
 226             }
 227             push @{$pkgs->{$n}{valid_version_info}},
 228                    {%$pkg};
 229             # this is a package with a valid src_ver
 230             $svp->{$pkg->{src_pkg}}{$pkg->{src_ver}}++;
 231             $sp->{$pkg->{src_pkg}}++;
 232             # this is a package with a valid bin_ver
 233             $bvp->{$pkg->{bin_pkg}}{$pkg->{bin_ver}}++;
 234             $bp->{$pkg->{bin_pkg}}++;
 235         }
 236     }
 237     my $src_rs = $s->resultset('SrcVer')->
 238         search({-or => [-and => {'src_pkg.pkg' => [keys %src_packages],
 239                                  -or => {'suite.codename' => $common_dists,
 240                                          'suite.suite_name' => $common_dists,
 241                                         },
 242                                 },
 243                         @src_ver_search,
 244                        ],
 245                },
 246               {join => ['src_pkg',
 247                        {'src_associations' => 'suite'},
 248                        {'bin_vers' => ['bin_pkg','arch']},
 249                         'maintainer',
 250                        ],
 251                'select' => [qw(src_pkg.pkg),
 252                             qw(suite.codename),
 253                             qw(suite.suite_name),
 254                             qw(src_associations.modified),
 255                             qw(me.ver),
 256                             q(CONCAT(src_pkg.pkg,'/',me.ver)),
 257                             qw(bin_vers.ver bin_pkg.pkg arch.arch),
 258                             qw(maintainer.name),
 259                            ],
 260                'as' => [qw(src_pkg codename suite_name),
 261                         qw(modified_time src_ver src_pkg_ver),
 262                         qw(bin_ver bin_pkg arch maintainer),
 263                        ],
 264                result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 265                order_by => {-desc => 'me.ver'}
 266               },
 267               );
 268     add_result_to_package($packages,$src_rs,
 269                           \%src_ver_packages,
 270                           \%bin_ver_packages,
 271                           \%src_packages,
 272                           \%bin_packages,
 273                          );
 274     my $bin_rs = $s->resultset('BinVer')->
 275        search({-or => [-and => {'bin_pkg.pkg' => [keys %bin_packages],
 276                                  -or => {'suite.codename' => $common_dists,
 277                                          'suite.suite_name' => $common_dists,
 278                                         },
 279                                 },
 280                         @bin_ver_search,
 281                        ],
 282                },
 283               {join => ['bin_pkg',
 284                        {'src_ver' => [{'src_associations' => 'suite'},
 285                                       'src_pkg',
 286                                       'maintainer',
 287                                      ]},
 288                         'arch',
 289                        ],
 290                'select' => [qw(src_pkg.pkg),
 291                             qw(suite.codename),
 292                             qw(suite.suite_name),
 293                             qw(src_associations.modified),
 294                             qw(src_ver.ver),
 295                             q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
 296                             qw(me.ver bin_pkg.pkg arch.arch),
 297                             qw(maintainer.name),
 298                             ],
 299                'as' => [qw(src_pkg codename suite_name),
 300                         qw(modified_time src_ver src_pkg_ver),
 301                         qw(bin_ver bin_pkg arch maintainer),
 302                        ],
 303                result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 304                order_by => {-desc => 'me.ver'}
 305               },
 306               );
 307     add_result_to_package($packages,$bin_rs,
 308                           \%src_ver_packages,
 309                           \%bin_ver_packages,
 310                           \%src_packages,
 311                           \%bin_packages,
 312                          );
 313     for my $sp (keys %src_ver_packages) {
 314         if (not exists $packages->{'src:'.$sp}) {
 315             $packages->{'src:'.$sp} =
 316                 _default_pkg_info($sp,'source',0);
 317         }
 318         for my $sv (keys %{$src_ver_packages{$sp}}) {
 319             $packages->{'src:'.$sp}{invalid_versions}{$sv} = 1;
 320         }
 321     }
 322     for my $bp (keys %bin_ver_packages) {
 323         if (not exists $packages->{$bp}) {
 324             $packages->{$bp} =
 325                 _default_pkg_info($bp,'binary',0);
 326         }
 327         for my $bv (keys %{$bin_ver_packages{$bp}}) {
 328             $packages->{$bp}{invalid_versions}{$bv} = 1;
 329         }
 330     }
 331     for my $sp (keys %src_packages) {
 332         next if $src_packages{$sp} > 0;
 333         $packages->{'src:'.$sp} =
 334             _default_pkg_info($sp,'source',0);
 335     }
 336     for my $bp (keys %bin_packages) {
 337         next if $bin_packages{$bp} > 0;
 338         $packages->{$bp} =
 339             _default_pkg_info($bp,'binary',0);
 340     }
 341     return $packages;
 342 }
 343
 344 has 'source_version_to_info' =>
 345     (is => 'bare', isa => 'HashRef',
 346      traits => ['Hash'],
 347      lazy => 1,
 348      builder => '_build_source_version_to_info',
 349      handles => {_get_source_version_to_info => 'get',
 350                 },
 351     );
 352
 353 sub _build_source_version_to_info {
 354     my $self = shift;
 355     my $info = {};
 356     my $i = 0;
 357     for my $v ($self->_valid_versioninfo) {
 358         push @{$info->{$v->{src_ver}}}, $i;
 359         $i++;
 360     }
 361     return $info;
 362 }
 363
 364 has 'binary_version_to_info' =>
 365     (is => 'bare', isa => 'HashRef',
 366      traits => ['Hash'],
 367      lazy => 1,
 368      builder => '_build_binary_version_to_info',
 369      handles => {_get_binary_version_to_info => 'get',
 370                 },
 371     );
 372
 373 sub _build_binary_version_to_info {
 374     my $self = shift;
 375     my $info = {};
 376     my $i = 0;
 377     for my $v ($self->_valid_versioninfo) {
 378         push @{$info->{$v->{bin_ver}}}, $i;
 379         $i++;
 380     }
 381     return $info;
 382 }
 383
 384 has 'dist_to_info' =>
 385     (is => 'bare', isa => 'HashRef',
 386      traits => ['Hash'],
 387      lazy => 1,
 388      builder => '_build_dist_to_info',
 389      handles => {_get_dist_to_info => 'get',
 390                 },
 391     );
 392 sub _build_dist_to_info {
 393     my $self = shift;
 394     my $info = {};
 395     my $i = 0;
 396     for my $v ($self->_valid_versioninfo) {
 397         push @{$info->{$v->{dist}}}, $i;
 398         $i++;
 399     }
 400     return $info;
 401 }
 402
 403 # this is a hashref of versions that we know are invalid
 404 has 'invalid_versions' =>
 405     (is => 'bare',isa => 'HashRef[Bool]',
 406      lazy => 1,
 407      default => sub {{}},
 408      clearer => '_clear_invalid_versions',
 409      traits => ['Hash'],
 410      handles => {_invalid_version => 'exists',
 411                  _mark_invalid_version => 'set',
 412                 },
 413     );
 414
 415 has 'binaries' => (is => 'ro',
 416                    isa => 'Debbugs::Collection::Package',
 417                    lazy => 1,
 418                    builder => '_build_binaries',
 419                    predicate => '_has_binaries',
 420                   );
 421
 422 sub _build_binaries {
 423     my $self = shift;
 424     if ($self->is_binary) {
 425         return $self->package_collection->limit($self);
 426     }
 427     # OK, walk through the valid_versions for this package
 428     my @binaries =
 429         uniq map {$_->{bin_pkg}} $self->_valid_versioninfo;
 430     return $self->package_collection->limit(@binaries);
 431 }
 432
 433 has 'sources' => (is => 'ro',
 434                   isa => 'Debbugs::Collection::Package',
 435                   lazy => 1,
 436                   builder => '_build_sources',
 437                   predicate => '_has_sources',
 438                  );
 439
 440 sub _build_sources {
 441     my $self = shift;
 442     if ($self->is_source) {
 443         return $self->package_collection->limit($self);
 444     }
 445     # OK, walk through the valid_versions for this package
 446     my @sources =
 447         uniq map {'src:'.$_->{src_pkg_name}} $self->_valid_versioninfo;
 448     return $self->package_collection->limit(@sources);
 449 }
 450
 451 has 'versions' => (is => 'bare',
 452                    isa => 'HashRef[Debbugs::Version]',
 453                    traits => ['Hash'],
 454                    handles => {_exists_version => 'exists',
 455                                _get_version => 'get',
 456                                _set_version => 'set',
 457                               },
 458                    lazy => 1,
 459                    builder => '_build_versions',
 460                   );
 461
 462 sub _build_versions {
 463     my $self = shift;
 464     return {};
 465 }
 466
 467 sub _add_version {
 468     my $self = shift;
 469     my @set;
 470     for my $v (@_) {
 471         push @set,
 472             $v->version,$v;
 473     }
 474     $self->_set_version(@set);
 475 }
 476
 477 sub get_source_version_distribution {
 478     my $self = shift;
 479
 480     my %src_pkg_vers = @_;
 481     for my $dist (@_) {
 482         my @ver_loc =
 483             grep {defined $_}
 484             $self->_get_dist_to_info($dist);
 485         for my $v ($self->
 486                    _get_valid_versioninfo(@ver_loc)) {
 487             $src_pkg_vers{$v->{src_pkg_ver}} = 1;
 488         }
 489     }
 490     return $self->package_collection->
 491         get_source_versions(keys %src_pkg_vers)->members;
 492 }
 493
 494 # returns the source version(s) corresponding to the version of *this* package; the
 495 # version passed may be binary or source, depending.
 496 sub get_source_version {
 497     my $self = shift;
 498     if ($self->is_source) {
 499         return $self->get_version(@_);
 500     }
 501     my %src_pkg_vers;
 502     for my $ver (@_) {
 503         my %archs;
 504         if (ref $ver) {
 505             my @archs;
 506             ($ver,@archs) = @{$ver};
 507             @archs{@archs} = (1) x @archs;
 508         }
 509         my @ver_loc =
 510             @{$self->_get_binary_version_to_info($ver)//[]};
 511         next unless @ver_loc;
 512         my @vers = map {$self->
 513                             _get_valid_versioninfo($_)}
 514             @ver_loc;
 515         for my $v (@vers) {
 516             if (keys %archs) {
 517                 next unless exists $archs{$v->{arch}};
 518             }
 519             $src_pkg_vers{$v->{src_pkg_ver}} = 1;
 520         }
 521     }
 522     return $self->package_collection->
 523         get_source_versions(keys %src_pkg_vers)->members;
 524 }
 525
 526 sub get_version {
 527     my $self = shift;
 528     my @ret;
 529     for my $v (@_) {
 530         if ($self->_exists_version($v)) {
 531             push @ret,$self->_get_version($v);
 532         } else {
 533             push @ret,
 534                 $self->_create_version($v);
 535         }
 536     }
 537     return @ret;
 538 }
 539
 540 sub _create_version {
 541     my $self = shift;
 542     my @versions;
 543     if ($self->is_source) {
 544         for my $v (@_) {
 545             push @versions,
 546                 $v,
 547                 Debbugs::Version::Source->
 548                     new(package => $self,
 549                         version => $v,
 550                         package_collection => $self->package_collection,
 551                         $self->has_schema?(schema => $self->schema):(),
 552                        );
 553         }
 554     } else {
 555         for my $v (@_) {
 556             push @versions,
 557                 $v,
 558                 Debbugs::Version::Binary->
 559                     new(package => $self,
 560                         version => $v,
 561                         package_collection => $self->package_collection,
 562                         $self->has_schema?(schema => $self->schema):(),
 563                        );
 564         }
 565     }
 566     $self->_set_version(@versions);
 567 }
 568
 569 # gets used to retrieve packages
 570 has 'package_collection' => (is => 'ro',
 571                              isa => 'Debbugs::Collection::Package',
 572                              builder => '_build_package_collection',
 573                              lazy => 1,
 574                             );
 575
 576 sub _build_package_collection {
 577     my $self = shift;
 578     return Debbugs::Collection::Package->new($self->has_schema?(schema => $self->schema):());
 579 }
 580
 581
 582 1;
 583
 584
 585 __END__
 586 # Local Variables:
 587 # indent-tabs-mode: nil
 588 # cperl-indent-level: 4
 589 # End: