Debbugs/Bug/Status.pm

   1 # This module is part of debbugs, and
   2 # is released under the terms of the GPL version 2, 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::Bug::Status;
   8
   9 =head1 NAME
  10
  11 Debbugs::Bug::Status -- OO interface to status files
  12
  13 =head1 SYNOPSIS
  14
  15    use Debbugs::Bug;
  16    Debbugs::Bug->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 namespace::clean;
  27 use v5.10; # for state
  28 use Mouse::Util::TypeConstraints qw(enum);
  29
  30 use DateTime;
  31 use List::AllUtils qw(max first min);
  32
  33 use Params::Validate qw(validate_with :types);
  34 use Debbugs::Common qw(make_list);
  35 use Debbugs::Config qw(:config);
  36 use Debbugs::Status qw(get_bug_status);
  37
  38 use Debbugs::OOTypes;
  39
  40 use Carp;
  41
  42 extends 'Debbugs::OOBase';
  43
  44 my $meta = __PACKAGE__->meta;
  45
  46 has bug => (is => 'ro', isa => 'Int',
  47            );
  48
  49 # status obtained from DB, filesystem, or hashref
  50 has status_source => (is => 'ro',
  51                       isa => enum([qw(db filesystem hashref)]),
  52                       default => 'filesystem',
  53                       writer => '_set_status_source',
  54                      );
  55
  56 sub BUILD {
  57     my $self = shift;
  58     my $args = shift;
  59     if (not exists $args->{status} and exists $args->{bug}) {
  60         if ($self->has_schema) {
  61             ($args->{status}) =
  62                 $self->schema->resultset('BugStatus')->
  63                 search_rs({id => [make_list($args->{bug})]},
  64                          {result_class => 'DBIx::Class::ResultClass::HashRefInflator'})->
  65                              all();
  66             state $field_mapping =
  67                {originator => 'submitter',
  68                 blockedby => 'blocked_by',
  69                 found_versions => 'found',
  70                 fixed_versions => 'fixed',
  71                };
  72             for my $field (keys %{$field_mapping}) {
  73                 $args->{status}{$field_mapping->{$field}} =
  74                     $args->{status}{$field} if defined $args->{status}{$field};
  75                 delete $args->{status}{$field};
  76             }
  77             $self->_set_status_source('db');
  78         } else {
  79             $args->{status} = get_bug_status(bug=>$args->{bug});
  80             state $field_mapping =
  81                {originator => 'submitter',
  82                 keywords => 'tags',
  83                 msgid => 'message_id',
  84                 blockedby => 'blocked_by',
  85                 found_versions => 'found',
  86                 fixed_versions => 'fixed',
  87                };
  88             for my $field (keys %{$field_mapping}) {
  89                 $args->{status}{$field_mapping->{$field}} =
  90                     $args->{status}{$field};
  91             }
  92             $self->_set_status_source('filesystem');
  93         }
  94     } elsif (exists $args->{status}) {
  95         $self->_set_status_source('hashref');
  96     }
  97     if (exists $args->{status}) {
  98         if (ref($args->{status}) ne 'HASH') {
  99             croak "status must be a HASHREF (argument to __PACKAGE__)";
 100         }
 101         # single value fields
 102         for my $field (qw(submitter date subject message_id done severity unarchived),
 103                        qw(owner summary outlook bug log_modified),
 104                        qw(last_modified archived forwarded)) {
 105             next unless defined $args->{status}{$field};
 106             # we're going to let status override passed values in args for now;
 107             # maybe this should change
 108             my $field_method = $meta->find_method_by_name('_set_'.$field);
 109             if (not defined $field_method) {
 110                 croak "Unable to find field method for _set_$field";
 111             }
 112             $field_method->($self,$args->{status}{$field});
 113         }
 114         # multi value fields
 115         for my $field (qw(affects package tags blocks blocked_by mergedwith),
 116                        qw(found fixed)) {
 117             next unless defined $args->{status}{$field};
 118             my $field_method = $meta->find_method_by_name('_set_'.$field);
 119             my $split_field = $args->{status}{$field};
 120             if (!ref($split_field)) {
 121                 $split_field =
 122                     _build_split_field($args->{status}{$field},
 123                                        $field);
 124             }
 125             $field_method->($self,
 126                             $split_field,
 127                             );
 128         }
 129         delete $args->{status};
 130     }
 131 }
 132
 133 has saved => (is => 'ro', isa => 'Bool',
 134               default => 0,
 135               writer => '_set_set_saved',
 136              );
 137
 138 =head2 Status Fields
 139
 140 =cut
 141
 142 =head3 Single-value Fields
 143
 144 =over
 145
 146 =item submitter (single)
 147
 148 =cut
 149
 150 has submitter =>
 151     (is => 'ro',
 152      isa => 'Str',
 153      default => $config{maintainer_email},
 154      writer => '_set_submitter',
 155     );
 156
 157 =item date (single)
 158
 159 =cut
 160
 161 has date =>
 162     (is => 'ro',
 163      isa => 'Str',
 164      builder => sub {return time},
 165      lazy => 1,
 166      writer => '_set_date',
 167     );
 168
 169 =item last_modified (single)
 170
 171 =cut
 172
 173 has last_modified =>
 174     (is => 'ro',
 175      isa => 'Str',
 176      builder => sub {return time},
 177      lazy => 1,
 178      writer => '_set_last_modified',
 179     );
 180
 181 =item log_modified (single)
 182
 183 =cut
 184
 185 has log_modified =>
 186     (is => 'ro',
 187      isa => 'Str',
 188      builder => sub {return time},
 189      lazy => 1,
 190      writer => '_set_log_modified',
 191     );
 192
 193
 194 =item subject
 195
 196 =cut
 197
 198 has subject =>
 199     (is => 'ro',
 200      isa => 'Str',
 201      default => 'No subject',
 202      writer => '_set_subject',
 203     );
 204
 205 =item message_id
 206
 207 =cut
 208
 209 has message_id =>
 210     (is => 'ro',
 211      isa => 'Str',
 212      lazy => 1,
 213      builder =>
 214      sub {
 215          my $self = shift;
 216          return 'nomessageid.'.$self->date.'_'.
 217              md5_hex($self->subject.$self->submitter).'@'.$config{email_domain},
 218      },
 219      writer => '_set_message_id',
 220     );
 221
 222
 223 =item done
 224
 225 =item severity
 226
 227 =cut
 228
 229 has severity =>
 230     (is => 'ro',
 231      isa => 'Str',
 232      default => $config{default_severity},
 233      writer => '_set_severity',
 234     );
 235
 236 =item unarchived
 237
 238 Unix epoch the bug was last unarchived. Zero if the bug has never been
 239 unarchived.
 240
 241 =cut
 242
 243 has unarchived =>
 244     (is => 'ro',
 245      isa => 'Int',
 246      default => 0,
 247      writer => '_set_unarchived',
 248     );
 249
 250 =item archived
 251
 252 True if the bug is archived, false otherwise.
 253
 254 =cut
 255
 256 has archived =>
 257     (is => 'ro',
 258      isa => 'Int',
 259      default => 0,
 260      writer => '_set_archived',
 261     );
 262
 263 =item owner
 264
 265 =item summary
 266
 267 =item outlook
 268
 269 =item done
 270
 271 =item forwarded
 272
 273 =cut
 274
 275 for my $field (qw(owner unarchived summary outlook done forwarded)) {
 276     has $field =>
 277         (is => 'ro',
 278          isa => 'Str',
 279          default => '',
 280          writer => '_set_'.$field,
 281         );
 282     my $field_method = $meta->find_method_by_name($field);
 283     die "No field method for $field" unless defined $field_method;
 284     $meta->add_method('has_'.$field =>
 285                       sub {my $self = shift;
 286                            return length($field_method->($self));
 287                        });
 288 }
 289
 290 =back
 291
 292 =head3 Multi-value Fields
 293
 294 =over
 295
 296 =item affects
 297
 298 =item package
 299
 300 =item tags
 301
 302 =cut
 303
 304 for my $field (qw(affects package tags)) {
 305     has '_'.$field =>
 306         (is => 'ro',
 307          traits => [qw(Array)],
 308          isa => 'ArrayRef[Str]',
 309          default => sub {return []},
 310          writer => '_set_'.$field,
 311          handles => {$field => 'elements',
 312                     },
 313          lazy => 1,
 314         );
 315     my $field_method = $meta->find_method_by_name($field);
 316     if (defined $field_method) {
 317         $meta->add_method($field.'_ref'=>
 318                           sub {my $self = shift;
 319                                return [$field_method->($self)]
 320                            });
 321     }
 322 }
 323
 324 =item found
 325
 326 =item fixed
 327
 328 =cut
 329
 330 for my $field (qw(found fixed)) {
 331     has '_'.$field =>
 332         (is => 'ro',
 333          traits => ['Hash'],
 334          isa => 'HashRef[Str]',
 335          default => sub {return {}},
 336          writer => '_set_'.$field,
 337          handles => {$field => 'keys',
 338                     },
 339          lazy => 1,
 340         );
 341     my $field_method = $meta->find_method_by_name($field);
 342     if (defined $field_method) {
 343         $meta->add_method('_'.$field.'_ref'=>
 344                           sub {my $self = shift;
 345                                return [$field_method->($self)]
 346                            });
 347     }
 348 }
 349
 350
 351 for (qw(found fixed)) {
 352     around '_set_'.$_ => sub {
 353         my $orig = shift;
 354         my $self = shift;
 355         if (defined ref($_[0]) and
 356             ref($_[0]) eq 'ARRAY'
 357            ) {
 358             @_ = {map {$_,'1'} @{$_[0]}};
 359         } elsif (@_ > 1) {
 360             @_ = {map {$_,'1'} @_};
 361         }
 362         $self->$orig(@_);
 363     };
 364 }
 365
 366
 367
 368 =item mergedwith
 369
 370 =item blocks
 371
 372 =item blocked_by
 373
 374 =cut
 375
 376 for my $field (qw(blocks blocked_by mergedwith)) {
 377     has '_'.$field =>
 378         (is => 'ro',
 379          traits => ['Hash'],
 380          isa => 'HashRef[Int]',
 381          default => sub {return {}},
 382          writer => '_set_'.$field,
 383          lazy => 1,
 384         );
 385     my $internal_field_method = $meta->find_method_by_name('_'.$field);
 386     die "No field method for _$field" unless defined $internal_field_method;
 387     $meta->add_method($field =>
 388                       sub {my $self = shift;
 389                            return sort {$a <=> $b}
 390                                keys %{$internal_field_method->($self)};
 391                        });
 392     my $field_method = $meta->find_method_by_name($field);
 393     die "No field method for _$field" unless defined $field_method;
 394     $meta->add_method('_'.$field.'_ref'=>
 395                       sub {my $self = shift;
 396                            return [$field_method->($self)]
 397                        });
 398 }
 399
 400 for (qw(blocks blocked_by mergedwith)) {
 401     around '_set_'.$_ => sub {
 402         my $orig = shift;
 403         my $self = shift;
 404         if (defined ref($_[0]) and
 405             ref($_[0]) eq 'ARRAY'
 406            ) {
 407             $_[0] = {map {$_,'1'} @{$_[0]}};
 408         } elsif (@_ > 1) {
 409             @_ = {map {$_,'1'} @{$_[0]}};
 410         }
 411         $self->$orig(@_);
 412     };
 413 }
 414
 415 =back
 416
 417 =cut
 418
 419 sub _build_split_field {
 420     sub sort_and_unique {
 421         my @v;
 422         my %u;
 423         my $all_numeric = 1;
 424         for my $v (@_) {
 425             if ($all_numeric and $v =~ /\D/) {
 426                 $all_numeric = 0;
 427             }
 428             next if exists $u{$v};
 429             $u{$v} = 1;
 430             push @v, $v;
 431         }
 432         if ($all_numeric) {
 433             return sort {$a <=> $b} @v;
 434         } else {
 435             return sort @v;
 436         }
 437     }
 438     sub split_ditch_empty {
 439         return grep {length $_} map {split ' '} @_;
 440
 441     }
 442     my ($val,$field) = @_;
 443     $val //= '';
 444
 445     if ($field =~ /^(package|affects|source)$/) {
 446         return [grep {length $_} map lc, split /[\s,()?]+/, $val];
 447     } else {
 448         return [sort_and_unique(split_ditch_empty($val))];
 449     }
 450 }
 451
 452
 453 __PACKAGE__->meta->make_immutable;
 454
 455 no Mouse;
 456 no Mouse::Util::TypeConstraints;
 457 1;
 458
 459
 460 __END__
 461 # Local Variables:
 462 # indent-tabs-mode: nil
 463 # cperl-indent-level: 4
 464 # End: