]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/Package.pm
Documentation of Debbugs::Package
[debbugs.git] / 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: