| File: | Dpkg/Changelog/Entry/Debian.pm |
| Coverage: | 80.6% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 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 | =encoding utf8 | ||||||
| 18 | |||||||
| 19 - 30 | =head1 NAME Dpkg::Changelog::Entry::Debian - represents a Debian changelog entry =head1 DESCRIPTION This class represents a Debian changelog entry. It implements the generic interface L<Dpkg::Changelog::Entry>. Only functions specific to this implementation are described below, the rest are inherited. =cut | ||||||
| 31 | |||||||
| 32 | package Dpkg::Changelog::Entry::Debian 2.00; | ||||||
| 33 | |||||||
| 34 | 18 18 18 | 67 11 261 | use strict; | ||||
| 35 | 18 18 18 | 30 13 787 | use warnings; | ||||
| 36 | |||||||
| 37 | our @EXPORT_OK = qw( | ||||||
| 38 | match_header | ||||||
| 39 | match_trailer | ||||||
| 40 | find_closes | ||||||
| 41 | ); | ||||||
| 42 | |||||||
| 43 | 18 18 18 | 52 87 254 | use Exporter qw(import); | ||||
| 44 | 18 18 18 | 7242 94462 42 | use Time::Piece; | ||||
| 45 | |||||||
| 46 | 18 18 18 | 898 15 669 | use Dpkg::Gettext; | ||||
| 47 | 18 18 18 | 43 12 863 | use Dpkg::Control::Fields; | ||||
| 48 | 18 18 18 | 37 21 294 | use Dpkg::Control::Changelog; | ||||
| 49 | 18 18 18 | 3282 23 379 | use Dpkg::Changelog::Entry; | ||||
| 50 | 18 18 18 | 54 102 1134 | use Dpkg::Version; | ||||
| 51 | |||||||
| 52 | 18 18 18 | 344 147 142 | use parent qw(Dpkg::Changelog::Entry); | ||||
| 53 | |||||||
| 54 | my $name_chars = qr/[-+0-9a-z.]/i; | ||||||
| 55 | |||||||
| 56 | # The matched content is the source package name ($1), the version ($2), | ||||||
| 57 | # the target distributions ($3) and the options on the rest of the line ($4). | ||||||
| 58 | my $regex_header = qr{ | ||||||
| 59 | ^ | ||||||
| 60 | (\w$name_chars*) # Package name | ||||||
| 61 | \ \(([^\(\) \t]+)\) # Package version | ||||||
| 62 | ((?:\s+$name_chars+)+) # Target distribution | ||||||
| 63 | \; # Separator | ||||||
| 64 | (.*?) # Key=Value options | ||||||
| 65 | \s*$ # Trailing space | ||||||
| 66 | }xi; | ||||||
| 67 | |||||||
| 68 | # The matched content is the maintainer name ($1), its email ($2), | ||||||
| 69 | # some blanks ($3) and the timestamp ($4), which is decomposed into | ||||||
| 70 | # day of week ($6), date-time ($7) and this into month name ($8). | ||||||
| 71 | my $regex_trailer = qr< | ||||||
| 72 | ^ | ||||||
| 73 | \ \-\- # Trailer marker | ||||||
| 74 | \ (.*) # Maintainer name | ||||||
| 75 | \ \<(.*)\> # Maintainer email | ||||||
| 76 | (\ \ ?) # Blanks | ||||||
| 77 | ( | ||||||
| 78 | ((\w+)\,\s*)? # Day of week (abbreviated) | ||||||
| 79 | ( | ||||||
| 80 | \d{1,2}\s+ # Day of month | ||||||
| 81 | (\w+)\s+ # Month name (abbreviated) | ||||||
| 82 | \d{4}\s+ # Year | ||||||
| 83 | \d{1,2}:\d\d:\d\d\s+[-+]\d{4} # ISO 8601 date | ||||||
| 84 | ) | ||||||
| 85 | ) | ||||||
| 86 | \s*$ # Trailing space | ||||||
| 87 | >xo; | ||||||
| 88 | |||||||
| 89 | my %week_day = map { $_ => 1 } qw(Mon Tue Wed Thu Fri Sat Sun); | ||||||
| 90 | my @month_abbrev = qw( | ||||||
| 91 | Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec | ||||||
| 92 | ); | ||||||
| 93 | my %month_abbrev = map { $_ => 1 } @month_abbrev; | ||||||
| 94 | my @month_name = qw( | ||||||
| 95 | January February March April May June July | ||||||
| 96 | August September October November December | ||||||
| 97 | ); | ||||||
| 98 | my %month_name = map { $month_name[$_] => $month_abbrev[$_] } 0 .. 11; | ||||||
| 99 | |||||||
| 100 - 112 | =head1 METHODS =over 4 =item @items = $entry->get_change_items() Return a list of change items. Each item contains at least one line. A change line starting with an asterisk denotes the start of a new item. Any change line like "C<[ Raphaël Hertzog ]>" is treated like an item of its own even if it starts a set of items attributed to this person (the following line necessarily starts a new item). =cut | ||||||
| 113 | |||||||
| 114 | sub get_change_items { | ||||||
| 115 | 6 | 1 | 11 | my $self = shift; | |||
| 116 | 6 | 8 | my (@items, @blanks, $item); | ||||
| 117 | 6 6 | 6 16 | foreach my $line (@{$self->get_part('changes')}) { | ||||
| 118 | 54 | 127 | if ($line =~ /^\s*\*/) { | ||||
| 119 | 24 | 30 | push @items, $item if defined $item; | ||||
| 120 | 24 | 28 | $item = "$line\n"; | ||||
| 121 | } elsif ($line =~ /^\s*\[\s[^\]]+\s\]\s*$/) { | ||||||
| 122 | 12 | 18 | push @items, $item if defined $item; | ||||
| 123 | 12 | 18 | push @items, "$line\n"; | ||||
| 124 | 12 | 13 | $item = undef; | ||||
| 125 | 12 | 26 | @blanks = (); | ||||
| 126 | } elsif ($line =~ /^\s*$/) { | ||||||
| 127 | 6 | 13 | push @blanks, "$line\n"; | ||||
| 128 | } else { | ||||||
| 129 | 12 | 14 | if (defined $item) { | ||||
| 130 | 12 | 22 | $item .= "@blanks$line\n"; | ||||
| 131 | } else { | ||||||
| 132 | 0 | 0 | $item = "$line\n"; | ||||
| 133 | } | ||||||
| 134 | 12 | 16 | @blanks = (); | ||||
| 135 | } | ||||||
| 136 | } | ||||||
| 137 | 6 | 15 | push @items, $item if defined $item; | ||||
| 138 | 6 | 15 | return @items; | ||||
| 139 | } | ||||||
| 140 | |||||||
| 141 - 149 | =item @errors = $entry->parse_header() =item @errors = $entry->parse_trailer() Return a list of errors. Each item in the list is an error message describing the problem. If the empty list is returned, no errors have been found. =cut | ||||||
| 150 | |||||||
| 151 | sub parse_header { | ||||||
| 152 | 957 | 1 | 684 | my $self = shift; | |||
| 153 | 957 | 627 | my @errors; | ||||
| 154 | 957 | 4762 | if (defined($self->{header}) and $self->{header} =~ $regex_header) { | ||||
| 155 | 957 | 1453 | $self->{header_source} = $1; | ||||
| 156 | |||||||
| 157 | 957 | 1630 | my $version = Dpkg::Version->new($2); | ||||
| 158 | 957 | 1230 | my ($ok, $msg) = version_check($version); | ||||
| 159 | 957 | 970 | if ($ok) { | ||||
| 160 | 948 | 883 | $self->{header_version} = $version; | ||||
| 161 | } else { | ||||||
| 162 | 9 | 10 | push @errors, sprintf(g_("version '%s' is invalid: %s"), $version, $msg); | ||||
| 163 | } | ||||||
| 164 | |||||||
| 165 | 957 957 | 680 1839 | @{$self->{header_dists}} = split ' ', $3; | ||||
| 166 | |||||||
| 167 | 957 | 1070 | my $options = $4; | ||||
| 168 | 957 | 1414 | $options =~ s/^\s+//; | ||||
| 169 | 957 | 1662 | my $c = Dpkg::Control::Changelog->new(); | ||||
| 170 | 957 | 1600 | foreach my $opt (split(/\s*,\s*/, $options)) { | ||||
| 171 | 969 | 2585 | unless ($opt =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i) { | ||||
| 172 | 0 | 0 | push @errors, sprintf(g_("bad key-value after ';': '%s'"), $opt); | ||||
| 173 | 0 | 0 | next; | ||||
| 174 | } | ||||||
| 175 | ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) | ||||||
| 176 | 969 | 1196 | my ($k, $v) = (field_capitalize($1), $2); | ||||
| 177 | 969 | 1769 | if (exists $c->{$k}) { | ||||
| 178 | 0 | 0 | push @errors, sprintf(g_('repeated key-value %s'), $k); | ||||
| 179 | } else { | ||||||
| 180 | 969 | 909 | $c->{$k} = $v; | ||||
| 181 | } | ||||||
| 182 | 969 | 1599 | if ($k eq 'Urgency') { | ||||
| 183 | 957 | 2384 | push @errors, sprintf(g_('badly formatted urgency value: %s'), $v) | ||||
| 184 | unless ($v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i); | ||||||
| 185 | } elsif ($k eq 'Binary-Only') { | ||||||
| 186 | 0 | 0 | push @errors, sprintf(g_('bad binary-only value: %s'), $v) | ||||
| 187 | unless ($v eq 'yes'); | ||||||
| 188 | } elsif ($k =~ m/^X[BCS]+-/i) { | ||||||
| 189 | } else { | ||||||
| 190 | 0 | 0 | push @errors, sprintf(g_('unknown key-value %s'), $k); | ||||
| 191 | } | ||||||
| 192 | } | ||||||
| 193 | 957 | 1284 | $self->{header_fields} = $c; | ||||
| 194 | } else { | ||||||
| 195 | 0 | 0 | push @errors, g_("the header doesn't match the expected regex"); | ||||
| 196 | } | ||||||
| 197 | 957 | 1121 | return @errors; | ||||
| 198 | } | ||||||
| 199 | |||||||
| 200 | sub parse_trailer { | ||||||
| 201 | 951 | 1 | 684 | my $self = shift; | |||
| 202 | 951 | 636 | my @errors; | ||||
| 203 | 951 | 4700 | if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) { | ||||
| 204 | 951 | 2912 | $self->{trailer_maintainer} = "$1 <$2>"; | ||||
| 205 | |||||||
| 206 | 951 | 1363 | if ($3 ne ' ') { | ||||
| 207 | 0 | 0 | push @errors, g_('badly formatted trailer line'); | ||||
| 208 | } | ||||||
| 209 | |||||||
| 210 | # Validate the week day. Date::Parse used to ignore it, but Time::Piece | ||||||
| 211 | # is much more strict and it does not gracefully handle bogus values. | ||||||
| 212 | 951 | 2377 | if (defined $5 and not exists $week_day{$6}) { | ||||
| 213 | 0 | 0 | push @errors, sprintf(g_('ignoring invalid week day \'%s\''), $6); | ||||
| 214 | } | ||||||
| 215 | |||||||
| 216 | # Ignore the week day ('%a, '), as we have validated it above. | ||||||
| 217 | 951 | 3763 | local $ENV{LC_ALL} = 'C'; | ||||
| 218 | eval { | ||||||
| 219 | 951 | 1659 | my $tp = Time::Piece->strptime($7, '%d %b %Y %T %z'); | ||||
| 220 | 951 | 64110 | $self->{trailer_timepiece} = $tp; | ||||
| 221 | 951 | 739 | } or do { | ||||
| 222 | # Validate the month. Date::Parse used to accept both abbreviated | ||||||
| 223 | # and full months, but Time::Piece strptime() implementation only | ||||||
| 224 | # matches the abbreviated one with %b, which is what we want anyway. | ||||||
| 225 | 0 | 0 | if (not exists $month_abbrev{$8}) { | ||||
| 226 | # We have to nest the conditionals because May is the same in | ||||||
| 227 | # full and abbreviated forms! | ||||||
| 228 | 0 | 0 | if (exists $month_name{$8}) { | ||||
| 229 | push @errors, sprintf(g_('uses full \'%s\' instead of abbreviated month name \'%s\''), | ||||||
| 230 | 0 | 0 | $8, $month_name{$8}); | ||||
| 231 | } else { | ||||||
| 232 | 0 | 0 | push @errors, sprintf(g_('invalid abbreviated month name \'%s\''), $8); | ||||
| 233 | } | ||||||
| 234 | } | ||||||
| 235 | 0 | 0 | push @errors, sprintf(g_("cannot parse non-conformant date '%s'"), $7); | ||||
| 236 | }; | ||||||
| 237 | 951 | 13492 | $self->{trailer_timestamp_date} = $4; | ||||
| 238 | } else { | ||||||
| 239 | 0 | 0 | push @errors, g_("the trailer doesn't match the expected regex"); | ||||
| 240 | } | ||||||
| 241 | 951 | 1271 | return @errors; | ||||
| 242 | } | ||||||
| 243 | |||||||
| 244 - 249 | =item $entry->normalize() Normalize the content. Strip whitespaces at end of lines, use a single empty line to separate each part. =cut | ||||||
| 250 | |||||||
| 251 | sub normalize { | ||||||
| 252 | 0 | 1 | 0 | my $self = shift; | |||
| 253 | 0 | 0 | $self->SUPER::normalize(); | ||||
| 254 | #XXX: recreate header/trailer | ||||||
| 255 | } | ||||||
| 256 | |||||||
| 257 - 261 | =item $src = $entry->get_source() Return the name of the source package associated to the changelog entry. =cut | ||||||
| 262 | |||||||
| 263 | sub get_source { | ||||||
| 264 | 1506 | 1 | 1077 | my $self = shift; | |||
| 265 | |||||||
| 266 | 1506 | 2667 | return $self->{header_source}; | ||||
| 267 | } | ||||||
| 268 | |||||||
| 269 - 273 | =item $ver = $entry->get_version() Return the version associated to the changelog entry. =cut | ||||||
| 274 | |||||||
| 275 | sub get_version { | ||||||
| 276 | 6222 | 1 | 4068 | my $self = shift; | |||
| 277 | |||||||
| 278 | 6222 | 7158 | return $self->{header_version}; | ||||
| 279 | } | ||||||
| 280 | |||||||
| 281 - 285 | =item @dists = $entry->get_distributions() Return a list of target distributions for this version. =cut | ||||||
| 286 | |||||||
| 287 | sub get_distributions { | ||||||
| 288 | 1527 | 1 | 1168 | my $self = shift; | |||
| 289 | |||||||
| 290 | 1527 | 1769 | if (defined $self->{header_dists}) { | ||||
| 291 | 1527 1506 | 1419 2539 | return @{$self->{header_dists}} if wantarray; | ||||
| 292 | 21 | 50 | return $self->{header_dists}[0]; | ||||
| 293 | } | ||||||
| 294 | 0 | 0 | return; | ||||
| 295 | } | ||||||
| 296 | |||||||
| 297 - 302 | =item $ctrl = $entry->get_optional_fields() Return a set of optional fields exposed by the changelog entry. It always returns a L<Dpkg::Control> object (possibly empty though). =cut | ||||||
| 303 | |||||||
| 304 | sub get_optional_fields { | ||||||
| 305 | 4434 | 1 | 2962 | my $self = shift; | |||
| 306 | 4434 | 2872 | my $c; | ||||
| 307 | |||||||
| 308 | 4434 | 4762 | if (defined $self->{header_fields}) { | ||||
| 309 | 4434 | 3290 | $c = $self->{header_fields}; | ||||
| 310 | } else { | ||||||
| 311 | 0 | 0 | $c = Dpkg::Control::Changelog->new(); | ||||
| 312 | } | ||||||
| 313 | |||||||
| 314 | 4434 4434 | 2989 9416 | my @closes = find_closes(join("\n", @{$self->{changes}})); | ||||
| 315 | 4434 | 4426 | if (@closes) { | ||||
| 316 | 3102 | 4919 | $c->{Closes} = join ' ', @closes; | ||||
| 317 | } | ||||||
| 318 | |||||||
| 319 | 4434 | 5822 | return $c; | ||||
| 320 | } | ||||||
| 321 | |||||||
| 322 - 326 | =item $urgency = $entry->get_urgency() Return the urgency of the associated upload. =cut | ||||||
| 327 | |||||||
| 328 | sub get_urgency { | ||||||
| 329 | 2214 | 1 | 1643 | my $self = shift; | |||
| 330 | 2214 | 2222 | my $c = $self->get_optional_fields(); | ||||
| 331 | 2214 | 2207 | if (exists $c->{Urgency}) { | ||||
| 332 | 2214 | 1849 | $c->{Urgency} =~ s/\s.*$//; | ||||
| 333 | 2214 | 2494 | return lc $c->{Urgency}; | ||||
| 334 | } | ||||||
| 335 | 0 | 0 | return; | ||||
| 336 | } | ||||||
| 337 | |||||||
| 338 - 342 | =item $maint = $entry->get_maintainer() Return the string identifying the person who signed this changelog entry. =cut | ||||||
| 343 | |||||||
| 344 | sub get_maintainer { | ||||||
| 345 | 1506 | 1 | 1045 | my $self = shift; | |||
| 346 | |||||||
| 347 | 1506 | 2496 | return $self->{trailer_maintainer}; | ||||
| 348 | } | ||||||
| 349 | |||||||
| 350 - 354 | =item $time = $entry->get_timestamp() Return the timestamp of the changelog entry. =cut | ||||||
| 355 | |||||||
| 356 | sub get_timestamp { | ||||||
| 357 | 1524 | 1 | 1033 | my $self = shift; | |||
| 358 | |||||||
| 359 | 1524 | 2471 | return $self->{trailer_timestamp_date}; | ||||
| 360 | } | ||||||
| 361 | |||||||
| 362 - 368 | =item $time = $entry->get_timepiece() Return the timestamp of the changelog entry as a L<Time::Piece> object. This function might return undef if there was no timestamp. =cut | ||||||
| 369 | |||||||
| 370 | sub get_timepiece { | ||||||
| 371 | 3000 | 1 | 19190 | my $self = shift; | |||
| 372 | |||||||
| 373 | 3000 | 4167 | return $self->{trailer_timepiece}; | ||||
| 374 | } | ||||||
| 375 | |||||||
| 376 | =back | ||||||
| 377 | |||||||
| 378 - 386 | =head1 UTILITY FUNCTIONS =over 4 =item $bool = match_header($line) Checks if the line matches a valid changelog header line. =cut | ||||||
| 387 | |||||||
| 388 | sub match_header { | ||||||
| 389 | 13110 | 1 | 8138 | my $line = shift; | |||
| 390 | |||||||
| 391 | 13110 | 52537 | return $line =~ /$regex_header/; | ||||
| 392 | } | ||||||
| 393 | |||||||
| 394 - 398 | =item $bool = match_trailer($line) Checks if the line matches a valid changelog trailing line. =cut | ||||||
| 399 | |||||||
| 400 | sub match_trailer { | ||||||
| 401 | 12117 | 1 | 7757 | my $line = shift; | |||
| 402 | |||||||
| 403 | 12117 | 24619 | return $line =~ /$regex_trailer/; | ||||
| 404 | } | ||||||
| 405 | |||||||
| 406 - 412 | =item @closed_bugs = find_closes($changes) Takes one string as argument and finds "Closes: #123456, #654321" statements as supported by the Debian Archive software in it. Returns all closed bug numbers in an array. =cut | ||||||
| 413 | |||||||
| 414 | sub find_closes { | ||||||
| 415 | 4434 | 1 | 3099 | my $changes = shift; | |||
| 416 | 4434 | 2702 | my %closes; | ||||
| 417 | |||||||
| 418 | 4434 | 17446 | while ($changes && ($changes =~ m{ | ||||
| 419 | closes:\s* | ||||||
| 420 | (?:bug)?\#?\s?\d+ | ||||||
| 421 | (?:,\s*(?:bug)?\#?\s?\d+)* | ||||||
| 422 | }pigx)) { | ||||||
| 423 | 17466 | 81540 | $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g); | ||||
| 424 | } | ||||||
| 425 | |||||||
| 426 | 4434 59240 | 7427 37937 | my @closes = sort { $a <=> $b } keys %closes; | ||||
| 427 | 4434 | 8632 | return @closes; | ||||
| 428 | } | ||||||
| 429 | |||||||
| 430 | =back | ||||||
| 431 | |||||||
| 432 - 460 | =head1 CHANGES =head2 Version 2.00 (dpkg 1.20.0) Remove methods: $entry->check_header(), $entry->check_trailer(). Hide variables: $regex_header, $regex_trailer. =head2 Version 1.03 (dpkg 1.18.8) New methods: $entry->get_timepiece(). =head2 Version 1.02 (dpkg 1.18.5) New methods: $entry->parse_header(), $entry->parse_trailer(). Deprecated methods: $entry->check_header(), $entry->check_trailer(). =head2 Version 1.01 (dpkg 1.17.2) New functions: match_header(), match_trailer() Deprecated variables: $regex_header, $regex_trailer =head2 Version 1.00 (dpkg 1.15.6) Mark the module as public. =cut | ||||||
| 461 | |||||||
| 462 | 1; | ||||||