|
|
@@ -0,0 +1,167 @@
|
|
|
+# Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de>
|
|
|
+# Copyright © 2009 Raphaël Hertzog <hertzog@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, write to the Free Software
|
|
|
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
+
|
|
|
+=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;
|
|
|
+
|
|
|
+use Dpkg; # for $dpkglibdir
|
|
|
+use Dpkg::Gettext;
|
|
|
+use Dpkg::ErrorHandling;
|
|
|
+use Dpkg::Control::Changelog;
|
|
|
+
|
|
|
+use base qw(Exporter);
|
|
|
+our @EXPORT = qw(changelog_parse);
|
|
|
+
|
|
|
+=head3 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},
|
|
|
+/usr/local/lib/dpkg/parsechangelog, /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 overriden
|
|
|
+with $opt{changelogformat}. The program expects the content of the
|
|
|
+changelog file on its standard input.
|
|
|
+
|
|
|
+The changelog file that is parsed is debian/changelog by default but it
|
|
|
+can be overriden 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",
|
|
|
+ "$dpkglibdir/parsechangelog",
|
|
|
+ "/usr/lib/dpkg/parsechangelog");
|
|
|
+ my $format = "debian";
|
|
|
+ my $changelogfile = "debian/changelog";
|
|
|
+ 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{"file"}) {
|
|
|
+ $changelogfile = $options{"file"};
|
|
|
+ delete $options{"file"};
|
|
|
+ }
|
|
|
+ if (exists $options{"changelogformat"}) {
|
|
|
+ $format = $options{"changelogformat"};
|
|
|
+ delete $options{"changelogformat"};
|
|
|
+ $force = 1;
|
|
|
+ }
|
|
|
+ # XXX: For compatibility with old parsers, don't use --since but -v
|
|
|
+ # This can be removed later (in lenny+1 for example)
|
|
|
+ if (exists $options{"since"}) {
|
|
|
+ my $since = $options{"since"};
|
|
|
+ $options{"-v$since"} = undef;
|
|
|
+ delete $options{"since"};
|
|
|
+ }
|
|
|
+
|
|
|
+ # Extract the format from the changelog file if possible
|
|
|
+ unless($force or ($changelogfile eq "-")) {
|
|
|
+ open(P, "-|", "tail", "-n", "40", $changelogfile);
|
|
|
+ while(<P>) {
|
|
|
+ $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/;
|
|
|
+ }
|
|
|
+ close(P) 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 (keys %options) {
|
|
|
+ if (m/^-/) {
|
|
|
+ # Options passed untouched
|
|
|
+ push @exec, $_;
|
|
|
+ } else {
|
|
|
+ # Non-options are mapped to long options
|
|
|
+ push @exec, "--$_";
|
|
|
+ }
|
|
|
+ push @exec, $options{$_} if defined($options{$_});
|
|
|
+ }
|
|
|
+
|
|
|
+ # Fork and call the parser
|
|
|
+ my $pid = open(P, "-|");
|
|
|
+ syserr(_g("fork for %s"), $parser) unless defined $pid;
|
|
|
+ if (not $pid) {
|
|
|
+ if ($changelogfile ne "-") {
|
|
|
+ open(STDIN, "<", $changelogfile) or
|
|
|
+ syserr(_g("cannot open %s"), $changelogfile);
|
|
|
+ }
|
|
|
+ exec(@exec) || syserr(_g("cannot exec 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_fh(\*P, _g("output of changelog parser"));
|
|
|
+ push @res, $fields;
|
|
|
+ }
|
|
|
+ close(P) or subprocerr(_g("changelog parser %s"), $parser);
|
|
|
+ if (wantarray) {
|
|
|
+ return @res;
|
|
|
+ } else {
|
|
|
+ return $res[0] if (@res);
|
|
|
+ return undef;
|
|
|
+ }
|
|
|
+}
|
|
|
+
|
|
|
+1;
|
Raphaël Hertzog