[dpkg] / scripts / Dpkg / Changelog / Debian.pm

# Copyright © 1996 Ian Jackson
# Copyright © 2005 Frank Lichtenheld <frank@lichtenheld.de>
# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
# Copyright © 2012-2015 Guillem Jover <guillem@debian.org>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

=encoding utf8

=head1 NAME

Dpkg::Changelog::Debian - parse Debian changelogs

=head1 DESCRIPTION

Dpkg::Changelog::Debian parses Debian changelogs as described in
deb-changelog(5).

The parser tries to ignore most cruft like # or /* */ style comments,
CVS comments, vim variables, emacs local variables and stuff from
older changelogs with other formats at the end of the file.
NOTE: most of these are ignored silently currently, there is no
parser error issued for them. This should become configurable in the
future.

=cut

package Dpkg::Changelog::Debian;

use strict;
use warnings;

our $VERSION = '1.00';

use Dpkg::Gettext;
use Dpkg::File;
use Dpkg::Changelog qw(:util);
use Dpkg::Changelog::Entry::Debian qw(match_header match_trailer);

use parent qw(Dpkg::Changelog);

use constant {
    FIRST_HEADING => g_('first heading'),
    NEXT_OR_EOF => g_('next heading or end of file'),
    START_CHANGES => g_('start of change data'),
    CHANGES_OR_TRAILER => g_('more change data or trailer'),
};

my $ancient_delimiter_re = qr{
    ^
    (?: # Ancient GNU style changelog entry with expanded date
      (?:
        \w+\s+                          # Day of week (abbreviated)
        \w+\s+                          # Month name (abbreviated)
        \d{1,2}                         # Day of month
        \Q \E
        \d{1,2}:\d{1,2}:\d{1,2}\s+      # Time
        [\w\s]*                         # Timezone
        \d{4}                           # Year
      )
      \s+
      (?:.*)                            # Maintainer name
      \s+
      [<\(]
        (?:.*)                          # Maintainer email
      [\)>]
    | # Old GNU style changelog entry with expanded date
      (?:
        \w+\s+                          # Day of week (abbreviated)
        \w+\s+                          # Month name (abbreviated)
        \d{1,2},?\s*                    # Day of month
        \d{4}                           # Year
      )
      \s+
      (?:.*)                            # Maintainer name
      \s+
      [<\(]
        (?:.*)                          # Maintainer email
      [\)>]
    | # Ancient changelog header w/o key=value options
      (?:\w[-+0-9a-z.]*)                # Package name
      \Q \E
      \(
        (?:[^\(\) \t]+)                 # Package version
      \)
      \;?
    | # Ancient changelog header
      (?:[\w.+-]+)                      # Package name
      [- ]
      (?:\S+)                           # Package version
      \ Debian
      \ (?:\S+)                         # Package revision
    |
      Changes\ from\ version\ (?:.*)\ to\ (?:.*):
    |
      Changes\ for\ [\w.+-]+-[\w.+-]+:?\s*$
    |
      Old\ Changelog:\s*$
    |
      (?:\d+:)?
      \w[\w.+~-]*:?
      \s*$
    )
}xi;

=head1 METHODS

=over 4

=item $c->parse($fh, $description)

Read the filehandle and parse a Debian changelog in it. The data in the
object is reset before parsing new data.

Returns the number of changelog entries that have been parsed with success.

=cut

