Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | # Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de> |
2 | # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> | |
3 | # Copyright © 2010, 2012-2015 Guillem Jover <guillem@debian.org> | |
4 | # | |
5 | # This program is free software; you can redistribute it and/or modify | |
6 | # it under the terms of the GNU General Public License as published by | |
7 | # the Free Software Foundation; either version 2 of the License, or | |
8 | # (at your option) any later version. | |
9 | # | |
10 | # This program is distributed in the hope that it will be useful, | |
11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | # GNU General Public License for more details. | |
14 | # | |
15 | # You should have received a copy of the GNU General Public License | |
16 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
17 | ||
18 | =encoding utf8 | |
19 | ||
20 | =head1 NAME | |
21 | ||
22 | Dpkg::Changelog::Parse - generic changelog parser for dpkg-parsechangelog | |
23 | ||
24 | =head1 DESCRIPTION | |
25 | ||
26 | This module provides a set of functions which reproduce all the features | |
27 | of dpkg-parsechangelog. | |
28 | ||
29 | =cut | |
30 | ||
31 | package Dpkg::Changelog::Parse; | |
32 | ||
33 | use strict; | |
34 | use warnings; | |
35 | ||
36 | our $VERSION = '1.02'; | |
37 | our @EXPORT = qw( | |
38 | changelog_parse_debian | |
39 | changelog_parse_plugin | |
40 | changelog_parse | |
41 | ); | |
42 | ||
43 | use Exporter qw(import); | |
44 | ||
45 | use Dpkg (); | |
46 | use Dpkg::Util qw(none); | |
47 | use Dpkg::Gettext; | |
48 | use Dpkg::ErrorHandling; | |
49 | use Dpkg::Control::Changelog; | |
50 | ||
51 | sub _changelog_detect_format { | |
52 | my $file = shift; | |
53 | my $format = 'debian'; | |
54 | ||
55 | # Extract the format from the changelog file if possible | |
56 | if ($file ne '-') { | |
57 | local $_; | |
58 | ||
59 | open my $format_fh, '-|', 'tail', '-n', '40', $file | |
60 | or syserr(g_('cannot create pipe for %s'), 'tail'); | |
61 | while (<$format_fh>) { | |
62 | $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/; | |
63 | } | |
64 | close $format_fh or subprocerr(g_('tail of %s'), $file); | |
65 | } | |
66 | ||
67 | return $format; | |
68 | } | |
69 | ||
70 | =head1 FUNCTIONS | |
71 | ||
72 | =over 4 | |
73 | ||
74 | =item $fields = changelog_parse_debian(%opt) | |
75 | ||
76 | This function is deprecated, use changelog_parse() instead, with the changelog | |
77 | format set to "debian". | |
78 | ||
79 | =cut | |
80 | ||
81 | sub changelog_parse_debian { | |
82 | my (%options) = @_; | |
83 | ||
84 | warnings::warnif('deprecated', | |
85 | 'deprecated function changelog_parse_debian, use changelog_parse instead'); | |
86 | ||
87 | # Force the plugin to be debian. | |
88 | $options{changelogformat} = 'debian'; | |
89 | ||
90 | return _changelog_parse(%options); | |
91 | } | |
92 | ||
93 | =item $fields = changelog_parse_plugin(%opt) | |
94 | ||
95 | This function is deprecated, use changelog_parse() instead. | |
96 | ||
97 | =cut | |
98 | ||
99 | sub changelog_parse_plugin { | |
100 | my (%options) = @_; | |
101 | ||
102 | warnings::warnif('deprecated', | |
103 | 'deprecated function changelog_parse_plugin, use changelog_parse instead'); | |
104 | ||
105 | return _changelog_parse(%options); | |
106 | } | |
107 | ||
108 | =item $fields = changelog_parse(%opt) | |
109 | ||
110 | This function will parse a changelog. In list context, it returns as many | |
111 | Dpkg::Control objects as the parser did create. In scalar context, it will | |
112 | return only the first one. If the parser did not return any data, it will | |
113 | return an empty list in list context or undef on scalar context. If the | |
114 | parser failed, it will die. | |
115 | ||
116 | The changelog file that is parsed is F<debian/changelog> by default but it | |
117 | can be overridden with $opt{file}. The default output format is "dpkg" but | |
118 | it can be overridden with $opt{format}. | |
119 | ||
120 | The parsing itself is done by a parser module (searched in the standard | |
121 | perl library directories. That module is named according to the format that | |
122 | it is able to parse, with the name capitalized. By default it is either | |
123 | Dpkg::Changelog::Debian (from the "debian" format) or the format name looked | |
124 | up in the 40 last lines of the changelog itself (extracted with this perl | |
125 | regular expression "\schangelog-format:\s+([0-9a-z]+)\W"). But it can be | |
126 | overridden with $opt{changelogformat}. | |
127 | ||
128 | All the other keys in %opt are forwarded to the parser module constructor. | |
129 | ||
130 | =cut | |
131 | ||
132 | sub _changelog_parse { | |
133 | my (%options) = @_; | |
134 | ||
135 | # Setup and sanity checks. | |
136 | if (exists $options{libdir}) { | |
137 | warnings::warnif('deprecated', | |
138 | 'obsolete libdir option, changelog parsers are now perl modules'); | |
139 | } | |
140 | ||
141 | $options{file} //= 'debian/changelog'; | |
142 | $options{label} //= $options{file}; | |
143 | $options{changelogformat} //= _changelog_detect_format($options{file}); | |
144 | $options{format} //= 'dpkg'; | |
145 | ||
146 | my @range_opts = qw(since until from to offset count all); | |
147 | $options{all} = 1 if exists $options{all}; | |
148 | if (none { defined $options{$_} } @range_opts) { | |
149 | $options{count} = 1; | |
150 | } | |
151 | my $range; | |
152 | foreach my $opt (@range_opts) { | |
153 | $range->{$opt} = $options{$opt} if exists $options{$opt}; | |
154 | } | |
155 | ||
156 | # Find the right changelog parser. | |
157 | my $format = ucfirst lc $options{changelogformat}; | |
158 | my $changes; | |
159 | eval qq{ | |
160 | pop \@INC if \$INC[-1] eq '.'; | |
161 | require Dpkg::Changelog::$format; | |
162 | \$changes = Dpkg::Changelog::$format->new(); | |
163 | }; | |
164 | error(g_('changelog format %s is unknown: %s'), $format, $@) if $@; | |
165 | $changes->set_options(reportfile => $options{label}, range => $range); | |
166 | ||
167 | # Load and parse the changelog. | |
168 | $changes->load($options{file}) | |
169 | or error(g_('fatal error occurred while parsing %s'), $options{file}); | |
170 | ||
171 | # Get the output into several Dpkg::Control objects. | |
172 | my @res; | |
173 | if ($options{format} eq 'dpkg') { | |
174 | push @res, $changes->format_range('dpkg', $range); | |
175 | } elsif ($options{format} eq 'rfc822') { | |
176 | push @res, $changes->format_range('rfc822', $range); | |
177 | } else { | |
178 | error(g_('unknown output format %s'), $options{format}); | |
179 | } | |
180 | ||
181 | if (wantarray) { | |
182 | return @res; | |
183 | } else { | |
184 | return $res[0] if @res; | |
185 | return; | |
186 | } | |
187 | } | |
188 | ||
189 | sub changelog_parse { | |
190 | my (%options) = @_; | |
191 | ||
192 | if (exists $options{forceplugin}) { | |
193 | warnings::warnif('deprecated', 'obsolete forceplugin option'); | |
194 | } | |
195 | ||
196 | return _changelog_parse(%options); | |
197 | } | |
198 | ||
199 | =back | |
200 | ||
201 | =head1 CHANGES | |
202 | ||
203 | =head2 Version 1.02 (dpkg 1.18.8) | |
204 | ||
205 | Deprecated functions: changelog_parse_debian(), changelog_parse_plugin(). | |
206 | ||
207 | Obsolete options: $forceplugin, $libdir. | |
208 | ||
209 | =head2 Version 1.01 (dpkg 1.18.2) | |
210 | ||
211 | New functions: changelog_parse_debian(), changelog_parse_plugin(). | |
212 | ||
213 | =head2 Version 1.00 (dpkg 1.15.6) | |
214 | ||
215 | Mark the module as public. | |
216 | ||
217 | =cut | |
218 | ||
219 | 1; |