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_versioninfo > 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_versioninfo',
 155      predicate => '_has_valid_versioninfo',
 156      clearer => '_clear_valid_versioninfo',
 157      handles => {'_get_valid_versioninfo' => 'get',
 158                  '_grep_valid_versioninfo' => 'grep',
 159                  '_valid_versioninfo' => 'elements',
 160                 },
 161     );
 162
 163 sub _build_valid_versioninfo {
 164     my $self = shift;
 165     my $pkgs = $self->_get_valid_version_info_from_db;
 166     for my $invalid_version (@{$pkgs->{$self->qualified_name}->{invalid_versions}}) {
 167         $self->_mark_invalid_version($invalid_version,1);
 168     }
 169     return $pkgs->{$self->qualified_name}->{valid_version_info} // [];
 170 }
 171
 172 state $common_dists = [@{$config{distributions}}];
 173 sub _get_valid_version_info_from_db {
 174     my $self;
 175     if ((@_ % 2) == 1 and
 176         blessed($_[0])) {
 177         $self = shift;
 178     }
 179     my %args = @_;
 180     my @packages;
 181     my $s; # schema
 182     if (defined $self) {
 183         if ($self->has_schema) {
 184             $s = $self->schema;
 185         } else {
 186             $s = $args{schema};
 187         }
 188         @packages = $self->qualified_name;
 189     } else {
 190         $s = $args{schema};
 191         @packages = @{$args{packages}};
 192     }
 193     if (not defined $s) {
 194         confess("get_info_from_db not implemented without schema");
 195     }
 196     my %src_packages;
 197     my %src_ver_packages;
 198     my %bin_packages;
 199     my %bin_ver_packages;
 200     # split packages into src/ver, bin/ver, src, and bin so we can select them
 201     # from the database
 202     local $_;
 203     for my $pkg (@packages) {
 204         if (ref($pkg)) {
 205             if ($pkg->[0] =~ /^src:(.+)$/) {
 206                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 207                     $src_ver_packages{$1}{$ver} = 0;
 208                 }
 209             } else {
 210                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 211                     $bin_ver_packages{$pkg->[0]}{$ver} = 0;
 212                 }
 213             }
 214         } elsif ($pkg =~ /^src:(.+)$/) {
 215             $src_packages{$1} = 0;
 216         } else {
 217             $bin_packages{$pkg} = 0;
 218         }
 219     }
 220     # calculate searches for packages where we want specific versions. We
 221     # calculate this here so add_result_to_package can stomp over
 222     # %src_ver_packages and %bin_ver_packages
 223     my @src_ver_search;
 224     for my $sp (keys %src_ver_packages) {
 225         push @src_ver_search,
 226             (-and => {'src_pkg.pkg' => $sp,
 227                       'me.ver' => [keys %{$src_ver_packages{$sp}}],
 228                      },
 229              );
 230     }
 231
 232     my @bin_ver_search;
 233     for my $sp (keys %bin_ver_packages) {
 234         push @bin_ver_search,
 235             (-and => {'bin_pkg.pkg' => $sp,
 236                       'me.ver' => [keys %{$bin_ver_packages{$sp}}],
 237                      },
 238              );
 239     }
 240     my $packages = {};
 241     sub _default_pkg_info {
 242         return {name => $_[0],
 243                 type => $_[1]//'source',
 244                 valid => $_[2]//1,
 245                 valid_version_info => [],
 246                 invalid_versions => {},
 247                };
 248     }
 249     sub add_result_to_package {
 250         my ($pkgs,$rs,$svp,$bvp,$sp,$bp) = @_;
 251         while (my $pkg = $rs->next) {
 252             my $n = 'src:'.$pkg->{src_pkg};
 253             if (not exists $pkgs->{$n}) {
 254                 $pkgs->{$n} =
 255                     _default_pkg_info($pkg->{src_pkg});
 256             }
 257             push @{$pkgs->{$n}{valid_version_info}},
 258                {%$pkg};
 259             $n = $pkg->{bin_pkg};
 260             if (not exists $pkgs->{$n}) {
 261                 $pkgs->{$n} =
 262                     _default_pkg_info($pkg->{bin_pkg},'binary');
 263             }
 264             push @{$pkgs->{$n}{valid_version_info}},
 265                    {%$pkg};
 266             # this is a package with a valid src_ver
 267             $svp->{$pkg->{src_pkg}}{$pkg->{src_ver}}++;
 268             $sp->{$pkg->{src_pkg}}++;
 269             # this is a package with a valid bin_ver
 270             $bvp->{$pkg->{bin_pkg}}{$pkg->{bin_ver}}++;
 271             $bp->{$pkg->{bin_pkg}}++;
 272         }
 273     }
 274     if (keys %src_packages) {
 275         my $src_rs = $s->resultset('SrcVer')->
 276             search({-or => [-and => {'src_pkg.pkg' => [keys %src_packages],
 277                                      -or => {'suite.codename' => $common_dists,
 278                                              'suite.suite_name' => $common_dists,
 279                                             },
 280                                     },
 281                             @src_ver_search,
 282                            ],
 283                    },
 284                   {join => ['src_pkg',
 285                            {
 286                             'src_associations' => 'suite'},
 287                            {
 288                             'bin_vers' => ['bin_pkg','arch']},
 289                             'maintainer',
 290                            ],
 291                    'select' => [qw(src_pkg.pkg),
 292                                 qw(suite.codename),
 293                                 qw(suite.suite_name),
 294                                 qw(src_associations.modified),
 295                                 qw(me.ver),
 296                                 q(CONCAT(src_pkg.pkg,'/',me.ver)),
 297                                 qw(bin_vers.ver bin_pkg.pkg arch.arch),
 298                                 qw(maintainer.name),
 299                                ],
 300                    'as' => [qw(src_pkg codename suite_name),
 301                             qw(modified_time src_ver src_pkg_ver),
 302                             qw(bin_ver bin_pkg arch maintainer),
 303                            ],
 304                    result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 305                   },
 306                   );
 307         add_result_to_package($packages,$src_rs,
 308                               \%src_ver_packages,
 309                               \%bin_ver_packages,
 310                               \%src_packages,
 311                               \%bin_packages,
 312                              );
 313     }
 314     if (keys %bin_packages) {
 315         my $bin_assoc_rs =
 316             $s->resultset('BinAssociation')->
 317             search({-and => {'bin_pkg.pkg' => [keys %bin_packages],
 318                              -or => {'suite.codename' => $common_dists,
 319                                      'suite.suite_name' => $common_dists,
 320                                     },
 321                             }},
 322                   {join => [{'bin' =>
 323                              [{'src_ver' => ['src_pkg',
 324                                              'maintainer',
 325                                             ]},
 326                               'bin_pkg',
 327                               'arch']},
 328                             'suite',
 329                            ],
 330                    'select' => [qw(src_pkg.pkg),
 331                                 qw(suite.codename),
 332                                 qw(suite.suite_name),
 333                                 qw(me.modified),
 334                                 qw(src_ver.ver),
 335                                 q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
 336                                 qw(bin.ver bin_pkg.pkg arch.arch),
 337                                 qw(maintainer.name),
 338                                ],
 339                    'as' => [qw(src_pkg codename suite_name),
 340                             qw(modified_time src_ver src_pkg_ver),
 341                             qw(bin_ver bin_pkg arch maintainer),
 342                            ],
 343                    result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 344                   },
 345                   );
 346         add_result_to_package($packages,$bin_assoc_rs,
 347                               \%src_ver_packages,
 348                               \%bin_ver_packages,
 349                               \%src_packages,
 350                               \%bin_packages,
 351                              );
 352     }
 353     if (@bin_ver_search) {
 354         my $bin_rs = $s->resultset('BinVer')->
 355             search({-or => [@bin_ver_search,
 356                            ],
 357                    },
 358                   {join => ['bin_pkg',
 359                            {
 360                             'bin_associations' => 'suite'},
 361                            {'src_ver' => ['src_pkg',
 362                                           'maintainer',
 363                                          ]},
 364                             'arch',
 365                            ],
 366                    'select' => [qw(src_pkg.pkg),
 367                                 qw(suite.codename),
 368                                 qw(suite.suite_name),
 369                                 qw(bin_associations.modified),
 370                                 qw(src_ver.ver),
 371                                 q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
 372                                 qw(me.ver bin_pkg.pkg arch.arch),
 373                                 qw(maintainer.name),
 374                                ],
 375                    'as' => [qw(src_pkg codename suite_name),
 376                             qw(modified_time src_ver src_pkg_ver),
 377                             qw(bin_ver bin_pkg arch maintainer),
 378                            ],
 379                    result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 380                   },
 381                   );
 382         add_result_to_package($packages,$bin_rs,
 383                               \%src_ver_packages,
 384                               \%bin_ver_packages,
 385                               \%src_packages,
 386                               \%bin_packages,
 387                              );
 388     }
 389     for my $sp (keys %src_ver_packages) {
 390         if (not exists $packages->{'src:'.$sp}) {
 391             $packages->{'src:'.$sp} =
 392                 _default_pkg_info($sp,'source',0);
 393         }
 394         for my $sv (keys %{$src_ver_packages{$sp}}) {
 395             next if $src_ver_packages{$sp}{$sv} > 0;
 396             $packages->{'src:'.$sp}{invalid_versions}{$sv} = 1;
 397         }
 398     }
 399     for my $bp (keys %bin_ver_packages) {
 400         if (not exists $packages->{$bp}) {
 401             $packages->{$bp} =
 402                 _default_pkg_info($bp,'binary',0);
 403         }
 404         for my $bv (keys %{$bin_ver_packages{$bp}}) {
 405             next if $bin_ver_packages{$bp}{$bv} > 0;
 406             $packages->{$bp}{invalid_versions}{$bv} = 1;
 407         }
 408     }
 409     for my $sp (keys %src_packages) {
 410         next if $src_packages{$sp} > 0;
 411         $packages->{'src:'.$sp} =
 412             _default_pkg_info($sp,'source',0);
 413     }
 414     for my $bp (keys %bin_packages) {
 415         next if $bin_packages{$bp} > 0;
 416         $packages->{$bp} =
 417             _default_pkg_info($bp,'binary',0);
 418     }
 419     return $packages;
 420 }
 421
 422 has 'source_version_to_info' =>
 423     (is => 'bare', isa => 'HashRef',
 424      traits => ['Hash'],
 425      lazy => 1,
 426      builder => '_build_source_version_to_info',
 427      handles => {_get_source_version_to_info => 'get',
 428                 },
 429     );
 430
 431 sub _build_source_version_to_info {
 432     my $self = shift;
 433     my $info = {};
 434     my $i = 0;
 435     for my $v ($self->_valid_versioninfo) {
 436         push @{$info->{$v->{src_ver}}}, $i;
 437         $i++;
 438     }
 439     return $info;
 440 }
 441
 442 has 'binary_version_to_info' =>
 443     (is => 'bare', isa => 'HashRef',
 444      traits => ['Hash'],
 445      lazy => 1,
 446      builder => '_build_binary_version_to_info',
 447      handles => {_get_binary_version_to_info => 'get',
 448                 },
 449     );
 450
 451 sub _build_binary_version_to_info {
 452     my $self = shift;
 453     my $info = {};
 454     my $i = 0;
 455     for my $v ($self->_valid_versioninfo) {
 456         push @{$info->{$v->{bin_ver}}}, $i;
 457         $i++;
 458     }
 459     return $info;
 460 }
 461
 462 has 'dist_to_info' =>
 463     (is => 'bare', isa => 'HashRef',
 464      traits => ['Hash'],
 465      lazy => 1,
 466      builder => '_build_dist_to_info',
 467      handles => {_get_dist_to_info => 'get',
 468                 },
 469     );
 470 sub _build_dist_to_info {
 471     my $self = shift;
 472     my $info = {};
 473     my $i = 0;
 474     for my $v ($self->_valid_versioninfo) {
 475         push @{$info->{$v->{dist}}}, $i;
 476         $i++;
 477     }
 478     return $info;
 479 }
 480
 481 # this is a hashref of versions that we know are invalid
 482 has 'invalid_versions' =>
 483     (is => 'bare',isa => 'HashRef[Bool]',
 484      lazy => 1,
 485      default => sub {{}},
 486      clearer => '_clear_invalid_versions',
 487      traits => ['Hash'],
 488      handles => {_invalid_version => 'exists',
 489                  _mark_invalid_version => 'set',
 490                 },
 491     );
 492
 493 has 'binaries' => (is => 'ro',
 494                    isa => 'Debbugs::Collection::Package',
 495                    lazy => 1,
 496                    builder => '_build_binaries',
 497                    predicate => '_has_binaries',
 498                   );
 499
 500 sub _build_binaries {
 501     my $self = shift;
 502     if ($self->is_binary) {
 503         return $self->package_collection->limit($self);
 504     }
 505     # OK, walk through the valid_versions for this package
 506     my @binaries =
 507         uniq map {$_->{bin_pkg}} $self->_valid_versioninfo;
 508     return $self->package_collection->limit(@binaries);
 509 }
 510
 511 has 'sources' => (is => 'ro',
 512                   isa => 'Debbugs::Collection::Package',
 513                   lazy => 1,
 514                   builder => '_build_sources',
 515                   predicate => '_has_sources',
 516                  );
 517
 518 sub _build_sources {
 519     my $self = shift;
 520     if ($self->is_source) {
 521         return $self->package_collection->limit($self);
 522     }
 523     # OK, walk through the valid_versions for this package
 524     my @sources =
 525         uniq map {'src:'.$_->{src_pkg_name}} $self->_valid_versioninfo;
 526     return $self->package_collection->limit(@sources);
 527 }
 528
 529 has 'versions' => (is => 'bare',
 530                    isa => 'HashRef[Debbugs::Version]',
 531                    traits => ['Hash'],
 532                    handles => {_exists_version => 'exists',
 533                                _get_version => 'get',
 534                                _set_version => 'set',
 535                               },
 536                    lazy => 1,
 537                    builder => '_build_versions',
 538                   );
 539
 540 sub _build_versions {
 541     my $self = shift;
 542     return {};
 543 }
 544
 545 sub _add_version {
 546     my $self = shift;
 547     my @set;
 548     for my $v (@_) {
 549         push @set,
 550             $v->version,$v;
 551     }
 552     $self->_set_version(@set);
 553 }
 554
 555 sub get_source_version_distribution {
 556     my $self = shift;
 557
 558     my %src_pkg_vers = @_;
 559     for my $dist (@_) {
 560         my @ver_loc =
 561             grep {defined $_}
 562             $self->_get_dist_to_info($dist);
 563         for my $v ($self->
 564                    _get_valid_versioninfo(@ver_loc)) {
 565             $src_pkg_vers{$v->{src_pkg_ver}} = 1;
 566         }
 567     }
 568     return $self->package_collection->
 569         get_source_versions(keys %src_pkg_vers)->members;
 570 }
 571
 572 # returns the source version(s) corresponding to the version of *this* package; the
 573 # version passed may be binary or source, depending.
 574 sub get_source_version {
 575     my $self = shift;
 576     if ($self->is_source) {
 577         return $self->get_version(@_);
 578     }
 579     my %src_pkg_vers;
 580     for my $ver (@_) {
 581         my %archs;
 582         if (ref $ver) {
 583             my @archs;
 584             ($ver,@archs) = @{$ver};
 585             @archs{@archs} = (1) x @archs;
 586         }
 587         my @ver_loc =
 588             @{$self->_get_binary_version_to_info($ver)//[]};
 589         next unless @ver_loc;
 590         my @vers = map {$self->
 591                             _get_valid_versioninfo($_)}
 592             @ver_loc;
 593         for my $v (@vers) {
 594             if (keys %archs) {
 595                 next unless exists $archs{$v->{arch}};
 596             }
 597             $src_pkg_vers{$v->{src_pkg_ver}} = 1;
 598         }
 599     }
 600     return $self->package_collection->
 601         get_source_versions(keys %src_pkg_vers)->members;
 602 }
 603
 604 sub get_version {
 605     my $self = shift;
 606     my @ret;
 607     for my $v (@_) {
 608         if ($self->_exists_version($v)) {
 609             push @ret,$self->_get_version($v);
 610         } else {
 611             push @ret,
 612                 $self->_create_version($v);
 613         }
 614     }
 615     return @ret;
 616 }
 617
 618 sub _create_version {
 619     my $self = shift;
 620     my @versions;
 621     if ($self->is_source) {
 622         for my $v (@_) {
 623             push @versions,
 624                 $v,
 625                 Debbugs::Version::Source->
 626                     new(package => $self,
 627                         version => $v,
 628                         package_collection => $self->package_collection,
 629                         $self->schema_argument,
 630                        );
 631         }
 632     } else {
 633         for my $v (@_) {
 634             push @versions,
 635                 $v,
 636                 Debbugs::Version::Binary->
 637                     new(package => $self,
 638                         version => $v,
 639                         package_collection => $self->package_collection,
 640                         $self->schema_argument,
 641                        );
 642         }
 643     }
 644     $self->_set_version(@versions);
 645 }
 646
 647 =head2 package_collection
 648
 649 L<Debbugs::Collection::Package> to get additional packages required
 650
 651 =cut
 652
 653 # gets used to retrieve packages
 654 has 'package_collection' => (is => 'ro',
 655                              isa => 'Debbugs::Collection::Package',
 656                              builder => '_build_package_collection',
 657                              lazy => 1,
 658                             );
 659
 660 sub _build_package_collection {
 661     my $self = shift;
 662     return Debbugs::Collection::Package->new($self->schema_argument)
 663 }
 664
 665 sub CARP_TRACE {
 666     my $self = shift;
 667     return 'Debbugs::Package={package='.$self->qualified_name.'}';
 668 }
 669
 670 __PACKAGE__->meta->make_immutable;
 671 no Mouse;
 672
 673 1;
 674
 675
 676 __END__
 677 # Local Variables:
 678 # indent-tabs-mode: nil
 679 # cperl-indent-level: 4
 680 # End: