scripts/Dpkg/Changelog/Parse.pm

   1 # Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de>
   2 # Copyright © 2009       Raphaël Hertzog <hertzog@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 <http://www.gnu.org/licenses/>.
  16
  17 =encoding utf8
  18
  19 =head1 NAME
  20
  21 Dpkg::Changelog::Parse - generic changelog parser for dpkg-parsechangelog
  22
  23 =head1 DESCRIPTION
  24
  25 This module provides a single function changelog_parse() which reproduces
  26 all the features of dpkg-parsechangelog.
  27
  28 =head2 Functions
  29
  30 =cut
  31
  32 package Dpkg::Changelog::Parse;
  33
  34 use strict;
  35 use warnings;
  36
  37 our $VERSION = "1.00";
  38
  39 use Dpkg; # for $dpkglibdir
  40 use Dpkg::Gettext;
  41 use Dpkg::ErrorHandling;
  42 use Dpkg::Control::Changelog;
  43
  44 use base qw(Exporter);
  45 our @EXPORT = qw(changelog_parse);
  46
  47 =head3 my $fields = changelog_parse(%opt)
  48
  49 This function will parse a changelog. In list context, it return as many
  50 Dpkg::Control object as the parser did output. In scalar context, it will
  51 return only the first one. If the parser didn't return any data, it will
  52 return an empty in list context or undef on scalar context. If the parser
  53 failed, it will die.
  54
  55 The parsing itself is done by an external program (searched in the
  56 following list of directories: $opt{libdir},
  57 /usr/local/lib/dpkg/parsechangelog, /usr/lib/dpkg/parsechangelog) That
  58 program is named according to the format that it's able to parse. By
  59 default it's either "debian" or the format name lookep up in the 40 last
  60 lines of the changelog itself (extracted with this perl regular expression
  61 "\schangelog-format:\s+([0-9a-z]+)\W"). But it can be overridden
  62 with $opt{changelogformat}. The program expects the content of the
  63 changelog file on its standard input.
  64
  65 The changelog file that is parsed is debian/changelog by default but it
  66 can be overridden with $opt{file}.
  67
  68 All the other keys in %opt are forwarded as parameter to the external
  69 parser. If the key starts with "-", it's passed as is. If not, it's passed
  70 as "--<key>". If the value of the corresponding hash entry is defined, then
  71 it's passed as the parameter that follows.
  72
  73 =cut
  74
  75 sub changelog_parse {
  76     my (%options) = @_;
  77     my @parserpath = ("/usr/local/lib/dpkg/parsechangelog",
  78                       "$dpkglibdir/parsechangelog",
  79                       "/usr/lib/dpkg/parsechangelog");
  80     my $format = "debian";
  81     my $changelogfile = "debian/changelog";
  82     my $force = 0;
  83
  84     # Extract and remove options that do not concern the changelog parser
  85     # itself (and that we shouldn't forward)
  86     if (exists $options{"libdir"}) {
  87         unshift @parserpath, $options{"libdir"};
  88         delete $options{"libdir"};
  89     }
  90     if (exists $options{"file"}) {
  91         $changelogfile = $options{"file"};
  92         delete $options{"file"};
  93     }
  94     if (exists $options{"changelogformat"}) {
  95         $format = $options{"changelogformat"};
  96         delete $options{"changelogformat"};
  97         $force = 1;
  98     }
  99
 100     # Extract the format from the changelog file if possible
 101     unless($force or ($changelogfile eq "-")) {
 102         open(P, "-|", "tail", "-n", "40", $changelogfile);
 103         while(<P>) {
 104             $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/;
 105         }
 106         close(P) or subprocerr(_g("tail of %s"), $changelogfile);
 107     }
 108
 109     # Find the right changelog parser
 110     my $parser;
 111     foreach my $dir (@parserpath) {
 112         my $candidate = "$dir/$format";
 113         next if not -e $candidate;
 114         if (-x _) {
 115             $parser = $candidate;
 116             last;
 117         } else {
 118             warning(_g("format parser %s not executable"), $candidate);
 119         }
 120     }
 121     error(_g("changelog format %s is unknown"), $format) if not defined $parser;
 122
 123     # Create the arguments for the changelog parser
 124     my @exec = ($parser, "-l$changelogfile");
 125     foreach (keys %options) {
 126         if (m/^-/) {
 127             # Options passed untouched
 128             push @exec, $_;
 129         } else {
 130             # Non-options are mapped to long options
 131             push @exec, "--$_";
 132         }
 133         push @exec, $options{$_} if defined($options{$_});
 134     }
 135
 136     # Fork and call the parser
 137     my $pid = open(P, "-|");
 138     syserr(_g("cannot fork for %s"), $parser) unless defined $pid;
 139     if (not $pid) {
 140         if ($changelogfile ne "-") {
 141             open(STDIN, "<", $changelogfile) or
 142                 syserr(_g("cannot open %s"), $changelogfile);
 143         }
 144         exec(@exec) || syserr(_g("cannot exec format parser: %s"), $parser);
 145     }
 146
 147     # Get the output into several Dpkg::Control objects
 148     my (@res, $fields);
 149     while (1) {
 150         $fields = Dpkg::Control::Changelog->new();
 151         last unless $fields->parse(\*P, _g("output of changelog parser"));
 152         push @res, $fields;
 153     }
 154     close(P) or subprocerr(_g("changelog parser %s"), $parser);
 155     if (wantarray) {
 156         return @res;
 157     } else {
 158         return $res[0] if (@res);
 159         return undef;
 160     }
 161 }
 162
 163 1;