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

   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;