123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177 |
- # Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de>
- # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
- # Copyright © 2010, 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::Parse - generic changelog parser for dpkg-parsechangelog
- =head1 DESCRIPTION
- This module provides a single function changelog_parse() which reproduces
- all the features of dpkg-parsechangelog.
- =head2 FUNCTIONS
- =cut
- package Dpkg::Changelog::Parse;
- use strict;
- use warnings;
- our $VERSION = '1.00';
- our @EXPORT = qw(
- changelog_parse
- );
- use Exporter qw(import);
- use Dpkg ();
- use Dpkg::Gettext;
- use Dpkg::ErrorHandling;
- use Dpkg::Control::Changelog;
- =over 4
- =item my $fields = changelog_parse(%opt)
- This function will parse a changelog. In list context, it return as many
- Dpkg::Control object as the parser did output. In scalar context, it will
- return only the first one. If the parser didn't return any data, it will
- return an empty in list context or undef on scalar context. If the parser
- failed, it will die.
- The parsing itself is done by an external program (searched in the
- following list of directories: $opt{libdir},
- F</usr/local/lib/dpkg/parsechangelog>, F</usr/lib/dpkg/parsechangelog>) That
- program is named according to the format that it's able to parse. By
- default it's either "debian" or the format name lookep up in the 40 last
- lines of the changelog itself (extracted with this perl regular expression
- "\schangelog-format:\s+([0-9a-z]+)\W"). But it can be overridden
- with $opt{changelogformat}. The program expects the content of the
- changelog file on its standard input.
- The changelog file that is parsed is F<debian/changelog> by default but it
- can be overridden with $opt{file}.
- All the other keys in %opt are forwarded as parameter to the external
- parser. If the key starts with "-", it's passed as is. If not, it's passed
- as "--<key>". If the value of the corresponding hash entry is defined, then
- it's passed as the parameter that follows.
- =cut
- sub changelog_parse {
- my (%options) = @_;
- my @parserpath = ('/usr/local/lib/dpkg/parsechangelog',
- "$Dpkg::LIBDIR/parsechangelog",
- '/usr/lib/dpkg/parsechangelog');
- my $format = 'debian';
- my $force = 0;
- # Extract and remove options that do not concern the changelog parser
- # itself (and that we shouldn't forward)
- if (exists $options{libdir}) {
- unshift @parserpath, $options{libdir};
- delete $options{libdir};
- }
- if (exists $options{changelogformat}) {
- $format = $options{changelogformat};
- delete $options{changelogformat};
- $force = 1;
- }
- # Set a default filename
- $options{file} //= 'debian/changelog';
- my $changelogfile = $options{file};
- # Extract the format from the changelog file if possible
- unless ($force or ($changelogfile eq '-')) {
- local $_;
- open(my $format_fh, '-|', 'tail', '-n', '40', $changelogfile)
- or syserr(g_('cannot create pipe for %s'), 'tail');
- while (<$format_fh>) {
- $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/;
- }
- close($format_fh) or subprocerr(g_('tail of %s'), $changelogfile);
- }
- # Find the right changelog parser
- my $parser;
- foreach my $dir (@parserpath) {
- my $candidate = "$dir/$format";
- next if not -e $candidate;
- if (-x _) {
- $parser = $candidate;
- last;
- } else {
- warning(g_('format parser %s not executable'), $candidate);
- }
- }
- error(g_('changelog format %s is unknown'), $format) if not defined $parser;
- # Create the arguments for the changelog parser
- my @exec = ($parser, "-l$changelogfile");
- foreach my $option (keys %options) {
- if ($option =~ m/^-/) {
- # Options passed untouched
- push @exec, $option;
- } else {
- # Non-options are mapped to long options
- push @exec, "--$option";
- }
- push @exec, $options{$option} if defined $options{$option};
- }
- # Fork and call the parser
- my $pid = open(my $parser_fh, '-|');
- syserr(g_('cannot fork for %s'), $parser) unless defined $pid;
- if (not $pid) {
- exec @exec or syserr(g_('cannot execute format parser: %s'), $parser);
- }
- # Get the output into several Dpkg::Control objects
- my (@res, $fields);
- while (1) {
- $fields = Dpkg::Control::Changelog->new();
- last unless $fields->parse($parser_fh, g_('output of changelog parser'));
- push @res, $fields;
- }
- close($parser_fh) or subprocerr(g_('changelog parser %s'), $parser);
- if (wantarray) {
- return @res;
- } else {
- return $res[0] if (@res);
- return;
- }
- }
- =back
- =head1 CHANGES
- =head2 Version 1.00
- Mark the module as public.
- =cut
- 1;
|