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               },
 266               );
 267     add_result_to_package($packages,$src_rs,
 268                           \%src_ver_packages,
 269                           \%bin_ver_packages,
 270                           \%src_packages,
 271                           \%bin_packages,
 272                          );
 273     my $bin_assoc_rs =
 274         $s->resultset('BinAssociation')->
 275         search({-and => {'bin_pkg.pkg' => [keys %bin_packages],
 276                          -or => {'suite.codename' => $common_dists,
 277                                  'suite.suite_name' => $common_dists,
 278                                 },
 279                         }},
 280                {join => [{'bin' =>
 281                          [{'src_ver' => ['src_pkg',
 282                                         'maintainer',
 283                                        ]},
 284                           'bin_pkg',
 285                           'arch']},
 286                          'suite',
 287                       ],
 288               'select' => [qw(src_pkg.pkg),
 289                             qw(suite.codename),
 290                             qw(suite.suite_name),
 291                             qw(me.modified),
 292                             qw(src_ver.ver),
 293                             q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
 294                             qw(bin.ver bin_pkg.pkg arch.arch),
 295                             qw(maintainer.name),
 296                             ],
 297                'as' => [qw(src_pkg codename suite_name),
 298                         qw(modified_time src_ver src_pkg_ver),
 299                         qw(bin_ver bin_pkg arch maintainer),
 300                        ],
 301                result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 302               },
 303               );
 304     add_result_to_package($packages,$bin_assoc_rs,
 305                           \%src_ver_packages,
 306                           \%bin_ver_packages,
 307                           \%src_packages,
 308                           \%bin_packages,
 309                          );
 310     my $bin_rs = $s->resultset('BinVer')->
 311         search({-or => [@bin_ver_search,
 312                        ],
 313                },
 314              {join => ['bin_pkg',
 315                       {'bin_associations' => 'suite'},
 316                       {'src_ver' => ['src_pkg',
 317                                      'maintainer',
 318                                     ]},
 319                        'arch',
 320                       ],
 321               'select' => [qw(src_pkg.pkg),
 322                             qw(suite.codename),
 323                             qw(suite.suite_name),
 324                             qw(bin_associations.modified),
 325                             qw(src_ver.ver),
 326                             q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
 327                             qw(me.ver bin_pkg.pkg arch.arch),
 328                             qw(maintainer.name),
 329                             ],
 330                'as' => [qw(src_pkg codename suite_name),
 331                         qw(modified_time src_ver src_pkg_ver),
 332                         qw(bin_ver bin_pkg arch maintainer),
 333                        ],
 334                result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 335               },
 336               );
 337     add_result_to_package($packages,$bin_rs,
 338                           \%src_ver_packages,
 339                           \%bin_ver_packages,
 340                           \%src_packages,
 341                           \%bin_packages,
 342                          );
 343     for my $sp (keys %src_ver_packages) {
 344         if (not exists $packages->{'src:'.$sp}) {
 345             $packages->{'src:'.$sp} =
 346                 _default_pkg_info($sp,'source',0);
 347         }
 348         for my $sv (keys %{$src_ver_packages{$sp}}) {
 349             $packages->{'src:'.$sp}{invalid_versions}{$sv} = 1;
 350         }
 351     }
 352     for my $bp (keys %bin_ver_packages) {
 353         if (not exists $packages->{$bp}) {
 354             $packages->{$bp} =
 355                 _default_pkg_info($bp,'binary',0);
 356         }
 357         for my $bv (keys %{$bin_ver_packages{$bp}}) {
 358             $packages->{$bp}{invalid_versions}{$bv} = 1;
 359         }
 360     }
 361     for my $sp (keys %src_packages) {
 362         next if $src_packages{$sp} > 0;
 363         $packages->{'src:'.$sp} =
 364             _default_pkg_info($sp,'source',0);
 365     }
 366     for my $bp (keys %bin_packages) {
 367         next if $bin_packages{$bp} > 0;
 368         $packages->{$bp} =
 369             _default_pkg_info($bp,'binary',0);
 370     }
 371     return $packages;
 372 }
 373
 374 has 'source_version_to_info' =>
 375     (is => 'bare', isa => 'HashRef',
 376      traits => ['Hash'],
 377      lazy => 1,
 378      builder => '_build_source_version_to_info',
 379      handles => {_get_source_version_to_info => 'get',
 380                 },
 381     );
 382
 383 sub _build_source_version_to_info {
 384     my $self = shift;
 385     my $info = {};
 386     my $i = 0;
 387     for my $v ($self->_valid_versioninfo) {
 388         push @{$info->{$v->{src_ver}}}, $i;
 389         $i++;
 390     }
 391     return $info;
 392 }
 393
 394 has 'binary_version_to_info' =>
 395     (is => 'bare', isa => 'HashRef',
 396      traits => ['Hash'],
 397      lazy => 1,
 398      builder => '_build_binary_version_to_info',
 399      handles => {_get_binary_version_to_info => 'get',
 400                 },
 401     );
 402
 403 sub _build_binary_version_to_info {
 404     my $self = shift;
 405     my $info = {};
 406     my $i = 0;
 407     for my $v ($self->_valid_versioninfo) {
 408         push @{$info->{$v->{bin_ver}}}, $i;
 409         $i++;
 410     }
 411     return $info;
 412 }
 413
 414 has 'dist_to_info' =>
 415     (is => 'bare', isa => 'HashRef',
 416      traits => ['Hash'],
 417      lazy => 1,
 418      builder => '_build_dist_to_info',
 419      handles => {_get_dist_to_info => 'get',
 420                 },
 421     );
 422 sub _build_dist_to_info {
 423     my $self = shift;
 424     my $info = {};
 425     my $i = 0;
 426     for my $v ($self->_valid_versioninfo) {
 427         push @{$info->{$v->{dist}}}, $i;
 428         $i++;
 429     }
 430     return $info;
 431 }
 432
 433 # this is a hashref of versions that we know are invalid
 434 has 'invalid_versions' =>
 435     (is => 'bare',isa => 'HashRef[Bool]',
 436      lazy => 1,
 437      default => sub {{}},
 438      clearer => '_clear_invalid_versions',
 439      traits => ['Hash'],
 440      handles => {_invalid_version => 'exists',
 441                  _mark_invalid_version => 'set',
 442                 },
 443     );
 444
 445 has 'binaries' => (is => 'ro',
 446                    isa => 'Debbugs::Collection::Package',
 447                    lazy => 1,
 448                    builder => '_build_binaries',
 449                    predicate => '_has_binaries',
 450                   );
 451
 452 sub _build_binaries {
 453     my $self = shift;
 454     if ($self->is_binary) {
 455         return $self->package_collection->limit($self);
 456     }
 457     # OK, walk through the valid_versions for this package
 458     my @binaries =
 459         uniq map {$_->{bin_pkg}} $self->_valid_versioninfo;
 460     return $self->package_collection->limit(@binaries);
 461 }
 462
 463 has 'sources' => (is => 'ro',
 464                   isa => 'Debbugs::Collection::Package',
 465                   lazy => 1,
 466                   builder => '_build_sources',
 467                   predicate => '_has_sources',
 468                  );
 469
 470 sub _build_sources {
 471     my $self = shift;
 472     if ($self->is_source) {
 473         return $self->package_collection->limit($self);
 474     }
 475     # OK, walk through the valid_versions for this package
 476     my @sources =
 477         uniq map {'src:'.$_->{src_pkg_name}} $self->_valid_versioninfo;
 478     return $self->package_collection->limit(@sources);
 479 }
 480
 481 has 'versions' => (is => 'bare',
 482                    isa => 'HashRef[Debbugs::Version]',
 483                    traits => ['Hash'],
 484                    handles => {_exists_version => 'exists',
 485                                _get_version => 'get',
 486                                _set_version => 'set',
 487                               },
 488                    lazy => 1,
 489                    builder => '_build_versions',
 490                   );
 491
 492 sub _build_versions {
 493     my $self = shift;
 494     return {};
 495 }
 496
 497 sub _add_version {
 498     my $self = shift;
 499     my @set;
 500     for my $v (@_) {
 501         push @set,
 502             $v->version,$v;
 503     }
 504     $self->_set_version(@set);
 505 }
 506
 507 sub get_source_version_distribution {
 508     my $self = shift;
 509
 510     my %src_pkg_vers = @_;
 511     for my $dist (@_) {
 512         my @ver_loc =
 513             grep {defined $_}
 514             $self->_get_dist_to_info($dist);
 515         for my $v ($self->
 516                    _get_valid_versioninfo(@ver_loc)) {
 517             $src_pkg_vers{$v->{src_pkg_ver}} = 1;
 518         }
 519     }
 520     return $self->package_collection->
 521         get_source_versions(keys %src_pkg_vers)->members;
 522 }
 523
 524 # returns the source version(s) corresponding to the version of *this* package; the
 525 # version passed may be binary or source, depending.
 526 sub get_source_version {
 527     my $self = shift;
 528     if ($self->is_source) {
 529         return $self->get_version(@_);
 530     }
 531     my %src_pkg_vers;
 532     for my $ver (@_) {
 533         my %archs;
 534         if (ref $ver) {
 535             my @archs;
 536             ($ver,@archs) = @{$ver};
 537             @archs{@archs} = (1) x @archs;
 538         }
 539         my @ver_loc =
 540             @{$self->_get_binary_version_to_info($ver)//[]};
 541         next unless @ver_loc;
 542         my @vers = map {$self->
 543                             _get_valid_versioninfo($_)}
 544             @ver_loc;
 545         for my $v (@vers) {
 546             if (keys %archs) {
 547                 next unless exists $archs{$v->{arch}};
 548             }
 549             $src_pkg_vers{$v->{src_pkg_ver}} = 1;
 550         }
 551     }
 552     return $self->package_collection->
 553         get_source_versions(keys %src_pkg_vers)->members;
 554 }
 555
 556 sub get_version {
 557     my $self = shift;
 558     my @ret;
 559     for my $v (@_) {
 560         if ($self->_exists_version($v)) {
 561             push @ret,$self->_get_version($v);
 562         } else {
 563             push @ret,
 564                 $self->_create_version($v);
 565         }
 566     }
 567     return @ret;
 568 }
 569
 570 sub _create_version {
 571     my $self = shift;
 572     my @versions;
 573     if ($self->is_source) {
 574         for my $v (@_) {
 575             push @versions,
 576                 $v,
 577                 Debbugs::Version::Source->
 578                     new(package => $self,
 579                         version => $v,
 580                         package_collection => $self->package_collection,
 581                         $self->schema_argument,
 582                        );
 583         }
 584     } else {
 585         for my $v (@_) {
 586             push @versions,
 587                 $v,
 588                 Debbugs::Version::Binary->
 589                     new(package => $self,
 590                         version => $v,
 591                         package_collection => $self->package_collection,
 592                         $self->schema_argument,
 593                        );
 594         }
 595     }
 596     $self->_set_version(@versions);
 597 }
 598
 599 # gets used to retrieve packages
 600 has 'package_collection' => (is => 'ro',
 601                              isa => 'Debbugs::Collection::Package',
 602                              builder => '_build_package_collection',
 603                              lazy => 1,
 604                             );
 605
 606 sub _build_package_collection {
 607     my $self = shift;
 608     return Debbugs::Collection::Package->new($self->schema_argument)
 609 }
 610
 611 sub CARP_TRACE {
 612     my $self = shift;
 613     return 'Debbugs::Package={package='.$self->qualified_name.'}';
 614 }
 615
 616 __PACKAGE__->meta->make_immutable;
 617 no Mouse;
 618
 619 1;
 620
 621
 622 __END__
 623 # Local Variables:
 624 # indent-tabs-mode: nil
 625 # cperl-indent-level: 4
 626 # End: