lib/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 =head2 name
  37
  38 Name of the Package
  39
  40 =head2 qualified_name
  41
  42 name if binary, name prefixed with C<src:> if source
  43
  44 =cut
  45
  46 has name => (is => 'ro', isa => 'Str',
  47              required => 1,
  48             );
  49
  50 sub qualified_name {
  51     my $self = shift;
  52     return
  53         # src: if source, nothing if binary
  54         ($self->_type eq 'source' ? 'src:':'') .
  55         $self->name;
  56 }
  57
  58
  59 =head2 type
  60
  61 Type of the package; either C<binary> or C<source>
  62
  63 =cut
  64
  65 has type => (is => 'bare', isa => 'Str',
  66              lazy => 1,
  67              builder => '_build_type',
  68              clearer => '_clear_type',
  69              reader => '_type',
  70              writer => '_set_type',
  71             );
  72
  73 sub _build_type {
  74     my $self = shift;
  75     if ($self->name !~ /^src:/) {
  76         return 'binary';
  77     }
  78 }
  79
  80 =head2 url
  81
  82 url to the package
  83
  84 =cut
  85
  86 sub url {
  87     my $self = shift;
  88     return $config{web_domain}.'/'.$self->qualified_name;
  89 }
  90
  91 around BUILDARGS => sub {
  92     my $orig = shift;
  93     my $class = shift;
  94     my %args;
  95     if (@_==1 and ref($_[0]) eq 'HASH') {
  96         %args = %{$_[0]};
  97     } else {
  98         %args = @_;
  99     }
 100     $args{name} //= '(unknown)';
 101     if ($args{name} =~ /src:(.+)/) {
 102         $args{name} = $1;
 103         $args{type} = 'source';
 104     } else {
 105         $args{type} = 'binary' unless
 106             defined $args{type};
 107     }
 108     return $class->$orig(%args);
 109 };
 110
 111 =head2 is_source
 112
 113 true if the package is a source package
 114
 115 =head2 is_binary
 116
 117 true if the package is a binary package
 118
 119 =cut
 120
 121 sub is_source {
 122     return $_[0]->_type eq 'source'
 123 }
 124
 125 sub is_binary {
 126     return $_[0]->_type eq 'binary'
 127 }
 128
 129 =head2 valid -- true if the package has any valid versions
 130
 131 =cut
 132
 133 has valid => (is => 'ro', isa => 'Bool',
 134               lazy => 1,
 135               builder => '_build_valid',
 136               writer => '_set_valid',
 137              );
 138
 139 sub _build_valid {
 140     my $self = shift;
 141     if ($self->valid_version_info_count> 0) {
 142         return 1;
 143     }
 144     return 0;
 145 }
 146
 147 # this contains source name, source version, binary name, binary version, arch,
 148 # and dist which have been selected from the database. It is used to build
 149 # versions and anything else which are known as required.
 150 has 'valid_version_info' =>
 151     (is => 'bare', isa => 'ArrayRef',
 152      traits => ['Array'],
 153      lazy => 1,
 154      builder => '_build_valid_version_info',
 155      predicate => '_has_valid_version_info',
 156      clearer => '_clear_valid_version_info',
 157      handles => {'_get_valid_version_info' => 'get',
 158                  'valid_version_info_grep' => 'grep',
 159                  '_valid_version_info' => 'elements',
 160                  'valid_version_info_count' => 'count',
 161                 },
 162     );
 163
 164 sub _build_valid_version_info {
 165     my $self = shift;
 166     my $pkgs = $self->_get_valid_version_info_from_db;
 167     for my $invalid_version (@{$pkgs->{$self->qualified_name}->{invalid_versions}}) {
 168         $self->_mark_invalid_version($invalid_version,1);
 169     }
 170     return $pkgs->{$self->qualified_name}->{valid_version_info} // [];
 171 }
 172
 173 state $common_dists = [@{$config{distributions}}];
 174 sub _get_valid_version_info_from_db {
 175     my $self;
 176     if ((@_ % 2) == 1 and
 177         blessed($_[0])) {
 178         $self = shift;
 179     }
 180     my %args = @_;
 181     my @packages;
 182     my $s; # schema
 183     if (defined $self) {
 184         if ($self->has_schema) {
 185             $s = $self->schema;
 186         } else {
 187             $s = $args{schema};
 188         }
 189         @packages = $self->qualified_name;
 190     } else {
 191         $s = $args{schema};
 192         @packages = @{$args{packages}};
 193     }
 194     if (not defined $s) {
 195         # FIXME: Implement equivalent loader when there isn't a schema
 196         confess("get_info_from_db not implemented without schema");
 197     }
 198     my %src_packages;
 199     my %src_ver_packages;
 200     my %bin_packages;
 201     my %bin_ver_packages;
 202     # split packages into src/ver, bin/ver, src, and bin so we can select them
 203     # from the database
 204     local $_;
 205     for my $pkg (@packages) {
 206         if (ref($pkg)) {
 207             if ($pkg->[0] =~ /^src:(.+)$/) {
 208                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 209                     $src_ver_packages{$1}{$ver} = 0;
 210                 }
 211             } else {
 212                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 213                     $bin_ver_packages{$pkg->[0]}{$ver} = 0;
 214                 }
 215             }
 216         } elsif ($pkg =~ /^src:(.+)$/) {
 217             $src_packages{$1} = 0;
 218         } else {
 219             $bin_packages{$pkg} = 0;
 220         }
 221     }
 222     # calculate searches for packages where we want specific versions. We
 223     # calculate this here so add_result_to_package can stomp over
 224     # %src_ver_packages and %bin_ver_packages
 225     my @src_ver_search;
 226     for my $sp (keys %src_ver_packages) {
 227         push @src_ver_search,
 228             (-and => {'src_pkg.pkg' => $sp,
 229                       'me.ver' => [keys %{$src_ver_packages{$sp}}],
 230                      },
 231              );
 232     }
 233     my @src_packages = keys %src_packages;
 234
 235     my @bin_ver_search;
 236     for my $sp (keys %bin_ver_packages) {
 237         push @bin_ver_search,
 238             (-and => {'bin_pkg.pkg' => $sp,
 239                       'me.ver' => [keys %{$bin_ver_packages{$sp}}],
 240                      },
 241              );
 242     }
 243     my @bin_packages = keys %bin_packages;
 244     my $packages = {};
 245     sub _default_pkg_info {
 246         return {name => $_[0],
 247                 type => $_[1]//'source',
 248                 valid => $_[2]//1,
 249                 valid_version_info => [],
 250                 invalid_versions => {},
 251                };
 252     }
 253     sub add_result_to_package {
 254         my ($pkgs,$rs,$svp,$bvp,$sp,$bp) = @_;
 255         while (my $pkg = $rs->next) {
 256             my $n = 'src:'.$pkg->{src_pkg};
 257             if (not exists $pkgs->{$n}) {
 258                 $pkgs->{$n} =
 259                     _default_pkg_info($pkg->{src_pkg});
 260             }
 261             push @{$pkgs->{$n}{valid_version_info}},
 262                {%$pkg};
 263             $n = $pkg->{bin_pkg};
 264             if (not exists $pkgs->{$n}) {
 265                 $pkgs->{$n} =
 266                     _default_pkg_info($pkg->{bin_pkg},'binary');
 267             }
 268             push @{$pkgs->{$n}{valid_version_info}},
 269                    {%$pkg};
 270             # this is a package with a valid src_ver
 271             $svp->{$pkg->{src_pkg}}{$pkg->{src_ver}}++;
 272             $sp->{$pkg->{src_pkg}}++;
 273             # this is a package with a valid bin_ver
 274             $bvp->{$pkg->{bin_pkg}}{$pkg->{bin_ver}}++;
 275             $bp->{$pkg->{bin_pkg}}++;
 276         }
 277     }
 278     if (@src_packages) {
 279         my $src_rs = $s->resultset('SrcVer')->
 280             search({-or => [-and => {'src_pkg.pkg' => [@src_packages],
 281                                      -or => {'suite.codename' => $common_dists,
 282                                              'suite.suite_name' => $common_dists,
 283                                             },
 284                                     },
 285                             @src_ver_search,
 286                            ],
 287                    },
 288                   {join => ['src_pkg',
 289                            {
 290                             'src_associations' => 'suite'},
 291                            {
 292                             'bin_vers' => ['bin_pkg','arch']},
 293                             'maintainer',
 294                            ],
 295                    'select' => [qw(src_pkg.pkg),
 296                                 qw(suite.codename),
 297                                 qw(suite.suite_name),
 298                                 qw(src_associations.modified),
 299                                 qw(me.ver),
 300                                 q(CONCAT(src_pkg.pkg,'/',me.ver)),
 301                                 qw(bin_vers.ver bin_pkg.pkg arch.arch),
 302                                 qw(maintainer.name),
 303                                ],
 304                    'as' => [qw(src_pkg codename suite_name),
 305                             qw(modified_time src_ver src_pkg_ver),
 306                             qw(bin_ver bin_pkg arch maintainer),
 307                            ],
 308                    result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 309                   },
 310                   );
 311         add_result_to_package($packages,$src_rs,
 312                               \%src_ver_packages,
 313                               \%bin_ver_packages,
 314                               \%src_packages,
 315                               \%bin_packages,
 316                              );
 317     }
 318     if (@bin_packages) {
 319         my $bin_assoc_rs =
 320             $s->resultset('BinAssociation')->
 321             search({-and => {'bin_pkg.pkg' => [@bin_packages],
 322                              -or => {'suite.codename' => $common_dists,
 323                                      'suite.suite_name' => $common_dists,
 324                                     },
 325                             }},
 326                   {join => [{'bin' =>
 327                              [{'src_ver' => ['src_pkg',
 328                                              'maintainer',
 329                                             ]},
 330                               'bin_pkg',
 331                               'arch']},
 332                             'suite',
 333                            ],
 334                    'select' => [qw(src_pkg.pkg),
 335                                 qw(suite.codename),
 336                                 qw(suite.suite_name),
 337                                 qw(me.modified),
 338                                 qw(src_ver.ver),
 339                                 q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
 340                                 qw(bin.ver bin_pkg.pkg arch.arch),
 341                                 qw(maintainer.name),
 342                                ],
 343                    'as' => [qw(src_pkg codename suite_name),
 344                             qw(modified_time src_ver src_pkg_ver),
 345                             qw(bin_ver bin_pkg arch maintainer),
 346                            ],
 347                    result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 348                   },
 349                   );
 350         add_result_to_package($packages,$bin_assoc_rs,
 351                               \%src_ver_packages,
 352                               \%bin_ver_packages,
 353                               \%src_packages,
 354                               \%bin_packages,
 355                              );
 356     }
 357     if (@bin_ver_search) {
 358         my $bin_rs = $s->resultset('BinVer')->
 359             search({-or => [@bin_ver_search,
 360                            ],
 361                    },
 362                   {join => ['bin_pkg',
 363                            {
 364                             'bin_associations' => 'suite'},
 365                            {'src_ver' => ['src_pkg',
 366                                           'maintainer',
 367                                          ]},
 368                             'arch',
 369                            ],
 370                    'select' => [qw(src_pkg.pkg),
 371                                 qw(suite.codename),
 372                                 qw(suite.suite_name),
 373                                 qw(bin_associations.modified),
 374                                 qw(src_ver.ver),
 375                                 q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
 376                                 qw(me.ver bin_pkg.pkg arch.arch),
 377                                 qw(maintainer.name),
 378                                ],
 379                    'as' => [qw(src_pkg codename suite_name),
 380                             qw(modified_time src_ver src_pkg_ver),
 381                             qw(bin_ver bin_pkg arch maintainer),
 382                            ],
 383                    result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 384                   },
 385                   );
 386         add_result_to_package($packages,$bin_rs,
 387                               \%src_ver_packages,
 388                               \%bin_ver_packages,
 389                               \%src_packages,
 390                               \%bin_packages,
 391                              );
 392     }
 393     for my $sp (keys %src_ver_packages) {
 394         if (not exists $packages->{'src:'.$sp}) {
 395             $packages->{'src:'.$sp} =
 396                 _default_pkg_info($sp,'source',0);
 397         }
 398         for my $sv (keys %{$src_ver_packages{$sp}}) {
 399             next if $src_ver_packages{$sp}{$sv} > 0;
 400             $packages->{'src:'.$sp}{invalid_versions}{$sv} = 1;
 401         }
 402     }
 403     for my $bp (keys %bin_ver_packages) {
 404         if (not exists $packages->{$bp}) {
 405             $packages->{$bp} =
 406                 _default_pkg_info($bp,'binary',0);
 407         }
 408         for my $bv (keys %{$bin_ver_packages{$bp}}) {
 409             next if $bin_ver_packages{$bp}{$bv} > 0;
 410             $packages->{$bp}{invalid_versions}{$bv} = 1;
 411         }
 412     }
 413     for my $sp (keys %src_packages) {
 414         next if $src_packages{$sp} > 0;
 415         $packages->{'src:'.$sp} =
 416             _default_pkg_info($sp,'source',0);
 417     }
 418     for my $bp (keys %bin_packages) {
 419         next if $bin_packages{$bp} > 0;
 420         $packages->{$bp} =
 421             _default_pkg_info($bp,'binary',0);
 422     }
 423     return $packages;
 424 }
 425
 426 has 'source_version_to_info' =>
 427     (is => 'bare', isa => 'HashRef',
 428      traits => ['Hash'],
 429      lazy => 1,
 430      builder => '_build_source_version_to_info',
 431      handles => {_get_source_version_to_info => 'get',
 432                 },
 433     );
 434
 435 sub _build_source_version_to_info {
 436     my $self = shift;
 437     my $info = {};
 438     my $i = 0;
 439     for my $v ($self->_valid_version_info) {
 440         push @{$info->{$v->{src_ver}}}, $i;
 441         $i++;
 442     }
 443     return $info;
 444 }
 445
 446 has 'binary_version_to_info' =>
 447     (is => 'bare', isa => 'HashRef',
 448      traits => ['Hash'],
 449      lazy => 1,
 450      builder => '_build_binary_version_to_info',
 451      handles => {_get_binary_version_to_info => 'get',
 452                 },
 453     );
 454
 455 sub _build_binary_version_to_info {
 456     my $self = shift;
 457     my $info = {};
 458     my $i = 0;
 459     for my $v ($self->_valid_version_info) {
 460         push @{$info->{$v->{bin_ver}}}, $i;
 461         $i++;
 462     }
 463     return $info;
 464 }
 465
 466 has 'dist_to_info' =>
 467     (is => 'bare', isa => 'HashRef',
 468      traits => ['Hash'],
 469      lazy => 1,
 470      builder => '_build_dist_to_info',
 471      handles => {_get_dist_to_info => 'get',
 472                 },
 473     );
 474 sub _build_dist_to_info {
 475     my $self = shift;
 476     my $info = {};
 477     my $i = 0;
 478     for my $v ($self->_valid_version_info) {
 479         next unless defined $v->{suite_name} and length($v->{suite_name});
 480         push @{$info->{$v->{suite_name}}}, $i;
 481         $i++;
 482     }
 483     return $info;
 484 }
 485
 486 # this is a hashref of versions that we know are invalid
 487 has 'invalid_versions' =>
 488     (is => 'bare',isa => 'HashRef[Bool]',
 489      lazy => 1,
 490      default => sub {{}},
 491      clearer => '_clear_invalid_versions',
 492      traits => ['Hash'],
 493      handles => {_invalid_version => 'exists',
 494                  _mark_invalid_version => 'set',
 495                 },
 496     );
 497
 498 has 'binaries' => (is => 'ro',
 499                    isa => 'Debbugs::Collection::Package',
 500                    lazy => 1,
 501                    builder => '_build_binaries',
 502                    predicate => '_has_binaries',
 503                   );
 504
 505 sub _build_binaries {
 506     my $self = shift;
 507     if ($self->is_binary) {
 508         return $self->package_collection->limit($self->name);
 509     }
 510     # OK, walk through the valid_versions for this package
 511     my @binaries =
 512         uniq map {$_->{bin_pkg}} $self->_valid_version_info;
 513     return $self->package_collection->limit(@binaries);
 514 }
 515
 516 has 'sources' => (is => 'ro',
 517                   isa => 'Debbugs::Collection::Package',
 518                   lazy => 1,
 519                   builder => '_build_sources',
 520                   predicate => '_has_sources',
 521                  );
 522
 523 sub _build_sources {
 524     my $self = shift;
 525     return $self->package_collection->limit($self->source_names);
 526 }
 527
 528 sub source_names {
 529     my $self = shift;
 530
 531     if ($self->is_source) {
 532         return $self->name
 533     }
 534     return uniq map {'src:'.$_->{src_pkg}} $self->_valid_version_info;
 535 }
 536
 537 =head2 maintainers
 538
 539 L<Debbugs::Collection::Correspondent> of the maintainer(s) of the current package
 540
 541 =cut
 542
 543 has maintainers => (is => 'ro',
 544                     isa => 'Debbugs::Collection::Correspondent',
 545                     lazy => 1,
 546                     builder => '_build_maintainers',
 547                     predicate => '_has_maintainers',
 548                    );
 549
 550 sub _build_maintainers {
 551     my $self = shift;
 552     my @maintainers;
 553     for my $v ($self->_valid_version_info) {
 554         next unless length($v->{suite_name}) and length($v->{maintainer});
 555         push @maintainers,$v->{maintainer};
 556     }
 557     @maintainers =
 558         uniq @maintainers;
 559     return $self->correspondent_collection->limit(@maintainers);
 560 }
 561
 562 has 'versions' => (is => 'bare',
 563                    isa => 'HashRef[Debbugs::Version]',
 564                    traits => ['Hash'],
 565                    handles => {_exists_version => 'exists',
 566                                _get_version => 'get',
 567                                _set_version => 'set',
 568                               },
 569                    lazy => 1,
 570                    builder => '_build_versions',
 571                   );
 572
 573 sub _build_versions {
 574     my $self = shift;
 575     return {};
 576 }
 577
 578 sub _add_version {
 579     my $self = shift;
 580     my @set;
 581     for my $v (@_) {
 582         push @set,
 583             $v->version,$v;
 584     }
 585     $self->_set_version(@set);
 586 }
 587
 588 sub get_source_version_distribution {
 589     my $self = shift;
 590
 591     my %src_pkg_vers = @_;
 592     for my $dist (@_) {
 593         my @ver_loc =
 594             grep {defined $_}
 595             $self->_get_dist_to_info($dist);
 596         for my $v ($self->
 597                    _get_valid_version_info(@ver_loc)) {
 598             $src_pkg_vers{$v->{src_pkg_ver}} = 1;
 599         }
 600     }
 601     return $self->package_collection->
 602         get_source_versions(keys %src_pkg_vers)->members;
 603 }
 604
 605 # returns the source version(s) corresponding to the version of *this* package; the
 606 # version passed may be binary or source, depending.
 607 sub get_source_version {
 608     my $self = shift;
 609     if ($self->is_source) {
 610         return $self->get_version(@_);
 611     }
 612     my %src_pkg_vers;
 613     for my $ver (@_) {
 614         my %archs;
 615         if (ref $ver) {
 616             my @archs;
 617             ($ver,@archs) = @{$ver};
 618             @archs{@archs} = (1) x @archs;
 619         }
 620         my @ver_loc =
 621             @{$self->_get_binary_version_to_info($ver)//[]};
 622         next unless @ver_loc;
 623         my @vers = map {$self->
 624                             _get_valid_version_info($_)}
 625             @ver_loc;
 626         for my $v (@vers) {
 627             if (keys %archs) {
 628                 next unless exists $archs{$v->{arch}};
 629             }
 630             $src_pkg_vers{$v->{src_pkg_ver}} = 1;
 631         }
 632     }
 633     return $self->package_collection->
 634         get_source_versions(keys %src_pkg_vers)->members;
 635 }
 636
 637 sub get_version {
 638     my $self = shift;
 639     my @ret;
 640     for my $v (@_) {
 641         if ($self->_exists_version($v)) {
 642             push @ret,$self->_get_version($v);
 643         } else {
 644             push @ret,
 645                 $self->_create_version($v);
 646         }
 647     }
 648     return @ret;
 649 }
 650
 651 sub _create_version {
 652     my $self = shift;
 653     my @versions;
 654     if ($self->is_source) {
 655         for my $v (@_) {
 656             push @versions,
 657                 $v,
 658                 Debbugs::Version::Source->
 659                     new(pkg => $self,
 660                         version => $v,
 661                         package_collection => $self->package_collection,
 662                         $self->schema_argument,
 663                        );
 664         }
 665     } else {
 666         for my $v (@_) {
 667             push @versions,
 668                 $v,
 669                 Debbugs::Version::Binary->
 670                     new(pkg => $self,
 671                         version => $v,
 672                         package_collection => $self->package_collection,
 673                         $self->schema_argument,
 674                        );
 675         }
 676     }
 677     $self->_set_version(@versions);
 678 }
 679
 680 =head2 package_collection
 681
 682 L<Debbugs::Collection::Package> to get additional packages required
 683
 684 =cut
 685
 686 # gets used to retrieve packages
 687 has 'package_collection' => (is => 'ro',
 688                              isa => 'Debbugs::Collection::Package',
 689                              builder => '_build_package_collection',
 690                              lazy => 1,
 691                             );
 692
 693 sub _build_package_collection {
 694     my $self = shift;
 695     return Debbugs::Collection::Package->new($self->schema_argument)
 696 }
 697
 698 =head2 correspondent_collection
 699
 700 L<Debbugs::Collection::Correspondent> to get additional maintainers required
 701
 702 =cut
 703
 704 has 'correspondent_collection' => (is => 'ro',
 705                                    isa => 'Debbugs::Collection::Correspondent',
 706                                    builder => '_build_correspondent_collection',
 707                                    lazy => 1,
 708                                   );
 709
 710 sub _build_correspondent_collection {
 711     my $self = shift;
 712     return Debbugs::Collection::Correspondent->new($self->schema_argument)
 713 }
 714
 715 sub CARP_TRACE {
 716     my $self = shift;
 717     return 'Debbugs::Package={package='.$self->qualified_name.'}';
 718 }
 719
 720 __PACKAGE__->meta->make_immutable;
 721 no Mouse;
 722
 723 1;
 724
 725
 726 __END__
 727 # Local Variables:
 728 # indent-tabs-mode: nil
 729 # cperl-indent-level: 4
 730 # End: