chiark - git - mdw - dpkg/blob - scripts/Dpkg/Changelog/Entry/Debian.pm

   1 # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
   2 # Copyright © 2012-2013 Guillem Jover <guillem@debian.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 package Dpkg::Changelog::Entry::Debian;
  18
  19 use strict;
  20 use warnings;
  21
  22 our $VERSION = '1.03';
  23 our @EXPORT_OK = qw(
  24     $regex_header
  25     $regex_trailer
  26     match_header
  27     match_trailer
  28     find_closes
  29 );
  30
  31 use Exporter qw(import);
  32 use Time::Piece;
  33
  34 use Dpkg::Gettext;
  35 use Dpkg::Control::Fields;
  36 use Dpkg::Control::Changelog;
  37 use Dpkg::Changelog::Entry;
  38 use Dpkg::Version;
  39
  40 use parent qw(Dpkg::Changelog::Entry);
  41
  42 =encoding utf8
  43
  44 =head1 NAME
  45
  46 Dpkg::Changelog::Entry::Debian - represents a Debian changelog entry
  47
  48 =head1 DESCRIPTION
  49
  50 This object represents a Debian changelog entry. It implements the
  51 generic interface Dpkg::Changelog::Entry. Only functions specific to this
  52 implementation are described below.
  53
  54 =cut
  55
  56 my $name_chars = qr/[-+0-9a-z.]/i;
  57
  58 # XXX: Backwards compatibility, stop exporting on VERSION 2.00.
  59 ## no critic (Variables::ProhibitPackageVars)
  60
  61 # The matched content is the source package name ($1), the version ($2),
  62 # the target distributions ($3) and the options on the rest of the line ($4).
  63 our $regex_header = qr{
  64     ^
  65     (\w$name_chars*)                    # Package name
  66     \ \(([^\(\) \t]+)\)                 # Package version
  67     ((?:\s+$name_chars+)+)              # Target distribution
  68     \;                                  # Separator
  69     (.*?)                               # Key=Value options
  70     \s*$                                # Trailing space
  71 }xi;
  72
  73 # The matched content is the maintainer name ($1), its email ($2),
  74 # some blanks ($3) and the timestamp ($4), which is decomposed into
  75 # day of week ($6), date-time ($7) and this into month name ($8).
  76 our $regex_trailer = qr<
  77     ^
  78     \ \-\-                              # Trailer marker
  79     \ (.*)                              # Maintainer name
  80     \ \<(.*)\>                          # Maintainer email
  81     (\ \ ?)                             # Blanks
  82     (
  83       ((\w+)\,\s*)?                     # Day of week (abbreviated)
  84       (
  85         \d{1,2}\s+                      # Day of month
  86         (\w+)\s+                        # Month name (abbreviated)
  87         \d{4}\s+                        # Year
  88         \d{1,2}:\d\d:\d\d\s+[-+]\d{4}   # ISO 8601 date
  89       )
  90     )
  91     \s*$                                # Trailing space
  92 >xo;
  93
  94 my %week_day = map { $_ => 1 } qw(Mon Tue Wed Thu Fri Sat Sun);
  95 my %month_abbrev = map { $_ => 1 } qw(
  96     Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
  97 );
  98 my %month_name = map { $_ => } qw(
  99     January February March April May June July
 100     August September October November December
 101 );
 102
 103 ## use critic
 104
 105 =head1 METHODS
 106
 107 =over 4
 108
 109 =item @items = $entry->get_change_items()
 110
 111 Return a list of change items. Each item contains at least one line.
 112 A change line starting with an asterisk denotes the start of a new item.
 113 Any change line like "C<[ Raphaël Hertzog ]>" is treated like an item of its
 114 own even if it starts a set of items attributed to this person (the
 115 following line necessarily starts a new item).
 116
 117 =cut
 118
 119 sub get_change_items {
 120     my $self = shift;
 121     my (@items, @blanks, $item);
 122     foreach my $line (@{$self->get_part('changes')}) {
 123         if ($line =~ /^\s*\*/) {
 124             push @items, $item if defined $item;
 125             $item = "$line\n";
 126         } elsif ($line =~ /^\s*\[\s[^\]]+\s\]\s*$/) {
 127             push @items, $item if defined $item;
 128             push @items, "$line\n";
 129             $item = undef;
 130             @blanks = ();
 131         } elsif ($line =~ /^\s*$/) {
 132             push @blanks, "$line\n";
 133         } else {
 134             if (defined $item) {
 135                 $item .= "@blanks$line\n";
 136             } else {
 137                 $item = "$line\n";
 138             }
 139             @blanks = ();
 140         }
 141     }
 142     push @items, $item if defined $item;
 143     return @items;
 144 }
 145
 146 =item @errors = $entry->parse_header()
 147
 148 =item @errors = $entry->parse_trailer()
 149
 150 Return a list of errors. Each item in the list is an error message
 151 describing the problem. If the empty list is returned, no errors
 152 have been found.
 153
 154 =cut
 155
 156 sub parse_header {
 157     my $self = shift;
 158     my @errors;
 159     if (defined($self->{header}) and $self->{header} =~ $regex_header) {
 160         $self->{header_source} = $1;
 161
 162         my $version = Dpkg::Version->new($2);
 163         my ($ok, $msg) = version_check($version);
 164         if ($ok) {
 165             $self->{header_version} = $version;
 166         } else {
 167             push @errors, sprintf(g_("version '%s' is invalid: %s"), $version, $msg);
 168         }
 169
 170         @{$self->{header_dists}} = split ' ', $3;
 171
 172         my $options = $4;
 173         $options =~ s/^\s+//;
 174         my $f = Dpkg::Control::Changelog->new();
 175         foreach my $opt (split(/\s*,\s*/, $options)) {
 176             unless ($opt =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i) {
 177                 push @errors, sprintf(g_("bad key-value after ';': '%s'"), $opt);
 178                 next;
 179             }
 180             my ($k, $v) = (field_capitalize($1), $2);
 181             if (exists $f->{$k}) {
 182                 push @errors, sprintf(g_('repeated key-value %s'), $k);
 183             } else {
 184                 $f->{$k} = $v;
 185             }
 186             if ($k eq 'Urgency') {
 187                 push @errors, sprintf(g_('badly formatted urgency value: %s'), $v)
 188                     unless ($v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i);
 189             } elsif ($k eq 'Binary-Only') {
 190                 push @errors, sprintf(g_('bad binary-only value: %s'), $v)
 191                     unless ($v eq 'yes');
 192             } elsif ($k =~ m/^X[BCS]+-/i) {
 193             } else {
 194                 push @errors, sprintf(g_('unknown key-value %s'), $k);
 195             }
 196         }
 197         $self->{header_fields} = $f;
 198     } else {
 199         push @errors, g_("the header doesn't match the expected regex");
 200     }
 201     return @errors;
 202 }
 203
 204 sub parse_trailer {
 205     my $self = shift;
 206     my @errors;
 207     if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) {
 208         $self->{trailer_maintainer} = "$1 <$2>";
 209
 210         if ($3 ne '  ') {
 211             push @errors, g_('badly formatted trailer line');
 212         }
 213
 214         # Validate the week day. Date::Parse used to ignore it, but Time::Piece
 215         # is much more strict and it does not gracefully handle bogus values.
 216         if (defined $5 and not exists $week_day{$6}) {
 217             push @errors, sprintf(g_('ignoring invalid week day \'%s\''), $6);
 218         }
 219
 220         # Ignore the week day ('%a, '), as we have validated it above.
 221         local $ENV{LC_ALL} = 'C';
 222         eval {
 223             my $tp = Time::Piece->strptime($7, '%d %b %Y %T %z');
 224             $self->{trailer_timepiece} = $tp;
 225         } or do {
 226             # Validate the month. Date::Parse used to accept both abbreviated
 227             # and full months, but Time::Piece strptime() implementation only
 228             # matches the abbreviated one with %b, which is what we want anyway.
 229             if (not exists $month_abbrev{$8}) {
 230                 # We have to nest the conditionals because May is the same in
 231                 # full and abbreviated forms!
 232                 if (exists $month_name{$8}) {
 233                     push @errors, sprintf(g_('uses full instead of abbreviated month name \'%s\''),
 234                                           $8, $month_name{$8});
 235                 } else {
 236                     push @errors, sprintf(g_('invalid abbreviated month name \'%s\''), $8);
 237                 }
 238             }
 239             push @errors, sprintf(g_("cannot parse non-comformant date '%s'"), $7);
 240         };
 241         $self->{trailer_timestamp_date} = $4;
 242     } else {
 243         push @errors, g_("the trailer doesn't match the expected regex");
 244     }
 245     return @errors;
 246 }
 247
 248 =item $entry->check_header()
 249
 250 Obsolete method. Use parse_header() instead.
 251
 252 =cut
 253
 254 sub check_header {
 255     my $self = shift;
 256
 257     warnings::warnif('deprecated',
 258                      'obsolete check_header(), use parse_header() instead');
 259
 260     return $self->parse_header();
 261 }
 262
 263 =item $entry->check_trailer()
 264
 265 Obsolete method. Use parse_trailer() instead.
 266
 267 =cut
 268
 269 sub check_trailer {
 270     my $self = shift;
 271
 272     warnings::warnif('deprecated',
 273                      'obsolete check_trailer(), use parse_trailer() instead');
 274
 275     return $self->parse_header();
 276 }
 277
 278 =item $entry->normalize()
 279
 280 Normalize the content. Strip whitespaces at end of lines, use a single
 281 empty line to separate each part.
 282
 283 =cut
 284
 285 sub normalize {
 286     my $self = shift;
 287     $self->SUPER::normalize();
 288     #XXX: recreate header/trailer
 289 }
 290
 291 =item $src = $entry->get_source()
 292
 293 Return the name of the source package associated to the changelog entry.
 294
 295 =cut
 296
 297 sub get_source {
 298     my $self = shift;
 299
 300     return $self->{header_source};
 301 }
 302
 303 =item $ver = $entry->get_version()
 304
 305 Return the version associated to the changelog entry.
 306
 307 =cut
 308
 309 sub get_version {
 310     my $self = shift;
 311
 312     return $self->{header_version};
 313 }
 314
 315 =item @dists = $entry->get_distributions()
 316
 317 Return a list of target distributions for this version.
 318
 319 =cut
 320
 321 sub get_distributions {
 322     my $self = shift;
 323
 324     if (defined $self->{header_dists}) {
 325         return @{$self->{header_dists}} if wantarray;
 326         return $self->{header_dists}[0];
 327     }
 328     return;
 329 }
 330
 331 =item $fields = $entry->get_optional_fields()
 332
 333 Return a set of optional fields exposed by the changelog entry.
 334 It always returns a Dpkg::Control object (possibly empty though).
 335
 336 =cut
 337
 338 sub get_optional_fields {
 339     my $self = shift;
 340     my $f;
 341
 342     if (defined $self->{header_fields}) {
 343         $f = $self->{header_fields};
 344     } else {
 345         $f = Dpkg::Control::Changelog->new();
 346     }
 347
 348     my @closes = find_closes(join("\n", @{$self->{changes}}));
 349     if (@closes) {
 350         $f->{Closes} = join(' ', @closes);
 351     }
 352
 353     return $f;
 354 }
 355
 356 =item $urgency = $entry->get_urgency()
 357
 358 Return the urgency of the associated upload.
 359
 360 =cut
 361
 362 sub get_urgency {
 363     my $self = shift;
 364     my $f = $self->get_optional_fields();
 365     if (exists $f->{Urgency}) {
 366         $f->{Urgency} =~ s/\s.*$//;
 367         return lc($f->{Urgency});
 368     }
 369     return;
 370 }
 371
 372 =item $maint = $entry->get_maintainer()
 373
 374 Return the string identifying the person who signed this changelog entry.
 375
 376 =cut
 377
 378 sub get_maintainer {
 379     my $self = shift;
 380
 381     return $self->{trailer_maintainer};
 382 }
 383
 384 =item $time = $entry->get_timestamp()
 385
 386 Return the timestamp of the changelog entry.
 387
 388 =cut
 389
 390 sub get_timestamp {
 391     my $self = shift;
 392
 393     return $self->{trailer_timestamp_date};
 394 }
 395
 396 =item $time = $entry->get_timepiece()
 397
 398 Return the timestamp of the changelog entry as a Time::Piece object.
 399
 400 This function might return undef if there was no timestamp.
 401
 402 =cut
 403
 404 sub get_timepiece {
 405     my $self = shift;
 406
 407     return $self->{trailer_timepiece};
 408 }
 409
 410 =back
 411
 412 =head1 UTILITY FUNCTIONS
 413
 414 =over 4
 415
 416 =item $bool = match_header($line)
 417
 418 Checks if the line matches a valid changelog header line.
 419
 420 =cut
 421
 422 sub match_header {
 423     my $line = shift;
 424
 425     return $line =~ /$regex_header/;
 426 }
 427
 428 =item $bool = match_trailer($line)
 429
 430 Checks if the line matches a valid changelog trailing line.
 431
 432 =cut
 433
 434 sub match_trailer {
 435     my $line = shift;
 436
 437     return $line =~ /$regex_trailer/;
 438 }
 439
 440 =item @closed_bugs = find_closes($changes)
 441
 442 Takes one string as argument and finds "Closes: #123456, #654321" statements
 443 as supported by the Debian Archive software in it. Returns all closed bug
 444 numbers in an array.
 445
 446 =cut
 447
 448 sub find_closes {
 449     my $changes = shift;
 450     my %closes;
 451
 452     while ($changes && ($changes =~ m{
 453                closes:\s*
 454                (?:bug)?\#?\s?\d+
 455                (?:,\s*(?:bug)?\#?\s?\d+)*
 456            }pigx)) {
 457         $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g);
 458     }
 459
 460     my @closes = sort { $a <=> $b } keys %closes;
 461     return @closes;
 462 }
 463
 464 =back
 465
 466 =head1 CHANGES
 467
 468 =head2 Version 1.03 (dpkg 1.18.8)
 469
 470 New methods: $entry->get_timepiece().
 471
 472 =head2 Version 1.02 (dpkg 1.18.5)
 473
 474 New methods: $entry->parse_header(), $entry->parse_trailer().
 475
 476 Deprecated methods: $entry->check_header(), $entry->check_trailer().
 477
 478 =head2 Version 1.01 (dpkg 1.17.2)
 479
 480 New functions: match_header(), match_trailer()
 481
 482 Deprecated variables: $regex_header, $regex_trailer
 483
 484 =head2 Version 1.00 (dpkg 1.15.6)
 485
 486 Mark the module as public.
 487
 488 =cut
 489
 490 1;