sub parse {
    my ($self, $fh, $file) = @_;
    $file = $self->{reportfile} if exists $self->{reportfile};

    $self->reset_parse_errors;

    $self->{data} = [];
    $self->set_unparsed_tail(undef);

    my $expect = FIRST_HEADING;
    my $entry = Dpkg::Changelog::Entry::Debian->new();
    my @blanklines = ();
    my $unknowncounter = 1; # to make version unique, e.g. for using as id
    local $_;

    while (<$fh>) {
	chomp;
	if (match_header($_)) {
	    unless ($expect eq FIRST_HEADING || $expect eq NEXT_OR_EOF) {
		$self->parse_error($file, $.,
		    sprintf(g_('found start of entry where expected %s'),
		    $expect), "$_");
	    }
	    unless ($entry->is_empty) {
		push @{$self->{data}}, $entry;
		$entry = Dpkg::Changelog::Entry::Debian->new();
		last if $self->abort_early();
	    }
	    $entry->set_part('header', $_);
	    foreach my $error ($entry->parse_header()) {
		$self->parse_error($file, $., $error, $_);
	    }
	    $expect= START_CHANGES;
	    @blanklines = ();
	} elsif (m/^(?:;;\s*)?Local variables:/io) {
	    last; # skip Emacs variables at end of file
	} elsif (m/^vim:/io) {
	    last; # skip vim variables at end of file
	} elsif (m/^\$\w+:.*\$/o) {
	    next; # skip stuff that look like a CVS keyword
	} elsif (m/^\# /o) {
	    next; # skip comments, even that's not supported
	} elsif (m{^/\*.*\*/}o) {
	    next; # more comments
	} elsif (m/$ancient_delimiter_re/) {
	    # save entries on old changelog format verbatim
	    # we assume the rest of the file will be in old format once we
	    # hit it for the first time
	    $self->set_unparsed_tail("$_\n" . file_slurp($fh));
	} elsif (m/^\S/) {
	    $self->parse_error($file, $., g_('badly formatted heading line'), "$_");
	} elsif (match_trailer($_)) {
	    unless ($expect eq CHANGES_OR_TRAILER) {
		$self->parse_error($file, $.,
		    sprintf(g_('found trailer where expected %s'), $expect), "$_");
	    }
	    $entry->set_part('trailer', $_);
	    $entry->extend_part('blank_after_changes', [ @blanklines ]);
	    @blanklines = ();
	    foreach my $error ($entry->parse_trailer()) {
		$self->parse_error($file, $., $error, $_);
	    }
	    $expect = NEXT_OR_EOF;
	} elsif (m/^ \-\-/) {
	    $self->parse_error($file, $., g_('badly formatted trailer line'), "$_");
	} elsif (m/^\s{2,}(?:\S)/) {
	    unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
		$self->parse_error($file, $., sprintf(g_('found change data' .
		    ' where expected %s'), $expect), "$_");
		if ($expect eq NEXT_OR_EOF and not $entry->is_empty) {
		    # lets assume we have missed the actual header line
		    push @{$self->{data}}, $entry;
		    $entry = Dpkg::Changelog::Entry::Debian->new();
		    $entry->set_part('header', 'unknown (unknown' . ($unknowncounter++) . ') unknown; urgency=unknown');
		}
	    }
	    # Keep raw changes
	    $entry->extend_part('changes', [ @blanklines, $_ ]);
	    @blanklines = ();
	    $expect = CHANGES_OR_TRAILER;
	} elsif (!m/\S/) {
	    if ($expect eq START_CHANGES) {
		$entry->extend_part('blank_after_header', $_);
		next;
	    } elsif ($expect eq NEXT_OR_EOF) {
		$entry->extend_part('blank_after_trailer', $_);
		next;
	    } elsif ($expect ne CHANGES_OR_TRAILER) {
		$self->parse_error($file, $.,
		    sprintf(g_('found blank line where expected %s'), $expect));
	    }
	    push @blanklines, $_;
	} else {
	    $self->parse_error($file, $., g_('unrecognized line'), "$_");
	    unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
		# lets assume change data if we expected it
		$entry->extend_part('changes', [ @blanklines, $_]);
		@blanklines = ();
		$expect = CHANGES_OR_TRAILER;
	    }
	}
    }

    unless ($expect eq NEXT_OR_EOF) {
        $self->parse_error($file, $.,
                           sprintf(g_('found end of file where expected %s'),
                                   $expect));
    }
    unless ($entry->is_empty) {
	push @{$self->{data}}, $entry;
    }

    return scalar @{$self->{data}};
}

1;
__END__

=back

=head1 CHANGES

=head2 Version 1.00 (dpkg 1.15.6)

Mark the module as public.

=head1 SEE ALSO

Dpkg::Changelog

