File Coverage

File:Dpkg/Changelog/Entry/Debian.pm
Coverage:80.6%

linestmtbrancondsubpodtimecode
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
17package Dpkg::Changelog::Entry::Debian;
18
19
6
6
6
6
14
3
66
use strict;
20
6
6
6
6
7
5
173
use warnings;
21
22our $VERSION = '2.00';
23our @EXPORT_OK = qw(
24    match_header
25    match_trailer
26    find_closes
27);
28
29
6
6
6
6
11
4
63
use Exporter qw(import);
30
6
6
6
6
5106
29906
11
use Time::Piece;
31
32
6
6
6
6
203
5
153
use Dpkg::Gettext;
33
6
6
6
6
14
4
228
use Dpkg::Control::Fields;
34
6
6
6
6
10
6
76
use Dpkg::Control::Changelog;
35
6
6
6
6
766
6
84
use Dpkg::Changelog::Entry;
36
6
6
6
6
14
5
194
use Dpkg::Version;
37
38
6
6
6
6
12
3
14
use parent qw(Dpkg::Changelog::Entry);
39
40=encoding utf8
41
42 - 53
=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 Dpkg::Changelog::Entry.
Only functions specific to this implementation are described below,
the rest are inherited.

=cut
54
55my $name_chars = qr/[-+0-9a-z.]/i;
56
57# The matched content is the source package name ($1), the version ($2),
58# the target distributions ($3) and the options on the rest of the line ($4).
59my $regex_header = qr{
60    ^
61    (\w$name_chars*)                    # Package name
62    \ \(([^\(\) \t]+)\)                 # Package version
63    ((?:\s+$name_chars+)+)              # Target distribution
64    \;                                  # Separator
65    (.*?)                               # Key=Value options
66    \s*$                                # Trailing space
67}xi;
68
69# The matched content is the maintainer name ($1), its email ($2),
70# some blanks ($3) and the timestamp ($4), which is decomposed into
71# day of week ($6), date-time ($7) and this into month name ($8).
72my $regex_trailer = qr<
73    ^
74    \ \-\-                              # Trailer marker
75    \ (.*)                              # Maintainer name
76    \ \<(.*)\>                          # Maintainer email
77    (\ \ ?)                             # Blanks
78    (
79      ((\w+)\,\s*)?                     # Day of week (abbreviated)
80      (
81        \d{1,2}\s+                      # Day of month
82        (\w+)\s+                        # Month name (abbreviated)
83        \d{4}\s+                        # Year
84        \d{1,2}:\d\d:\d\d\s+[-+]\d{4}   # ISO 8601 date
85      )
86    )
87    \s*$                                # Trailing space
88>xo;
89
90my %week_day = map { $_ => 1 } qw(Mon Tue Wed Thu Fri Sat Sun);
91my @month_abbrev = qw(
92    Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
93);
94my %month_abbrev = map { $_ => 1 } @month_abbrev;
95my @month_name = qw(
96    January February March April May June July
97    August September October November December
98);
99my %month_name = map { $month_name[$_] => $month_abbrev[$_] } 0 .. 11;
100
101 - 113
=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
114
115sub get_change_items {
116
2
2
1
2
    my $self = shift;
117
2
2
    my (@items, @blanks, $item);
118
2
2
2
2
    foreach my $line (@{$self->get_part('changes')}) {
119
18
100
100
100
28
        if ($line =~ /^\s*\*/) {
120
8
100
8
            push @items, $item if defined $item;
121
8
4
            $item = "$line\n";
122        } elsif ($line =~ /^\s*\[\s[^\]]+\s\]\s*$/) {
123
4
100
4
            push @items, $item if defined $item;
124
4
5
            push @items, "$line\n";
125
4
3
            $item = undef;
126
4
3
            @blanks = ();
127        } elsif ($line =~ /^\s*$/) {
128
2
2
            push @blanks, "$line\n";
129        } else {
130
4
50
2
            if (defined $item) {
131
4
4
                $item .= "@blanks$line\n";
132            } else {
133
0
0
                $item = "$line\n";
134            }
135
4
2
            @blanks = ();
136        }
137    }
138
2
50
3
    push @items, $item if defined $item;
139
2
3
    return @items;
