File: //proc/1234692/root/bin/dh_installchangelogs
#!/usr/bin/perl
=head1 NAME
dh_installchangelogs - install changelogs into package build directories
=cut
use strict;
use warnings;
use Debian::Debhelper::Dh_Lib;
use Time::Piece;
our $VERSION = DH_BUILTIN_VERSION;
=head1 SYNOPSIS
B<dh_installchangelogs> [S<I<debhelper options>>] [B<-k>] [B<-X>I<item>] [B<--no-trim>] [I<upstream>]
=head1 DESCRIPTION
B<dh_installchangelogs> is a debhelper program that is responsible for
installing changelogs into package build directories.
An upstream F<changelog> file may be specified as an option.
If a changelog file is specified and is an F<html> file (determined by file
extension), it will be installed as F<usr/share/doc/package/changelog.html>
instead. If the html changelog is converted to plain text, that variant
can be specified as a second parameter. When no plain text variant is
specified, a short F<usr/share/doc/package/changelog> is generated,
pointing readers at the html changelog file.
The B<debchange>-style Debian changelogs are trimmed to include only
entries more recent than the release date of I<oldstable>.
No trimming will be performed if the B<--no-trim> option is passed or
if the B<DEB_BUILD_OPTIONS> environment variable contains B<notrimdch>.
=head1 FILES
=over 4
=item F<debian/changelog>
=item F<debian/NEWS>
=item debian/I<package>.changelog
=item debian/I<package>.NEWS
Automatically installed into usr/share/doc/I<package>/
in the package build directory.
Use the package specific name if I<package> needs a different
F<NEWS> or F<changelog> file.
The F<changelog> file is installed with a name of changelog
for native packages, and F<changelog.Debian> for non-native packages.
The F<NEWS> file is always installed with a name of F<NEWS.Debian>.
=back
=head1 OPTIONS
=over 4
=item B<-k>, B<--keep>
Keep the original name of the upstream changelog. This will be accomplished
by installing the upstream changelog as F<changelog>, and making a symlink from
that to the original name of the F<changelog> file. This can be useful if the
upstream changelog has an unusual name, or if other documentation in the
package refers to the F<changelog> file.
=item B<-X>I<item>, B<--exclude=>I<item>
Exclude upstream F<changelog> files that contain I<item> anywhere in their
filename from being installed.
Note that directory name of the changelog is also part of the match.
=item B<--no-trim>
Install the full changelog, not its trimmed version that includes only
recent entries.
=item I<upstream>
Install this file as the upstream changelog.
=back
=cut
init(options => {
'keep|k' => \$dh{K_FLAG},
'no-trim' => \$dh{NO_TRIM},
});
my $news_name="NEWS.Debian";
my $changelog_name="changelog.Debian";
use constant CUTOFF_DATE_STR => "2019-07-06"; # oldstable = Debian 10 Buster
use constant CUTOFF_DATE => Time::Piece->strptime(CUTOFF_DATE_STR, "%Y-%m-%d");
use constant MIN_NUM_ENTRIES => 4;
my $explicit_changelog = @ARGV ? 1 : 0;
my $default_upstream = $ARGV[0];
my $default_upstream_text=$default_upstream;
my $default_upstream_html;
if (! defined($default_upstream)) {
if (isnative($dh{MAINPACKAGE})) {
$changelog_name='changelog';
}
}
elsif ($default_upstream=~m/\.html?$/i) {
$default_upstream_html=$default_upstream;
$default_upstream_text=$ARGV[1];
}
sub find_changelog {
my ($dir) = @_;
my @files=sort glob("$dir/*");
foreach my $suffix ('', qw(.txt .md .rst)) {
foreach my $name (qw{changelog changes history}) {
my @matches=grep {
lc basename($_) eq "$name$suffix" && -f $_ && -s _ && ! excludefile($_)
} @files;
if (@matches) {
return shift(@matches);
}
}
}
return;
}
sub install_debian_changelog {
my ($changelog, $package, $arch, $tmp) = @_;
my $changelog_trimmed = generated_file($package, "dh_installchangelogs.dch.trimmed");
my $changelog_binnmu = generated_file($package, "dh_installchangelogs.dch.binnmu");
my ($error_in_changelog, $has_been_trimmed, $oldest_entry_time) =
prepare_changesfile("CHANGELOG", $changelog, $changelog_trimmed, $changelog_binnmu);
if ($error_in_changelog) {
# If the changelog could not be trimmed, fall back to the full changelog.
warning("$changelog could not be trimmed. The full changelog will be installed.");
$changelog_trimmed = $changelog;
} elsif ($has_been_trimmed) {
# Otherwise add a comment stating that this changelog has been trimmed.
my $note = "\n";
$note .= "# Older entries have been removed from this changelog.\n";
$note .= "# To read the complete changelog use `apt changelog $package`.\n";
open(my $log2, ">>", $changelog_trimmed) or error("Cannot open($changelog_trimmed): $!");
print($log2 $note) or error("Cannot write($changelog_trimmed): $!");
close($log2) or error("Cannot close($changelog_trimmed): $!");
}
install_file($changelog_trimmed, "$tmp/usr/share/doc/$package/$changelog_name");
if (-s $changelog_binnmu) {
install_file($changelog_binnmu, "$tmp/usr/share/doc/$package/$changelog_name.$arch");
}
return $oldest_entry_time;
}
sub install_debian_news {
my ($news, $package, $oldest_log_entry_time, $tmp) = @_;
if ($dh{NO_TRIM} || get_buildoption("notrimdch") || !defined($oldest_log_entry_time)) {
# Install the whole NEWS file.
install_file($news, "$tmp/usr/share/doc/$package/$news_name");
return;
}
my $news_trimmed = generated_file($package, "dh_installchangelogs.news.trimmed");
my ($error_in_news, $has_been_trimmed, $oldest_entry_time) =
prepare_changesfile("NEWS", $news, $news_trimmed, undef, $oldest_log_entry_time);
if ($error_in_news) {
# If the NEWS file could not be trimmed, fall back to the full NEWS file.
warning("$news could not be trimmed. The full NEWS file will be installed.");
$news_trimmed = $news;
}
# Install NEWS unless there are no recent news.
install_file($news_trimmed, "$tmp/usr/share/doc/$package/$news_name")
unless (-z $news_trimmed);
}
sub prepare_changesfile {
my ($mode, $changesfile, $changesfile_trimmed, $changelog_binnmu, $oldest_log_entry_time) = @_;
local $ENV{LC_ALL} = "C.UTF-8";
my $should_be_trimmed = !$dh{NO_TRIM} && !get_buildoption("notrimdch");
open(my $log1, "<", $changesfile) or error("Cannot open($changesfile): $!");
open(my $log2, ">", $changesfile_trimmed) or error("Cannot open($changesfile_trimmed): $!");
my $oldest_entry_time;
my $error_in_changesfile = 0;
my $is_binnmu = 0;
my $entry = "";
my $entry_num = 0;
while (my $line=<$log1>) {
$entry .= $line;
# Identify binNUM packages by binary-only=yes in the first line of the changelog.
if (($. == 1) && ($line =~ /\A\S.*;.*\bbinary-only=yes/)) {
$is_binnmu = 1;
}
# Get out of binNMU mode once we are in the second entry (and throw away one empty line).
if ($is_binnmu && ($entry_num eq 1)) {
$is_binnmu = 0;
$entry_num = 0;
$entry = "";
next;
}
if ($line =~ /^\s*--\s+.*?\s+<[^>]*>\s+(?<timestamp>.*)$/) {
if ($is_binnmu && ($entry_num eq 0)) {
# For binNMUs the first changelog entry is written into an extra file to
# keep the packages coinstallable.
open(my $log_binnum, ">", $changelog_binnmu) or error("Cannot open($changelog_binnmu): $!");
print($log_binnum $entry) or error("Cannot write($changelog_binnmu): $!");
close($log_binnum) or error("Cannot close($changelog_binnmu): $!");
# Continue processing the rest of the changelog.
$entry = "";
$entry_num++;
next;
}
my $timestamp = $+{timestamp};
$timestamp =~ s/^[A-Za-z]+, +//;
my $entry_time;
eval { $entry_time = Time::Piece->strptime($timestamp, '%d %b %Y %T %z') };
if (! defined $entry_time) {
$error_in_changesfile = 1;
warning("Could not parse timestamp '$timestamp'. $changesfile will not be trimmed.");
truncate($log2, 0) or error("Cannot truncate($changesfile_trimmed): $!");
last;
}
# Stop processing the changelog if we reached the cut-off date and
# at least MIN_NUM_ENTRIES entries have been added.
if ($should_be_trimmed && ($mode eq "CHANGELOG") && ($entry_time < CUTOFF_DATE) && ($entry_num >= MIN_NUM_ENTRIES)) {
last;
}
# Stop processing the NEWS file if we reached the oldest date in the changelog.
if ($should_be_trimmed && ($mode eq "NEWS") && ($entry_time < $oldest_log_entry_time)) { last; }
# Record the timestamp of what is currently the oldest entry
# in the trimmed changelog.
$oldest_entry_time = $entry_time;
# Append entry to trimmed changelog.
print($log2 $entry) or error("Cannot write($changesfile_trimmed): $!");
$entry = "";
$entry_num++;
}
}
# If the whole changelog has not been read, then it has been trimmed.
my $has_been_trimmed = !eof($log1);
close($log1) or error("Cannot close($changesfile): $!");
close($log2) or error("Cannot close($changesfile_trimmed): $!");
return $error_in_changesfile, $has_been_trimmed, $oldest_entry_time
}
# INTROSPECTABLE: CONFIG-FILES pkgfile(changelog) pkgfile(NEWS)
on_pkgs_in_parallel {
foreach my $package (@_) {
next if is_udeb($package);
my $tmp=tmpdir($package);
my $changelog=pkgfile($package,"changelog");
my $news=pkgfile($package,"NEWS");
my $upstream_changelog;
my ($upstream_changelog_text, $upstream_changelog_html);
my $changelog_from_tmp_dir = 0;
if ($explicit_changelog) {
$upstream_changelog = $default_upstream;
$upstream_changelog_text = $default_upstream_text;
$upstream_changelog_html = $default_upstream_html;
}
if (!$changelog) {
$changelog="debian/changelog";
}
if (!$news) {
$news="debian/NEWS";
}
if (! -e $changelog) {
error("could not find changelog $changelog");
}
# If it is a symlink to a documentation directory from the same
# source package, then don't do anything. Think multi-binary
# packages that depend on each other and want to link doc dirs.
if (-l "$tmp/usr/share/doc/$package") {
my $linkval=readlink("$tmp/usr/share/doc/$package");
my %allpackages=map { $_ => 1 } getpackages();
if ($allpackages{basename($linkval)}) {
next;
}
# Even if the target doesn't seem to be a doc dir from the
# same source package, don't do anything if it's a dangling
# symlink.
next unless -d "$tmp/usr/share/doc/$package";
}
install_dir("$tmp/usr/share/doc/$package");
my $oldest_log_entry_time;
if (! $dh{NO_ACT}) {
my $arch = package_binary_arch($package);
$oldest_log_entry_time = install_debian_changelog($changelog, $package, $arch, $tmp);
}
if (-e $news && ! $dh{NO_ACT}) {
install_debian_news($news, $package, $oldest_log_entry_time, $tmp);
}
if (defined($upstream_changelog)) {
my $link_to;
my $base="$tmp/usr/share/doc/$package";
if (defined($upstream_changelog_text)) {
if ($changelog_from_tmp_dir and not $dh{K_FLAG}) {
# mv (unless if it is the same file)
rename_path($upstream_changelog_text, "$base/changelog")
if basename($upstream_changelog_text) ne 'changelog';
reset_perm_and_owner(0644, "$base/changelog");
} else {
install_file($upstream_changelog_text, "$base/changelog");
}
$link_to='changelog';
}
if (defined($upstream_changelog_html)) {
if ($changelog_from_tmp_dir and not $dh{K_FLAG}) {
# mv (unless if it is the same file)
rename_path($upstream_changelog_html, "$base/changelog.html")
if basename($upstream_changelog_text) ne 'changelog.html';
reset_perm_and_owner(0644, "$base/changelog.html");
} else {
install_file($upstream_changelog_html,"$base/changelog.html");
}
$link_to='changelog.html';
if (! defined($upstream_changelog_text)) {
complex_doit("echo 'See changelog.html.gz' > $base/changelog");
reset_perm_and_owner(0644,"$base/changelog");
}
}
if ($dh{K_FLAG}) {
# Install symlink to original name of the upstream changelog file.
# Use basename in case original file was in a subdirectory or something.
doit('ln', '-sf', $link_to, "$tmp/usr/share/doc/$package/".basename($upstream_changelog));
}
}
}
};
=head1 SEE ALSO
L<debhelper(7)>
This program is a part of debhelper.
=head1 AUTHOR
Joey Hess <[email protected]>
=cut