=cut
Commit	Line	Data
1479465f GJ	1	# Copyright © 1996 Ian Jackson
	2	# Copyright © 2005 Frank Lichtenheld <frank@lichtenheld.de>
	3	# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
	4	# Copyright © 2012-2015 Guillem Jover <guillem@debian.org>
	5	#
	6	# This program is free software; you can redistribute it and/or modify
	7	# it under the terms of the GNU General Public License as published by
	8	# the Free Software Foundation; either version 2 of the License, or
	9	# (at your option) any later version.
	10	#
	11	# This program is distributed in the hope that it will be useful,
	12	# but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	# GNU General Public License for more details.
	15	#
	16	# You should have received a copy of the GNU General Public License
	17	# along with this program. If not, see <https://www.gnu.org/licenses/>.
	18
	19	=encoding utf8
	20
	21	=head1 NAME
	22
	23	Dpkg::Changelog::Debian - parse Debian changelogs
	24
	25	=head1 DESCRIPTION
	26
	27	Dpkg::Changelog::Debian parses Debian changelogs as described in
	28	deb-changelog(5).
	29
	30	The parser tries to ignore most cruft like # or /* */ style comments,
	31	CVS comments, vim variables, emacs local variables and stuff from
	32	older changelogs with other formats at the end of the file.
	33	NOTE: most of these are ignored silently currently, there is no
	34	parser error issued for them. This should become configurable in the
	35	future.
	36
	37	=cut
	38
	39	package Dpkg::Changelog::Debian;
	40
	41	use strict;
	42	use warnings;
	43
	44	our $VERSION = '1.00';
	45
	46	use Dpkg::Gettext;
	47	use Dpkg::File;
	48	use Dpkg::Changelog qw(:util);
	49	use Dpkg::Changelog::Entry::Debian qw(match_header match_trailer);
	50
	51	use parent qw(Dpkg::Changelog);
	52
	53	use constant {
	54	FIRST_HEADING => g_('first heading'),
	55	NEXT_OR_EOF => g_('next heading or end of file'),
	56	START_CHANGES => g_('start of change data'),
	57	CHANGES_OR_TRAILER => g_('more change data or trailer'),
	58	};
	59
	60	my $ancient_delimiter_re = qr{
	61	^
	62	(?: # Ancient GNU style changelog entry with expanded date
	63	(?:
	64	\w+\s+ # Day of week (abbreviated)
65	\w+\s+ # Month name (abbreviated)
66	\d{1,2} # Day of month
67	\Q \E
68	\d{1,2}:\d{1,2}:\d{1,2}\s+ # Time
69	[\w\s]* # Timezone
70	\d{4} # Year
71	)
72	\s+
73	(?:.*) # Maintainer name
74	\s+
75	[<\(]
76	(?:.*) # Maintainer email
77	[\)>]
78	\| # Old GNU style changelog entry with expanded date
79	(?:
80	\w+\s+ # Day of week (abbreviated)
81	\w+\s+ # Month name (abbreviated)
82	\d{1,2},?\s* # Day of month
83	\d{4} # Year
84	)
85	\s+
86	(?:.*) # Maintainer name
87	\s+
88	[<\(]
89	(?:.*) # Maintainer email
90	[\)>]
91	\| # Ancient changelog header w/o key=value options
92	(?:\w[-+0-9a-z.]*) # Package name
93	\Q \E
94	\(
95	(?:[^\(\) \t]+) # Package version
96	\)
97	\;?
98	\| # Ancient changelog header
99	(?:[\w.+-]+) # Package name
100	[- ]
101	(?:\S+) # Package version
102	\ Debian
103	\ (?:\S+) # Package revision
104	\|
105	Changes\ from\ version\ (?:.)\ to\ (?:.):
106	\|
107	Changes\ for\ [\w.+-]+-[\w.+-]+:?\s*$
108	\|
109	Old\ Changelog:\s*$
110	\|
111	(?:\d+:)?
112	\w[\w.+~-]*:?
113	\s*$
114	)
115	}xi;
116
117	=head1 METHODS
118
119	=over 4
120
121	=item $c->parse($fh, $description)
122
123	Read the filehandle and parse a Debian changelog in it. The data in the
124	object is reset before parsing new data.
125
126	Returns the number of changelog entries that have been parsed with success.
127
128	=cut
129
130	sub parse {
131	my ($self, $fh, $file) = @_;
132	$file = $self->{reportfile} if exists $self->{reportfile};
133
134	$self->reset_parse_errors;
135
136	$self->{data} = [];
137	$self->set_unparsed_tail(undef);
138
139	my $expect = FIRST_HEADING;
140	my $entry = Dpkg::Changelog::Entry::Debian->new();
141	my @blanklines = ();
142	my $unknowncounter = 1; # to make version unique, e.g. for using as id
143	local $_;
144
145	while (<$fh>) {
146	chomp;
147	if (match_header($_)) {
148	unless ($expect eq FIRST_HEADING \|\| $expect eq NEXT_OR_EOF) {
149	$self->parse_error($file, $.,
150	sprintf(g_('found start of entry where expected %s'),
151	$expect), "$_");
152	}
153	unless ($entry->is_empty) {
154	push @{$self->{data}}, $entry;
155	$entry = Dpkg::Changelog::Entry::Debian->new();
156	last if $self->abort_early();
157	}
158	$entry->set_part('header', $_);
159	foreach my $error ($entry->parse_header()) {
160	$self->parse_error($file, $., $error, $_);
161	}
162	$expect= START_CHANGES;
163	@blanklines = ();
164	} elsif (m/^(?:;;\s*)?Local variables:/io) {
165	last; # skip Emacs variables at end of file
166	} elsif (m/^vim:/io) {
167	last; # skip vim variables at end of file
168	} elsif (m/^\$\w+:.*\$/o) {
169	next; # skip stuff that look like a CVS keyword
170	} elsif (m/^\# /o) {
171	next; # skip comments, even that's not supported
172	} elsif (m{^/\.\*/}o) {
173	next; # more comments
174	} elsif (m/$ancient_delimiter_re/) {
175	# save entries on old changelog format verbatim
176	# we assume the rest of the file will be in old format once we
177	# hit it for the first time
178	$self->set_unparsed_tail("$_\n" . file_slurp($fh));
179	} elsif (m/^\S/) {
180	$self->parse_error($file, $., g_('badly formatted heading line'), "$_");
181	} elsif (match_trailer($_)) {
182	unless ($expect eq CHANGES_OR_TRAILER) {
183	$self->parse_error($file, $.,
184	sprintf(g_('found trailer where expected %s'), $expect), "$_");
185	}
186	$entry->set_part('trailer', $_);
187	$entry->extend_part('blank_after_changes', [ @blanklines ]);
188	@blanklines = ();
189	foreach my $error ($entry->parse_trailer()) {
190	$self->parse_error($file, $., $error, $_);
191	}
192	$expect = NEXT_OR_EOF;
193	} elsif (m/^ \-\-/) {
194	$self->parse_error($file, $., g_('badly formatted trailer line'), "$_");
195	} elsif (m/^\s{2,}(?:\S)/) {
196	unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
197	$self->parse_error($file, $., sprintf(g_('found change data' .
198	' where expected %s'), $expect), "$_");
199	if ($expect eq NEXT_OR_EOF and not $entry->is_empty) {
200	# lets assume we have missed the actual header line
201	push @{$self->{data}}, $entry;
202	$entry = Dpkg::Changelog::Entry::Debian->new();
203	$entry->set_part('header', 'unknown (unknown' . ($unknowncounter++) . ') unknown; urgency=unknown');
204	}
205	}
206	# Keep raw changes
207	$entry->extend_part('changes', [ @blanklines, $_ ]);
208	@blanklines = ();
209	$expect = CHANGES_OR_TRAILER;
210	} elsif (!m/\S/) {
211	if ($expect eq START_CHANGES) {
212	$entry->extend_part('blank_after_header', $_);
213	next;
214	} elsif ($expect eq NEXT_OR_EOF) {
215	$entry->extend_part('blank_after_trailer', $_);
216	next;
217	} elsif ($expect ne CHANGES_OR_TRAILER) {
218	$self->parse_error($file, $.,
219	sprintf(g_('found blank line where expected %s'), $expect));
220	}
221	push @blanklines, $_;
222	} else {
223	$self->parse_error($file, $., g_('unrecognized line'), "$_");
224	unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
225	# lets assume change data if we expected it
226	$entry->extend_part('changes', [ @blanklines, $_]);
227	@blanklines = ();
228	$expect = CHANGES_OR_TRAILER;
229	}
230	}
231	}
232
233	unless ($expect eq NEXT_OR_EOF) {
234	$self->parse_error($file, $.,
235	sprintf(g_('found end of file where expected %s'),
236	$expect));
237	}
238	unless ($entry->is_empty) {
239	push @{$self->{data}}, $entry;
240	}
241
242	return scalar @{$self->{data}};
243	}
244
245	1;
246	__END__
247
248	=back
249
250	=head1 CHANGES
251
252	=head2 Version 1.00 (dpkg 1.15.6)
253
254	Mark the module as public.
255
256	=head1 SEE ALSO
257
258	Dpkg::Changelog
259
260	=cut