140}
141
142 - 150
=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
151
152sub parse_header {
153
319
319
1
169
    my $self = shift;
154
319
188
    my @errors;
155
319
50
33
1125
    if (defined($self->{header}) and $self->{header} =~ $regex_header) {
156
319
404
        $self->{header_source} = $1;
157
158
319
328
        my $version = Dpkg::Version->new($2);
159
319
257
        my ($ok, $msg) = version_check($version);
160
319
100
264
        if ($ok) {
161
316
275
            $self->{header_version} = $version;
162        } else {
163
3
3
            push @errors, sprintf(g_("version '%s' is invalid: %s"), $version, $msg);
164        }
165
166
319
319
182
460
        @{$self->{header_dists}} = split ' ', $3;
167
168
319
268
        my $options = $4;
169
319
381
        $options =~ s/^\s+//;
170
319
357
        my $f = Dpkg::Control::Changelog->new();
171
319
362
        foreach my $opt (split(/\s*,\s*/, $options)) {
172
323
50
579
            unless ($opt =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i) {
173
0
0
                push @errors, sprintf(g_("bad key-value after ';': '%s'"), $opt);
174
0
0
                next;
175            }
176
323
276
            my ($k, $v) = (field_capitalize($1), $2);
177
323
50
436
            if (exists $f->{$k}) {
178
0
0
                push @errors, sprintf(g_('repeated key-value %s'), $k);
179            } else {
180
323
245
                $f->{$k} = $v;
181            }
182
323
100
50
50
432
            if ($k eq 'Urgency') {
183
319
50
555
                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
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
319
307
        $self->{header_fields} = $f;
194    } else {
195
0
0
        push @errors, g_("the header doesn't match the expected regex");
196    }
197
319
284
    return @errors;
198}
199
200sub parse_trailer {
201
317
317
1
185
    my $self = shift;
202
317
183
    my @errors;
203
317
50
33
1193
    if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) {
204
317
693
        $self->{trailer_maintainer} = "$1 <$2>";
205
206
317
50
332
        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
317
50
67
565
        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
317
698
        local $ENV{LC_ALL} = 'C';
218        eval {
219
317
334
            my $tp = Time::Piece->strptime($7, '%d %b %Y %T %z');
220
317
16021
            $self->{trailer_timepiece} = $tp;
221
317
50
183
        } 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
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
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
317
3615
        $self->{trailer_timestamp_date} = $4;
238    } else {
239
0
0
        push @errors, g_("the trailer doesn't match the expected regex");
240    }
241
317
311
    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
251sub normalize {
252
0
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
263sub get_source {
264
502
502
1
308
    my $self = shift;
265
266
502
589
    return $self->{header_source};
267}
268
269 - 273
=item $ver = $entry->get_version()

Return the version associated to the changelog entry.

=cut
274
275sub get_version {
276
2074
2074
1
1112
    my $self = shift;
277
278
2074
1574
    return $self->{header_version};
279}
280
281 - 285
=item @dists = $entry->get_distributions()

Return a list of target distributions for this version.

=cut
286
287sub get_distributions {
288
509
509
1
283
    my $self = shift;
289
290
509
50
423
    if (defined $self->{header_dists}) {
291
509
502
100
346
590
        return @{$self->{header_dists}} if wantarray;
292
7
12
        return $self->{header_dists}[0];
293    }
294
0
0
    return;
295}
296
297 - 302
=item $fields = $entry->get_optional_fields()

Return a set of optional fields exposed by the changelog entry.
It always returns a Dpkg::Control object (possibly empty though).

=cut
303
304sub get_optional_fields {
305
1478
1478
1
783
    my $self = shift;
306
1478
775
    my $f;
307
308
1478
50
1090
    if (defined $self->{header_fields}) {
309
1478
902
        $f = $self->{header_fields};
310    } else {
311
0
0
        $f = Dpkg::Control::Changelog->new();
312    }
313
314
1478
1478
737
1963
    my @closes = find_closes(join("\n", @{$self->{changes}}));
315
1478
100
1169
    if (@closes) {
316
1034
1081
        $f->{Closes} = join(' ', @closes);
317    }
318
319
1478
1457
    return $f;
320}
321
322 - 326
=item $urgency = $entry->get_urgency()

Return the urgency of the associated upload.

=cut
327
328sub get_urgency {
329
738
738
1
435
    my $self = shift;
330
738
503
    my $f = $self->get_optional_fields();
331
738
50
549
    if (exists $f->{Urgency}) {
332
738
454
        $f->{Urgency} =~ s/\s.*$//;
333
738
669
        return lc($f->{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
344sub get_maintainer {
345
502
502
1
277
    my $self = shift;
346
347
502
567
    return $self->{trailer_maintainer};
348}
349
350 - 354
=item $time = $entry->get_timestamp()

Return the timestamp of the changelog entry.

=cut
355
356sub get_timestamp {
357
508
508
1
267
    my $self = shift;
358
359
508
550
    return $self->{trailer_timestamp_date};
360}
361
362 - 368
=item $time = $entry->get_timepiece()

Return the timestamp of the changelog entry as a Time::Piece object.

This function might return undef if there was no timestamp.

=cut
369
370sub get_timepiece {
371
1000
1000
1
5058
    my $self = shift;
372
373
1000
930
    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
388sub match_header {
389
4370
4370
1
2291
    my $line = shift;
390
391
4370
12624
    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
400sub match_trailer {
401
4039
4039
1
2369
    my $line = shift;
402
403
4039
6434
    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
414sub find_closes {
415
1478
1478
1
837
    my $changes = shift;
416
1478
736
    my %closes;
417
418
1478
67
3615
    while ($changes && ($changes =~ m{
419               closes:\s*
420               (?:bug)?\#?\s?\d+
421               (?:,\s*(?:bug)?\#?\s?\d+)*
422           }pigx)) {
423
5822
20008
        $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g);
424    }
425
426
1478
19765
1732
10490
    my @closes = sort { $a <=> $b } keys %closes;
427
1478
2129
    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
4621;