horok/devscripts
1
0
Fork 0
Code Activity
devscripts/scripts/debchange.pl
Daniel Baumann b543f2e88d
Adding upstream version 2.25.15. 
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
2025-06-21 11:04:07 +02:00

1945 lines
67 KiB
Perl
Executable file
Raw Permalink Blame History

#!/usr/bin/perl
# vim: set ai shiftwidth=4 tabstop=4 expandtab:
# debchange: update the debian changelog using your favorite visual editor
# For options, see the usage message below.
#
# When creating a new changelog section, if either of the environment
# variables DEBEMAIL or EMAIL is set, debchange will use this as the
# uploader's email address (with the former taking precedence), and if
# DEBFULLNAME or NAME is set, it will use this as the uploader's full name.
# Otherwise, it will take the standard values for the current user or,
# failing that, just copy the values from the previous changelog entry.
#
# Originally by Christoph Lameter <clameter@debian.org>
# Modified extensively by Julian Gilbey <jdg@debian.org>
#
# Copyright 1999-2005 by Julian Gilbey
#
# 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/>.
use 5.008; # We're using PerlIO layers
use strict;
use warnings;
use open ':utf8'; # changelogs are written with UTF-8 encoding
use filetest 'access'; # use access rather than stat for -w
# for checking whether user names are valid and making format() behave
use Encode qw/decode_utf8 encode_utf8/;
use Getopt::Long qw(:config bundling permute no_getopt_compat);
use File::Copy;
use File::Basename;
use Cwd;
use Dpkg::Vendor qw(get_current_vendor);
use Dpkg::Changelog::Parse qw(changelog_parse);
use Dpkg::Control;
use Dpkg::Version;
use Devscripts::Compression;
use Devscripts::Debbugs;
use POSIX qw(locale_h strftime);
setlocale(LC_TIME, "C"); # so that strftime is locale independent
# Predeclare functions
sub fatal($);
my $warnings = 0;
# And global variables
my $progname = basename($0);
my $modified_conf_msg;
my %env;
my $CHGLINE; # used by the format O section at the end
my $compression_re = compression_get_file_extension_regex();
my $debian_distro_info;
sub get_debian_distro_info {
return $debian_distro_info if defined $debian_distro_info;
eval { require Debian::DistroInfo; };
if ($@) {
printf "libdistro-info-perl is not installed, Debian release names "
. "are not known.\n";
$debian_distro_info = 0;
} else {
$debian_distro_info = DebianDistroInfo->new();
}
return $debian_distro_info;
}
my $ubuntu_distro_info;
sub get_ubuntu_distro_info {
return $ubuntu_distro_info if defined $ubuntu_distro_info;
eval { require Debian::DistroInfo; };
if ($@) {
printf "libdistro-info-perl is not installed, Ubuntu release names "
. "are not known.\n";
$ubuntu_distro_info = 0;
} else {
$ubuntu_distro_info = UbuntuDistroInfo->new();
}
return $ubuntu_distro_info;
}
sub get_ubuntu_devel_distro {
my $ubu_info = get_ubuntu_distro_info();
if ($ubu_info == 0 or !$ubu_info->devel()) {
warn "$progname warning: Unable to determine the current Ubuntu "
. "development release. Using UNRELEASED instead.\n";
return 'UNRELEASED';
} else {
return $ubu_info->devel();
}
}
sub usage () {
print <<"EOF";
Usage: $progname [options] [changelog entry]
Options:
-a, --append
Append a new entry to the current changelog
-i, --increment
Increase the Debian release number, adding a new changelog entry
-v <version>, --newversion=<version>
Add a new changelog entry with version number specified
-e, --edit
Don't change version number or add a new changelog entry, just
opens an editor
-r, --release
Update the changelog timestamp. If the distribution is set to
"UNRELEASED", change it to unstable (or another distribution as
specified by --distribution, or the name of the current development
release when run under Ubuntu).
--force-save-on-release
When --release is used and an editor opened to allow inspection
of the changelog, require the user to save the changelog their
editor opened. Otherwise, the original changelog will not be
modified. (default)
--no-force-save-on-release
Do not do so. Note that a dummy changelog entry may be supplied
in order to achieve the same effect - e.g. $progname --release ""
The entry will not be added to the changelog but its presence will
suppress the editor
--create
Create a new changelog (default) or NEWS file (with --news) and
open for editing
--empty
When creating a new changelog, don't add any changes to it
(i.e. only include the header and trailer lines)
--package <package>
Specify the package name when using --create (optional)
--auto-nmu
Attempt to intelligently determine whether a change to the
changelog represents an NMU (default)
--no-auto-nmu
Do not do so
-n, --nmu
Increment the Debian release number for a non-maintainer upload
--bin-nmu
Increment the Debian release number for a binary non-maintainer upload
-q, --qa
Increment the Debian release number for a Debian QA Team upload
-R, --rebuild
Increment the Debian release number for a no-change rebuild
-s, --security
Increment the Debian release number for a Debian Security Team upload
--lts
Increment the Debian release number for a LTS Security Team upload
--team
Increment the Debian release number for a team upload
-U, --upstream
Increment the Debian release number without any appended derivative
distribution name
--bpo
Increment the Debian release number for a backports upload
to "bookworm-backports"
--sloppy
Increment the Debian release number for a sloppy backports upload
to "bullseye-backports-sloppy"
--stable
Increment the Debian release number for a stable upload.
-l, --local <suffix>
Add a suffix to the Debian version number for a local build
-b, --force-bad-version
Force a version to be less than the current one (e.g., when
backporting)
--allow-lower-version <pattern>
Allow a version to be less than the current one (e.g., when
backporting) if it matches the specified pattern
--force-distribution
Force the provided distribution to be used, even if it doesn't match
the list of known distributions
--closes nnnnn[,nnnnn,...]
Add entries for closing these bug numbers,
getting bug titles from the BTS (bug-tracking system, bugs.debian.org)
--[no]query
[Don\'t] try contacting the BTS to get bug titles (default: do query)
-d, --fromdirname
Add a new changelog entry with version taken from the directory name
-p, --preserve
Preserve the directory name
--no-preserve
Do not preserve the directory name (default)
--vendor <vendor>
Override the distributor ID from dpkg-vendor.
-D, --distribution <dist>
Use the specified distribution in the changelog entry being edited
-u, --urgency <urgency>
Use the specified urgency in the changelog entry being edited
-c, --changelog <changelog>
Specify the name of the changelog to use in place of debian/changelog
No directory traversal or checking is performed in this case.
--news <newsfile>
Specify that the newsfile (default debian/NEWS) is to be edited
--[no]multimaint
When appending an entry to a changelog section (-a), [do not]
indicate if multiple maintainers are now involved (default: do so)
--[no]multimaint-merge
When appending an entry to a changelog section, [do not] merge the
entry into an existing changelog section for the current author.
(default: do merge)
-m, --maintmaint
Don\'t change (maintain) the maintainer details in the changelog entry
-M, --controlmaint
Use maintainer name and email from the debian/control Maintainer field
-t, --mainttrailer
Don\'t change (maintain) the trailer line in the changelog entry; i.e.
maintain the maintainer and date/time details
--check-dirname-level N
How much to check directory names:
N=0 never
N=1 only if program changes directory (default)
N=2 always
--check-dirname-regex REGEX
What constitutes a matching directory name; REGEX is
a Perl regular expression; the string \`PACKAGE\' will
be replaced by the package name; see manpage for details
(default: 'PACKAGE(-.+)?')
--no-conf, --noconf
Don\'t read devscripts config files; must be the first option given
--release-heuristic log|changelog
Select heuristic used to determine if a package has been released.
(default: changelog)
--date <date>
Use the specified date in the changelog entry being edited.
The date must be in RFC 5322 format, i.e. as produced by \'date -R\'.
--help, -h
Display this help message and exit
--version
Display version information
At most one of -a, -i, -e, -r, -v, -d, -n, --bin-nmu, -q, --qa, -R, -s,
--lts, --team, --bpo, --sloppy, --stable, -l (or their long equivalents) may be used.
With no options, one of -i or -a is chosen by looking at the release
specified in the changelog.
Default settings modified by devscripts configuration files:
$modified_conf_msg
EOF
}
sub version () {
print <<"EOF";
This is $progname, from the Debian devscripts package, version 2.17.10
This code is copyright 1999-2003 by Julian Gilbey, all rights reserved.
Based on code by Christoph Lameter.
This program comes with ABSOLUTELY NO WARRANTY.
You are free to redistribute this code under the terms of the
GNU General Public License, version 2 or later.
EOF
}
# Start by setting default values
my $check_dirname_level = 1;
my $check_dirname_regex = 'PACKAGE(-.+)?';
my $opt_p = 0;
my $opt_query = 1;
my $opt_release_heuristic = 'changelog';
my $opt_release_heuristic_re = '^(changelog|log)$';
my $opt_multimaint = 1;
my $opt_multimaint_merge = 1;
my $opt_tz = undef;
my $opt_t = '';
my $opt_allow_lower = '';
my $opt_auto_nmu = 1;
my $opt_force_save_on_release = 1;
my $opt_vendor = undef;
my $opt_date = undef;
# Next, read configuration files and then command line
# The next stuff is boilerplate
if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
$modified_conf_msg = " (no configuration files read)";
shift;
} else {
my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
my %config_vars = (
'DEBCHANGE_PRESERVE' => 'no',
'DEBCHANGE_QUERY_BTS' => 'yes',
'DEVSCRIPTS_CHECK_DIRNAME_LEVEL' => 1,
'DEVSCRIPTS_CHECK_DIRNAME_REGEX' => 'PACKAGE(-.+)?',
'DEBCHANGE_RELEASE_HEURISTIC' => 'changelog',
'DEBCHANGE_MULTIMAINT' => 'yes',
'DEBCHANGE_TZ' => $ENV{TZ}, # undef if TZ unset
'DEBCHANGE_MULTIMAINT_MERGE' => 'yes',
'DEBCHANGE_MAINTTRAILER' => '',
'DEBCHANGE_LOWER_VERSION_PATTERN' => '',
'DEBCHANGE_AUTO_NMU' => 'yes',
'DEBCHANGE_FORCE_SAVE_ON_RELEASE' => 'yes',
'DEBCHANGE_VENDOR' => '',
);
$config_vars{'DEBCHANGE_TZ'} ||= '';
my %config_default = %config_vars;
my $shell_cmd;
# Set defaults
foreach my $var (keys %config_vars) {
$shell_cmd .= qq[$var="$config_vars{$var}";\n];
}
$shell_cmd .= 'for file in ' . join(" ", @config_files) . "; do\n";
$shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
# Read back values
foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
my $shell_out = `/bin/bash -c '$shell_cmd'`;
@config_vars{ keys %config_vars } = split /\n/, $shell_out, -1;
# Check validity
$config_vars{'DEBCHANGE_PRESERVE'} =~ /^(yes|no)$/
or $config_vars{'DEBCHANGE_PRESERVE'} = 'no';
$config_vars{'DEBCHANGE_QUERY_BTS'} =~ /^(yes|no)$/
or $config_vars{'DEBCHANGE_QUERY_BTS'} = 'yes';
$config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} =~ /^[012]$/
or $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} = 1;
$config_vars{'DEBCHANGE_RELEASE_HEURISTIC'} =~ $opt_release_heuristic_re
or $config_vars{'DEBCHANGE_RELEASE_HEURISTIC'} = 'changelog';
$config_vars{'DEBCHANGE_MULTIMAINT'} =~ /^(yes|no)$/
or $config_vars{'DEBCHANGE_MULTIMAINT'} = 'yes';
$config_vars{'DEBCHANGE_MULTIMAINT_MERGE'} =~ /^(yes|no)$/
or $config_vars{'DEBCHANGE_MULTIMAINT_MERGE'} = 'yes';
$config_vars{'DEBCHANGE_AUTO_NMU'} =~ /^(yes|no)$/
or $config_vars{'DEBCHANGE_AUTO_NMU'} = 'yes';
$config_vars{'DEBCHANGE_FORCE_SAVE_ON_RELEASE'} =~ /^(yes|no)$/
or $config_vars{'DEBCHANGE_FORCE_SAVE_ON_RELEASE'} = 'yes';
foreach my $var (sort keys %config_vars) {
if ($config_vars{$var} ne $config_default{$var}) {
$modified_conf_msg .= " $var=$config_vars{$var}\n";
}
}
$modified_conf_msg ||= " (none)\n";
chomp $modified_conf_msg;
$opt_p = $config_vars{'DEBCHANGE_PRESERVE'} eq 'yes' ? 1 : 0;
$opt_query = $config_vars{'DEBCHANGE_QUERY_BTS'} eq 'no' ? 0 : 1;
$check_dirname_level = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'};
$check_dirname_regex = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_REGEX'};
$opt_release_heuristic = $config_vars{'DEBCHANGE_RELEASE_HEURISTIC'};
$opt_multimaint = $config_vars{'DEBCHANGE_MULTIMAINT'} eq 'no' ? 0 : 1;
$opt_tz = $config_vars{'DEBCHANGE_TZ'};
$opt_multimaint_merge
= $config_vars{'DEBCHANGE_MULTIMAINT_MERGE'} eq 'no' ? 0 : 1;
$opt_t = ($config_vars{'DEBCHANGE_MAINTTRAILER'} eq 'no' ? 0 : 1)
if $config_vars{'DEBCHANGE_MAINTTRAILER'};
$opt_allow_lower = $config_vars{'DEBCHANGE_LOWER_VERSION_PATTERN'};
$opt_auto_nmu = $config_vars{'DEBCHANGE_AUTO_NMU'} eq 'yes';
$opt_force_save_on_release
= $config_vars{'DEBCHANGE_FORCE_SAVE_ON_RELEASE'} eq 'yes' ? 1 : 0;
$opt_vendor = $config_vars{'DEBCHANGE_VENDOR'};
}
# We use bundling so that the short option behaviour is the same as
# with older debchange versions.
my ($opt_help, $opt_version);
my (
$opt_i, $opt_a, $opt_e, $opt_r, $opt_v,
$opt_b, $opt_d, $opt_D, $opt_u, $opt_force_dist
);
my (
$opt_n, $opt_bn, $opt_qa, $opt_R, $opt_s,
$opt_lts, $opt_team, $opt_U, $opt_bpo, $opt_sloppy,
$opt_stable, $opt_l, $opt_c, $opt_m, $opt_M,
$opt_create, $opt_package, @closes
);
my ($opt_news);
my ($opt_noconf, $opt_empty);
Getopt::Long::Configure('bundling');
GetOptions(
"help|h" => \$opt_help,
"version" => \$opt_version,
"i|increment" => \$opt_i,
"a|append" => \$opt_a,
"e|edit" => \$opt_e,
"r|release" => \$opt_r,
"create" => \$opt_create,
"package=s" => \$opt_package,
"v|newversion=s" => \$opt_v,
"b|force-bad-version" => \$opt_b,
"allow-lower-version=s" => \$opt_allow_lower,
"force-distribution" => \$opt_force_dist,
"d|fromdirname" => \$opt_d,
"p" => \$opt_p,
"preserve!" => \$opt_p,
"D|distribution=s" => \$opt_D,
"u|urgency=s" => \$opt_u,
"n|nmu" => \$opt_n,
"bin-nmu" => \$opt_bn,
"q|qa" => \$opt_qa,
"R|rebuild" => \$opt_R,
"s|security" => \$opt_s,
"team" => \$opt_team,
"U|upstream" => \$opt_U,
"bpo" => \$opt_bpo,
"sloppy" => \$opt_sloppy,
"lts" => \$opt_lts,
"stable" => \$opt_stable,
"l|local=s" => \$opt_l,
"query!" => \$opt_query,
"closes=s" => \@closes,
"c|changelog=s" => \$opt_c,
"news:s" => \$opt_news,
"multimaint!" => \$opt_multimaint,
"multi-maint!" => \$opt_multimaint,
'multimaint-merge!' => \$opt_multimaint_merge,
'multi-maint-merge!' => \$opt_multimaint_merge,
"m|maintmaint" => \$opt_m,
"M|controlmaint" => \$opt_M,
"t|mainttrailer!" => \$opt_t,
"check-dirname-level=s" => \$check_dirname_level,
"check-dirname-regex=s" => \$check_dirname_regex,
"noconf" => \$opt_noconf,
"no-conf" => \$opt_noconf,
"release-heuristic=s" => \$opt_release_heuristic,
"empty" => \$opt_empty,
"auto-nmu!" => \$opt_auto_nmu,
"force-save-on-release!" => \$opt_force_save_on_release,
"vendor=s" => \$opt_vendor,
"date=s" => \$opt_date,
)
or die
"Usage: $progname [options] [changelog entry]\nRun $progname --help for more details\n";
# So that we can distinguish, if required, between an explicit
# passing of -a / -i and their values being automagically deduced
# later on
my $opt_a_passed = $opt_a || 0;
my $opt_i_passed = $opt_i || 0;
$opt_news = 'debian/NEWS' if defined $opt_news and $opt_news eq '';
if ($opt_t eq '' && $opt_release_heuristic eq 'changelog') {
$opt_t = 1;
}
if ($opt_noconf) {
fatal "--no-conf is only acceptable as the first command-line option!";
}
if ($opt_help) { usage; exit 0; }
if ($opt_version) { version; exit 0; }
if ($check_dirname_level !~ /^[012]$/) {
fatal "Unrecognised --check-dirname-level value (allowed are 0,1,2)";
}
if ($opt_release_heuristic !~ $opt_release_heuristic_re) {
fatal "Allowed values for --release-heuristics are log and changelog.";
}
# Only allow at most one non-help option
fatal
"Only one of -a, -i, -e, -r, -v, -d, -n/--nmu, --bin-nmu, -q/--qa, -R/--rebuild, -s/--security, --lts, --team, --bpo, --sloppy, --stable, -l/--local is allowed;\ntry $progname --help for more help"
if ($opt_i ? 1 : 0)
+ ($opt_a ? 1 : 0)
+ ($opt_e ? 1 : 0)
+ ($opt_r ? 1 : 0)
+ ($opt_v ? 1 : 0)
+ ($opt_d ? 1 : 0)
+ ($opt_n ? 1 : 0)
+ ($opt_bn ? 1 : 0)
+ ($opt_qa ? 1 : 0)
+ ($opt_R ? 1 : 0)
+ ($opt_s ? 1 : 0)
+ ($opt_lts ? 1 : 0)
+ ($opt_team ? 1 : 0)
+ ($opt_bpo ? 1 : 0)
+ ($opt_sloppy ? 1 : 0)
+ ($opt_stable ? 1 : 0)
+ ($opt_l ? 1 : 0) > 1;
# FIXME shouldn't this be later so that the user can override the urgency,
# e.g. "-s -ulow" ?
if ($opt_s || $opt_lts) {
$opt_u = "high";
}
if (defined $opt_u) {
fatal "Urgency can only be one of: low, medium, high, critical, emergency"
unless $opt_u =~ /^(low|medium|high|critical|emergency)$/;
}
# See if we're Debian, Ubuntu or someone else, if we can
my $vendor;
if (defined $opt_vendor && $opt_vendor) {
$vendor = $opt_vendor;
} else {
if (defined $opt_D) {
# Try to guess the vendor based on the given distribution name
my $distro = $opt_D;
$distro =~ s/-.*//;
my $deb_info = get_debian_distro_info();
my $ubu_info = get_ubuntu_distro_info();
if ($deb_info != 0 and $deb_info->valid($distro)) {
$vendor = 'Debian';
} elsif ($ubu_info != 0 and $ubu_info->valid($distro)) {
$vendor = 'Ubuntu';
}
}
if (not defined $vendor) {
# Get the vendor from dpkg-vendor (dpkg-vendor --query Vendor)
$vendor = get_current_vendor();
}
}
$vendor ||= 'Debian';
if (
$vendor eq 'Ubuntu'
and ( $opt_n
or $opt_bn
or $opt_qa
or $opt_bpo
or $opt_sloppy
or $opt_stable
or $opt_lts)
) {
$vendor = 'Debian';
}
# Check the distro name given.
if (defined $opt_D) {
if ($vendor eq 'Debian') {
unless ($opt_D
=~ /^(experimental|unstable|sid|UNRELEASED|((old){0,2}stable|testing|buster|bullseye|bookworm|trixie)(-proposed-updates|-security)?|proposed-updates)$/
) {
my $deb_info = get_debian_distro_info();
my ($oldstable_backports, $stable_backports) = ("", "");
if ($deb_info == 0) {
warn
"$progname warning: Unable to determine Debian's backport distributions.\n";
} else {
$stable_backports = $deb_info->stable() . "-backports";
# Silence any potential warnings $deb_info emits when oldstable is no longer supported
local $SIG{__WARN__} = sub { };
my $oldstable = $deb_info->old();
$oldstable_backports = "$oldstable-backports" if $oldstable;
}
if ( $deb_info == 0
|| $opt_D
!~ m/^(\Q$stable_backports\E|\Q$oldstable_backports\E)$/) {
$stable_backports = ", " . $stable_backports
if $stable_backports;
$oldstable_backports = ", " . $oldstable_backports
if $oldstable_backports;
warn "$progname warning: Recognised distributions are: \n"
. "experimental, unstable, testing, stable, oldstable, oldoldstable,\n"
. "{trixie,bookworm,bullseye,buster}-proposed-updates,\n"
. "{testing,stable,oldstable,oldoldstable}-proposed-updates,\n"
. "{trixie,bookworm,bullseye,buster}-security,\n"
. "{testing,stable,oldstable,oldoldstable}}-security$oldstable_backports$stable_backports and UNRELEASED.\n"
. "Using your request anyway.\n";
$warnings++ if not $opt_force_dist;
}
}
} elsif ($vendor eq 'Ubuntu') {
if ($opt_D eq 'UNRELEASED') {
;
} else {
my $ubu_release = $opt_D;
$ubu_release =~ s/(-updates|-security|-proposed|-backports)$//;
my $ubu_info = get_ubuntu_distro_info();
if ($ubu_info == 0) {
warn "$progname warning: Unable to determine if $ubu_release "
. "is a valid Ubuntu release.\n";
} elsif (!$ubu_info->valid($ubu_release)) {
warn "$progname warning: Recognised distributions are:\n{"
. join(',', $ubu_info->supported())
. "}{,-updates,-security,-proposed,-backports} and UNRELEASED.\n"
. "Using your request anyway.\n";
$warnings++ if not $opt_force_dist;
}
}
} else {
# Unknown vendor, skip check
}
}
fatal
"--closes should not be used with --news; put bug numbers in the changelog not the NEWS file"
if $opt_news && @closes;
# hm, this can probably be used with more than just -i.
fatal "--package can only be used with --create, --increment and --newversion"
if $opt_package && !($opt_create || $opt_i || $opt_v);
my $changelog_path = $opt_c || $ENV{'CHANGELOG'} || 'debian/changelog';
my $real_changelog_path = $changelog_path;
if ($opt_news) { $changelog_path = $opt_news; }
if ($changelog_path ne 'debian/changelog' and not $opt_news) {
$check_dirname_level = 0;
}
# extra --create checks
fatal "--package cannot be used when creating a NEWS file"
if $opt_package && $opt_news;
if ($opt_create) {
if ( $opt_a
|| $opt_i
|| $opt_e
|| $opt_r
|| $opt_b
|| $opt_n
|| $opt_bn
|| $opt_qa
|| $opt_R
|| $opt_s
|| $opt_lts
|| $opt_team
|| $opt_bpo
|| $opt_sloppy
|| $opt_stable
|| $opt_l
|| $opt_allow_lower) {
warn
"$progname warning: ignoring -a/-i/-e/-r/-b/--allow-lower-version/-n/--bin-nmu/-q/--qa/-R/-s/--lts/--team/--bpo/--sloppy/--stable,-l options with --create\n";
$warnings++;
}
if ($opt_package && $opt_d) {
fatal "Can only use one of --package and -d";
}
}
@closes = split(/,/, join(',', @closes));
map { s/^\#//; } @closes; # remove any leading # from bug numbers
# We'll process the rest of the command line later.
# Look for the changelog
my $chdir = 0;
if (!$opt_create) {
if ($changelog_path eq 'debian/changelog' or $opt_news) {
until (-f $changelog_path) {
$chdir = 1;
chdir '..' or fatal "Can't chdir ..: $!";
if (cwd() eq '/') {
fatal
"Cannot find $changelog_path anywhere!\nAre you in the source code tree?\n(You could use --create if you wish to create this file.)";
}
}
# Can't write, so stop now.
if (!-w $changelog_path) {
fatal "$changelog_path is not writable!";
}
} else {
unless (-f $changelog_path) {
fatal
"Cannot find $changelog_path!\nAre you in the correct directory?\n(You could use --create if you wish to create this file.)";
}
# Can't write, so stop now.
if (!-w $changelog_path) {
fatal "$changelog_path is not writable!";
}
}
} else { # $opt_create
unless (-d dirname $changelog_path) {
fatal "Cannot find "
. (dirname $changelog_path)
. " directory!\nAre you in the correct directory?";
}
if (-f $changelog_path) {
fatal "File $changelog_path already exists!";
}
unless (-w dirname $changelog_path) {
fatal "Cannot find "
. (dirname $changelog_path)
. " directory!\nAre you in the correct directory?";
}
if ($opt_news && !-f 'debian/changelog') {
fatal "I can't create $opt_news without debian/changelog present";
}
}
#####
# Find the current version number etc.
my $changelog;
my $PACKAGE = 'PACKAGE';
my $VERSION = 'VERSION';
my $MAINTAINER = 'MAINTAINER';
my $EMAIL = 'EMAIL';
my $DISTRIBUTION = 'UNRELEASED';
# when updating the lines below also update the help text, the manpage and the testcases.
my %dists = (10, 'buster', 11, 'bullseye', 12, 'bookworm', 13, 'trixie');
my $latest_dist = '12';
my $old_dist = $latest_dist - 1;
my $lts_dist = '11';
# dist guessed from backports, SRU, security uploads...
my $guessed_dist = '';
my $CHANGES = '';
# Changelog urgency, possibly propagated to NEWS files
my $CL_URGENCY = '';
if (!$opt_create || ($opt_create && $opt_news)) {
my $file = $opt_create ? 'debian/changelog' : $changelog_path;
$changelog = changelog_parse(file => $file);
# Now we've read the changelog, set some variables and then
# let's check the directory name is sensible
fatal "No package name in changelog!"
unless exists $changelog->{Source};
$PACKAGE = $changelog->{Source};
fatal "No version number in changelog!"
unless exists $changelog->{Version};
$VERSION = $changelog->{Version};
fatal "No maintainer in changelog!"
unless exists $changelog->{Maintainer};
$changelog->{Maintainer} = decode_utf8($changelog->{Maintainer});
($MAINTAINER, $EMAIL) = ($changelog->{Maintainer} =~ /^([^<]*) <(.*)>/);
$MAINTAINER ||= '';
fatal "No distribution in changelog!"
unless exists $changelog->{Distribution};
if ($vendor eq 'Ubuntu') {
# In Ubuntu the development release regularly changes, don't just copy
# the previous name.
$DISTRIBUTION = get_ubuntu_devel_distro();
} else {
$DISTRIBUTION = $changelog->{Distribution};
}
fatal "No changes in changelog!"
unless exists $changelog->{Changes};
# Find the current package version
if ($opt_news) {
my $found_version = 0;
my $found_urgency = 0;
my $clog = changelog_parse(file => $real_changelog_path);
$VERSION = $clog->{Version};
$VERSION =~ s/~$//;
$CL_URGENCY = $clog->{Urgency};
}
# Is the directory name acceptable?
if ($check_dirname_level == 2
or ($check_dirname_level == 1 and $chdir)) {
my $re = $check_dirname_regex;
$re =~ s/PACKAGE/\\Q$PACKAGE\\E/g;
my $gooddir;
if ($re =~ m%/%) { $gooddir = eval "cwd() =~ /^$re\$/;"; }
else { $gooddir = eval "basename(cwd()) =~ /^$re\$/;"; }
if (!$gooddir) {
my $pwd = cwd();
fatal <<"EOF";
Found debian/changelog for package $PACKAGE in the directory
$pwd
but this directory name does not match the package name according to the
regex $check_dirname_regex.
To run $progname on this package, see the --check-dirname-level and
--check-dirname-regex options; run $progname --help for more info.
EOF
}
}
} else {
# we're creating and we don't know much about our package
if ($opt_d) {
my $pwd = basename(cwd());
# The directory name should be <package>-<version>
my $version_chars = '0-9a-zA-Z+\.\-';
if ($pwd =~ m/^([a-z0-9][a-z0-9+\-\.]+)-([0-9][$version_chars]*)$/) {
$PACKAGE = $1;
$VERSION = "$2-1"; # introduce a Debian version of -1
} elsif ($pwd =~ m/^[a-z0-9][a-z0-9+\-\.]+$/) {
$PACKAGE = $pwd;
} else {
# don't know anything
}
}
if ($opt_v) {
$VERSION = $opt_v;
}
if ($opt_D) {
$DISTRIBUTION = $opt_D;
}
}
if ($opt_package) {
if ($opt_package =~ m/^[a-z0-9][a-z0-9+\-\.]+$/) {
$PACKAGE = $opt_package;
} else {
warn
"$progname warning: illegal package name used with --package: $opt_package\n";
$warnings++;
}
}
# Clean up after old versions of debchange
if (-f "debian/RELEASED") {
unlink("debian/RELEASED");
}
if (-e "$changelog_path.dch") {
fatal "The backup file $changelog_path.dch already exists --\n"
. "please move it before trying again";
}
# Is this a native Debian package, i.e., does it have a - in the
# version number?
(my $EPOCH) = ($VERSION =~ /^(\d+):/);
(my $SVERSION = $VERSION) =~ s/^\d+://;
(my $UVERSION = $SVERSION) =~ s/-[^-]*$//;
# Check, sanitise and decode these environment variables
check_env_utf8('DEBFULLNAME');
check_env_utf8('NAME');
check_env_utf8('DEBEMAIL');
check_env_utf8('EMAIL');
check_env_utf8('UBUMAIL');
if (exists $env{'DEBEMAIL'} and $env{'DEBEMAIL'} =~ /^(.*)\s+<(.*)>$/) {
$env{'DEBFULLNAME'} = $1 unless exists $env{'DEBFULLNAME'};
$env{'DEBEMAIL'} = $2;
}
if (!exists $env{'DEBEMAIL'} or !exists $env{'DEBFULLNAME'}) {
if (exists $env{'EMAIL'} and $env{'EMAIL'} =~ /^(.*)\s+<(.*)>$/) {
$env{'DEBFULLNAME'} = $1 unless exists $env{'DEBFULLNAME'};
$env{'EMAIL'} = $2;
}
}
if (exists $env{'UBUMAIL'} and $env{'UBUMAIL'} =~ /^(.*)\s+<(.*)>$/) {
$env{'DEBFULLNAME'} = $1 unless exists $env{'DEBFULLNAME'};
$env{'UBUMAIL'} = $2;
}
# Now use the gleaned values to determine our MAINTAINER and EMAIL values
if (!$opt_m and !$opt_M) {
if (exists $env{'DEBFULLNAME'}) {
$MAINTAINER = $env{'DEBFULLNAME'};
} elsif (exists $env{'NAME'}) {
$MAINTAINER = $env{'NAME'};
} else {
my @pw = getpwuid $<;
if ($pw[6]) {
if (my $pw = decode_utf8($pw[6])) {
$pw =~ s/,.*//;
$MAINTAINER = $pw;
} else {
warn
"$progname warning: passwd full name field for uid $<\nis not UTF-8 encoded; ignoring\n";
$warnings++;
}
}
}
# Otherwise, $MAINTAINER retains its default value of the last
# changelog entry
# Email is easier
if ($vendor eq 'Ubuntu' and exists $env{'UBUMAIL'}) {
$EMAIL = $env{'UBUMAIL'};
} elsif (exists $env{'DEBEMAIL'}) {
$EMAIL = $env{'DEBEMAIL'};
} elsif (exists $env{'EMAIL'}) {
$EMAIL = $env{'EMAIL'};
} else {
warn
"$progname warning: neither DEBEMAIL nor EMAIL environment variable is set\n";
$warnings++;
my $addr;
if (open MAILNAME, '/etc/mailname') {
warn
"$progname warning: building email address from username and mailname\n";
$warnings++;
chomp($addr = <MAILNAME>);
close MAILNAME;
}
if (!$addr) {
warn
"$progname warning: building email address from username and FQDN\n";
$warnings++;
chomp($addr = `hostname --fqdn 2>/dev/null`);
$addr = undef if $?;
}
if ($addr) {
my $user = getpwuid $<;
if (!$user) {
$addr = undef;
} else {
$addr = "$user\@$addr";
}
}
$EMAIL = $addr if $addr;
}
# Otherwise, $EMAIL retains its default value of the last changelog entry
} # if (! $opt_m and ! $opt_M)
if ($opt_M) {
if (-f 'debian/control') {
my $parser = Dpkg::Control->new(type => CTRL_INFO_SRC);
$parser->load('debian/control');
my $maintainer = decode_utf8($parser->{Maintainer});
if ($maintainer =~ /^(.*)\s+<(.*)>$/) {
$MAINTAINER = $1;
$EMAIL = $2;
} else {
fatal "$progname: invalid debian/control Maintainer field value\n";
}
} else {
fatal "Missing file debian/control";
}
}
#####
if (
$opt_auto_nmu
and !$opt_v
and !$opt_l
and !$opt_s
and !$opt_lts
and !$opt_team
and !$opt_qa
and !$opt_R
and !$opt_bpo
and !$opt_sloppy
and !$opt_bn
and !$opt_n
and !$opt_c
and !$opt_stable
and !(exists $ENV{'CHANGELOG'} and length $ENV{'CHANGELOG'})
and !$opt_M
and !$opt_create
and !$opt_a_passed
and !$opt_r
and !$opt_e
and $vendor ne 'Ubuntu'
and $vendor ne 'Tanglu'
and !(
$opt_release_heuristic eq 'changelog'
and $changelog->{Distribution} eq 'UNRELEASED'
and !$opt_i_passed
)
) {
if (-f 'debian/control') {
my $parser = Dpkg::Control->new(type => CTRL_INFO_SRC);
$parser->load('debian/control');
my $uploader = decode_utf8($parser->{Uploaders}) || '';
$uploader =~ s/^\s+//;
my $maintainer = decode_utf8($parser->{Maintainer});
my @uploaders = split(/\s*,\s*/, $uploader);
my $packager = "$MAINTAINER <$EMAIL>";
if ( $maintainer !~ m/<packages\@qa\.debian\.org>/
and !grep { $_ eq $packager } ($maintainer, @uploaders)
and $packager ne $changelog->{Maintainer}
and !$opt_team) {
$opt_n = 1;
$opt_a = 0;
}
} else {
fatal "Missing file debian/control";
}
}
#####
# Do we need to generate "closes" entries?
my @closes_text = ();
my $initial_release = 0;
if (@closes and $opt_query) { # and we have to query the BTS
if (!Devscripts::Debbugs::have_soap) {
warn
"$progname warning: libsoap-lite-perl not installed, so cannot query the bug-tracking system\n";
$opt_query = 0;
$warnings++;
# This will now go and execute the "if (@closes and ! $opt_query)" code
} else {
my $bugs = Devscripts::Debbugs::select("src:" . $PACKAGE);
my $statuses = Devscripts::Debbugs::status(
map { [bug => $_, indicatesource => 1] } @{$bugs});
if ($statuses eq "") {
warn "$progname: No bugs found for package $PACKAGE\n";
}
foreach my $close (@closes) {
if ($statuses and exists $statuses->{$close}) {
my $title = $statuses->{$close}->{subject};
my $pkg = $statuses->{$close}->{package};
$title =~ s/^($pkg|$PACKAGE): //;
push @closes_text,
"Fix \"$title\" <explain what you changed and why> (Closes: \#$close)\n";
} else { # not our package, or wnpp
my $bug = Devscripts::Debbugs::status(
[bug => $close, indicatesource => 1]);
if ($bug eq "") {
warn
"$progname warning: unknown bug \#$close does not belong to $PACKAGE,\n disabling closing changelog entry\n";
$warnings++;
push @closes_text,
"Closes?? \#$close: UNKNOWN BUG IN WRONG PACKAGE!!\n";
} else {
my $bugtitle = $bug->{$close}->{subject};
$bugtitle ||= '';
my $bugpkg = $bug->{$close}->{package};
$bugpkg ||= '?';
my $bugsrcpkg = $bug->{$close}->{source};
$bugsrcpkg ||= '?';
if ($bugsrcpkg eq $PACKAGE) {
warn
"$progname warning: bug \#$close appears to be already archived,\n disabling closing changelog entry\n";
$warnings++;
push @closes_text,
"Closes?? \#$close: ALREADY ARCHIVED? $bugtitle!!\n";
} elsif ($bugpkg eq 'wnpp') {
if ($bugtitle =~ /(^(O|RFA|ITA): )/) {
push @closes_text,
"New maintainer. (Closes: \#$close: $bugtitle)\n";
} elsif ($bugtitle =~ /(^(RFP|ITP): )/) {
push @closes_text,
"Initial release. (Closes: \#$close: $bugtitle)\n";
$initial_release = 1;
}
} else {
warn
"$progname warning: bug \#$close belongs to package $bugpkg (src $bugsrcpkg),\n not to $PACKAGE: disabling closing changelog entry\n";
$warnings++;
push @closes_text,
"Closes?? \#$close: WRONG PACKAGE!! $bugtitle\n";
}
}
}
}
}
}
if (@closes and !$opt_query) { # and we don't have to query the BTS
foreach my $close (@closes) {
unless ($close =~ /^\d{3,}$/) {
warn "$progname warning: Bug number $close is invalid; ignoring\n";
$warnings++;
next;
}
push @closes_text, "Closes: \#$close: \n";
}
}
# Get a possible changelog entry from the command line
my $ARGS = join(' ', @ARGV);
my $TEXT = decode_utf8($ARGS);
my $EMPTY_TEXT = 0;
if (@ARGV and !$TEXT) {
if ($ARGS) {
warn
"$progname warning: command-line changelog entry not UTF-8 encoded; ignoring\n";
$TEXT = '';
} else {
$EMPTY_TEXT = 1;
}
}
# Get the date
my $DATE;
{
my $date_rfc5322
= '^(((Mon|Tue|Wed|Thu|Fri|Sat|Sun))[,]?\s[0-9]{1,2})\s(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\s([0-9]{4})\s([0-9]{2}):([0-9]{2})(:([0-9]{2}))?\s([\+|\-][0-9]{4})$';
if (defined $opt_date) {
if ($opt_date =~ /$date_rfc5322/) {
$DATE = $opt_date;
} else {
my $example_date = strftime "%a, %d %b %Y %T %z", localtime();
fatal(
"Date '$opt_date' is not in RFC 5322 format. Example: $example_date"
);
}
} else {
local $ENV{TZ} = $opt_tz if $opt_tz;
$DATE = strftime "%a, %d %b %Y %T %z", localtime();
}
}
if ($opt_news && !$opt_i && !$opt_a) {
if ($VERSION eq $changelog->{Version} && !$opt_v && !$opt_l) {
$opt_a = 1;
} else {
$opt_i = 1;
}
}
# Are we going to have to figure things out for ourselves?
if ( !$opt_i
&& !$opt_v
&& !$opt_d
&& !$opt_a
&& !$opt_e
&& !$opt_r
&& !$opt_n
&& !$opt_bn
&& !$opt_qa
&& !$opt_R
&& !$opt_s
&& !$opt_lts
&& !$opt_team
&& !$opt_bpo
&& !$opt_sloppy
&& !$opt_stable
&& !$opt_l
&& !$opt_create) {
# Yes, we are
if ($opt_release_heuristic eq 'log') {
my @UPFILES = glob("../$PACKAGE\_$SVERSION\_*.upload");
if (@UPFILES > 1) {
fatal "Found more than one appropriate .upload file!\n"
. "Please use an explicit -a, -i or -v option instead.";
} elsif (@UPFILES == 0) {
$opt_a = 1;
} else {
open UPFILE, "<${UPFILES[0]}"
or fatal "Couldn't open .upload file for reading: $!\n"
. "Please use an explicit -a, -i or -v option instead.";
while (<UPFILE>) {
if (
m%^(s|Successfully uploaded) (/.*/)?\Q$PACKAGE\E\_\Q$SVERSION\E\_[\w\-\+]+\.changes %
) {
$opt_i = 1;
last;
}
}
close UPFILE
or fatal "Problems experienced reading .upload file: $!\n"
. "Please use an explicit -a, -i or -v option instead.";
if (!$opt_i) {
warn
"$progname warning: A successful upload of the current version was not logged\n"
. "in the upload log file; adding log entry to current version.\n";
$opt_a = 1;
}
}
} elsif ($opt_release_heuristic eq 'changelog') {
if ($changelog->{Distribution} eq 'UNRELEASED') {
$opt_a = 1;
} elsif ($EMPTY_TEXT == 1) {
$opt_a = 1;
} else {
$opt_i = 1;
}
} else {
fatal "Bad release heuristic value";
}
}
# Open in anticipation....
unless ($opt_create) {
open S, $changelog_path
or fatal "Cannot open existing $changelog_path: $!";
# Read the first stanza from the changelog file
# We do this directly rather than reusing $changelog->{Changes}
# so that we have the verbatim changes rather than a (albeit very
# slightly) reformatted version. See Debian bug #452806
while (<S>) {
last if /^ --/;
$CHANGES .= $_;
}
chomp $CHANGES;
# Reset file pointer
seek(S, 0, 0);
}
open O, ">$changelog_path.dch"
or fatal "Cannot write to temporary file: $!";
# Turn off form feeds; taken from perlform
select((select(O), $^L = "")[0]);
# Note that we now have to remove it
my $tmpchk = 1;
my ($NEW_VERSION, $NEW_SVERSION, $NEW_UVERSION);
my $line;
my $optionsok = 0;
my $merge = 0;
if ((
$opt_i
|| $opt_n
|| $opt_bn
|| $opt_qa
|| $opt_R
|| $opt_s
|| $opt_lts
|| $opt_team
|| $opt_bpo
|| $opt_sloppy
|| $opt_stable
|| $opt_l
|| $opt_v
|| $opt_d
|| ($opt_news && $VERSION ne $changelog->{Version}))
&& !$opt_create
) {
$optionsok = 1;
# Check that a given explicit version number is sensible.
if ($opt_v || $opt_d) {
if ($opt_v) {
$NEW_VERSION = $opt_v;
} else {
my $pwd = basename(cwd());
# The directory name should be <package>-<version>
my $version_chars = '0-9a-zA-Z+\.~';
$version_chars .= ':' if defined $EPOCH;
$version_chars .= '\-' if $UVERSION ne $SVERSION;
if ($pwd =~ m/^\Q$PACKAGE\E-([0-9][$version_chars]*)$/) {
$NEW_VERSION = $1;
if ($NEW_VERSION eq $UVERSION) {
# So it's a Debian-native package
if ($SVERSION eq $UVERSION) {
fatal
"New version taken from directory ($NEW_VERSION) is equal to\n"
. "the current version number ($UVERSION)!";
}
# So we just increment the Debian revision
warn
"$progname warning: Incrementing Debian revision without altering\nupstream version number.\n";
$VERSION =~ /^(.*?)([a-yA-Y][a-zA-Z]*|\d*)$/;
my $end = $2;
if ($end eq '') {
fatal
"Cannot determine new Debian revision; please use -v option!";
}
$end++;
$NEW_VERSION = "$1$end";
} else {
$NEW_VERSION = "$EPOCH:$NEW_VERSION" if defined $EPOCH;
$NEW_VERSION .= "-1";
}
} else {
fatal
"The directory name must be <package>-<version> for -d to work!\n"
. "No underscores allowed!";
}
# Don't try renaming the directory in this case!
$opt_p = 1;
}
if (version_compare($VERSION, $NEW_VERSION) == 1) {
if ($opt_b
or ($opt_allow_lower and $NEW_VERSION =~ /$opt_allow_lower/)) {
warn
"$progname warning: new version ($NEW_VERSION) is less than\n"
. "the current version number ($VERSION).\n";
} else {
fatal "New version specified ($NEW_VERSION) is less than\n"
. "the current version number ($VERSION)! Use -b to force.";
}
}
($NEW_SVERSION = $NEW_VERSION) =~ s/^\d+://;
($NEW_UVERSION = $NEW_SVERSION) =~ s/-[^-]*$//;
}
# We use the following criteria for the version and release number:
# the last component of the version number is used as the
# release number. If this is not a Debian native package, then the
# upstream version number is everything up to the final '-', not
# including epochs.
if (!$NEW_VERSION) {
if ($VERSION =~ /(.*?)([a-yA-Y][a-zA-Z]*|\d+)([+~])?$/i) {
my $extra = $3 || '';
my $useextra = 0;
my $end = $2;
my $start = $1;
# If it's not already an NMU make it so
# otherwise we can be safe if we behave like dch -i
if (
($opt_n or $opt_s)
and $vendor ne 'Ubuntu'
and $vendor ne 'Tanglu'
and ( ($VERSION eq $UVERSION and not $start =~ /\+nmu/)
or ($VERSION ne $UVERSION and not $start =~ /\.$/))
) {
if ($VERSION eq $UVERSION) {
# First NMU of a Debian native package
$end .= "+nmu1";
} else {
$end += 0.1;
}
} elsif ($opt_bn and not $start =~ /\+b/) {
$end .= "+b1";
} elsif ($opt_qa and $start =~ /(.*?)-(\d+)\.$/) {
# Drop NMU revision when doing a QA upload
my $upstream_version = $1;
my $debian_revision = $2;
$debian_revision++;
$start = "$upstream_version-$debian_revision";
$end = "";
} elsif ($opt_R
and $vendor eq 'Ubuntu'
and not $start =~ /build/
and not $start =~ /ubuntu/) {
$end .= "build1";
} elsif ($opt_R
and $vendor eq 'Tanglu'
and not "$start$end" =~ /(b\d+)$/
and not $start =~ /tanglu/) {
$end .= "b1";
} elsif ($opt_bpo and not $start =~ /~bpo[0-9]+\+$/) {
# If it's not already a backport make it so
# otherwise we can be safe if we behave like dch -i
$end .= "~bpo$latest_dist+1";
} elsif ($opt_sloppy and not $start =~ /~bpo[0-9]+\+$/) {
# If it's not already a backport make it so
# otherwise we can be safe if we behave like dch -i
$end .= "~bpo$old_dist+1";
} elsif ($opt_stable and not $start =~ /\+deb\d+u/) {
$end .= "+deb${latest_dist}u1";
} elsif ($opt_lts and not $start =~ /\+deb\d+u/) {
$end .= "+deb${lts_dist}u1";
$guessed_dist = $dists{$lts_dist} . '-security';
} elsif ($opt_l and not $start =~ /\Q$opt_l\E/) {
# If it's not already a local package make it so
# otherwise we can be safe if we behave like dch -i
$end .= $opt_l . "1";
} elsif (!$opt_news) {
# Don't bump the version of a NEWS file in this case as we're
# using the version from the changelog
if ( ($opt_i or $opt_s)
and $vendor eq 'Ubuntu'
and $start !~ /(ubuntu|~ppa)(\d+\.)*$/
and not $opt_U) {
if ($start =~ /build/) {
# Drop buildX suffix in favor of ubuntu1
$start =~ s/build//;
$end = "";
}
$end .= "ubuntu1";
} elsif (($opt_i or $opt_s)
and $vendor eq 'Tanglu'
and $start !~ /(tanglu)(\d+\.)*$/
and not $opt_U) {
if ("$start$end" =~ /(b\d+)$/) {
# Drop bX suffix in favor of tanglu1
$start =~ s/b$//;
$end = "";
}
$end .= "tanglu1";
} else {
$end++;
}
# Attempt to set the distribution for a stable upload correctly
# based on the version of the previous upload
if ( $opt_stable
|| $opt_bpo
|| $opt_sloppy
|| $opt_s
|| $opt_lts) {
my $previous_dist = $start;
$previous_dist =~ s/^.*[+~](?:deb|bpo)(\d+)(?:u\+)$/$1/;
if ( defined $previous_dist
and defined $dists{$previous_dist}) {
if ($opt_s || $opt_lts) {
$guessed_dist
= $dists{$previous_dist} . '-security';
} elsif ($opt_bpo) {
+$guessed_dist
= $dists{$previous_dist} . '-backports';
} elsif ($opt_sloppy) {
+$guessed_dist
= $dists{$old_dist} . '-backports-sloppy';
} elsif ($opt_stable) {
$guessed_dist = $dists{$previous_dist};
}
} elsif ($opt_s) {
$guessed_dist = $dists{$latest_dist} . '-security';
} elsif ($opt_lts) {
$guessed_dist = $dists{$lts_dist} . '-security';
} else {
# Fallback to using the previous distribution
$guessed_dist = $changelog->{Distribution};
}
}
if (
!(
$opt_s
or $opt_n
or $vendor eq 'Ubuntu'
or $vendor eq 'Tanglu'
)
) {
if ($start =~ /(.*?)-(\d+)\.$/) {
# Drop NMU revision
my $upstream_version = $1;
my $debian_revision = $2;
$debian_revision++;
$start = "$upstream_version-$debian_revision";
$end = "";
}
}
if (
!(
$opt_qa
or $opt_bpo
or $opt_sloppy
or $opt_stable
or $opt_l
)
) {
$useextra = 1;
}
}
$NEW_VERSION = "$start$end";
if ($useextra) {
$NEW_VERSION .= $extra;
}
($NEW_SVERSION = $NEW_VERSION) =~ s/^\d+://;
($NEW_UVERSION = $NEW_SVERSION) =~ s/-[^-]*$//;
} else {
fatal "Error parsing version number: $VERSION";
}
}
if ($NEW_VERSION eq $NEW_UVERSION and $VERSION ne $UVERSION) {
warn
"$progname warning: New package version is Debian native whilst previous version was not\n";
} elsif ($NEW_VERSION ne $NEW_UVERSION and $VERSION eq $UVERSION) {
warn
"$progname warning: Previous package version was Debian native whilst new version is not\n"
unless $opt_n or $opt_s;
}
if ($opt_bpo) {
$guessed_dist ||= $dists{$latest_dist} . '-backports';
}
if ($opt_sloppy) {
$guessed_dist ||= $dists{$old_dist} . '-backports-sloppy';
}
if ($opt_stable) {
$guessed_dist ||= $dists{$latest_dist};
}
my $distribution
= $opt_D
|| $guessed_dist
|| (
($opt_release_heuristic eq 'changelog')
? "UNRELEASED"
: $DISTRIBUTION
);
my $urgency = $opt_u;
if ($opt_news) {
$urgency ||= $CL_URGENCY;
}
$urgency ||= 'medium';
if ( ($opt_v or $opt_i or $opt_l or $opt_d)
and $opt_release_heuristic eq 'changelog'
and $changelog->{Distribution} eq 'UNRELEASED') {
$merge = 1;
} else {
print O "$PACKAGE ($NEW_VERSION) $distribution; urgency=$urgency";
print O ", binary-only=yes" if ($opt_bn);
print O "\n\n";
if ($opt_n && !$opt_news) {
print O " * Non-maintainer upload.\n";
$line = 1;
} elsif ($opt_bn && !$opt_news) {
my $arch = qx/dpkg-architecture -qDEB_BUILD_ARCH/;
chomp($arch);
print O
" * Binary-only non-maintainer upload for $arch; no source changes.\n";
$line = 1;
} elsif ($opt_qa && !$opt_news) {
print O " * QA upload.\n";
$line = 1;
} elsif ($opt_s && !$opt_news) {
if ($vendor eq 'Ubuntu' or $vendor eq 'Tanglu') {
print O " * SECURITY UPDATE:\n";
print O " * References\n";
} else {
print O " * Non-maintainer upload by the Security Team.\n";
}
$line = 1;
} elsif ($opt_lts && !$opt_news) {
print O " * Non-maintainer upload by the LTS Security Team.\n";
$line = 1;
} elsif ($opt_team && !$opt_news) {
print O " * Team upload.\n";
$line = 1;
} elsif ($opt_bpo && !$opt_news) {
print O " * Rebuild for $guessed_dist.\n";
$line = 1;
} elsif ($opt_sloppy && !$opt_news) {
print O " * Rebuild for $guessed_dist.\n";
$line = 1;
}
if (@closes_text or $TEXT or $EMPTY_TEXT) {
foreach (@closes_text) { format_line($_, 1); }
if (length $TEXT) { format_line($TEXT, 1); }
} elsif ($opt_news) {
print O " \n";
} else {
print O " * \n";
}
$line += 3;
print O "\n -- $MAINTAINER <$EMAIL> $DATE\n\n";
# Copy the old changelog file to the new one
local $/ = undef;
print O <S>;
}
}
if (($opt_r || $opt_a || $merge) && !$opt_create) {
# This means we just have to generate a new * entry in changelog
# and if a multi-developer changelog is detected, add developer names.
$NEW_VERSION = $VERSION unless $NEW_VERSION;
$NEW_SVERSION = $SVERSION unless $NEW_SVERSION;
$NEW_UVERSION = $UVERSION unless $NEW_UVERSION;
# Read and discard maintainer line, see who made the
# last entry, and determine whether there are existing
# multi-developer changes by the current maintainer.
$line = -1;
my ($lastmaint, $nextmaint, $maintline, $count, $lastheader, $lastdist,
$dist_indicator);
my $savedline = $line;
while (<S>) {
$line++;
# Start of existing changes by the current maintainer
if (/^ \[ \Q$MAINTAINER\E \]$/ && $opt_multimaint_merge) {
# If there's more than one such block,
# we only care about the first
$maintline ||= $line;
} elsif (/^ \[ (.*) \]$/ && defined $maintline) {
# Start of existing changes following those by the current
# maintainer
$nextmaint ||= $1;
} elsif (
m/^\w[-+0-9a-z.]* \(([^\(\) \t]+)\)((?:\s+[-+0-9a-z.]+)+)\;\s+urgency=(\w+)/i
) {
if (defined $lastmaint) {
$lastheader = $_;
$lastdist = $2;
$lastdist =~ s/^\s+//;
undef $lastdist if $lastdist eq "UNRELEASED";
# Revert to our previously saved position
$line = $savedline;
last;
} else {
my $tmpver = $1;
$tmpver =~ s/^\s+//;
if ($tmpver =~ m/~bpo(\d+)\+/ && exists $dists{$1}) {
$dist_indicator = "$dists{$1}-backports";
}
if ($tmpver =~ m/\+deb(\d+)u/ && exists $dists{$1}) {
$dist_indicator = "$dists{$1}";
}
}
} elsif (/ \* (?:Upload to|Rebuild for) (\S+).*$/) {
($dist_indicator = $1) =~ s/[!:.,;]$//;
chomp $dist_indicator;
} elsif (/^ --\s+([^<]+)\s+/ || /^ --\s+<(.+?)>/) {
$lastmaint = $1;
# Remember where we are so we can skip back afterwards
$savedline = $line;
}
if (defined $maintline && !defined $nextmaint) {
$maintline++;
}
}
# Munging of changelog for multimaintainer mode.
my $multimaint = 0;
if (!$opt_news) {
my $lastmultimaint;
# Parse the changelog for multi-maintainer maintainer lines of
# the form [ Full Name ] and record the last of these.
while ($CHANGES =~ /.*\n^\s+\[\s+([^\]]+)\s+]\s*$/mg) {
$lastmultimaint = $1;
}
if ((
!defined $lastmultimaint
&& defined $lastmaint
&& $lastmaint ne $MAINTAINER
&& $opt_multimaint
)
|| (defined $lastmultimaint && $lastmultimaint ne $MAINTAINER)
|| (defined $nextmaint)
) {
$multimaint = 1;
if (!$lastmultimaint) {
# Add a multi-maintainer header to the top of the existing
# changelog.
my $newchanges = '';
$CHANGES =~ s/^( .+)$/ [ $lastmaint ]\n$1/m;
}
}
}
# based on /usr/lib/dpkg/parsechangelog/debian
if ($CHANGES
=~ m/^\w[-+0-9a-z.]* \([^\(\) \t]+\)((?:\s+[-+0-9a-z.]+)+)\;\s+urgency=(\w+)/i
) {
my $distribution = $1;
my $urgency = $2;
if ($opt_news) {
$urgency = $CL_URGENCY;
}
$distribution =~ s/^\s+//;
if ($opt_r) {
# Change the distribution from UNRELEASED for release
if ($distribution eq "UNRELEASED") {
if ($dist_indicator and not $opt_D) {
$distribution = $dist_indicator;
} elsif ($vendor eq 'Ubuntu') {
if ($opt_D) {
$distribution = $opt_D;
} else {
$distribution = get_ubuntu_devel_distro();
}
} else {
$distribution = $opt_D || $lastdist || "unstable";
}
} elsif ($opt_D) {
warn
"$progname warning: ignoring distribution passed to --release as changelog has already been released\n";
}
# Set the start-line to 1, as we don't know what they want to edit
$line = 1;
} else {
$distribution = $opt_D if $opt_D;
}
$urgency = $opt_u if $opt_u;
$CHANGES
=~ s/^(\w[-+0-9a-z.]* \([^\(\) \t]+\))(?:\s+[-+0-9a-z.]+)+\;\s+urgency=\w+/$PACKAGE ($NEW_VERSION) $distribution; urgency=$urgency/i;
} else {
warn
"$progname: couldn't parse first changelog line, not touching it\n";
$warnings++;
}
if (defined $maintline && defined $nextmaint) {
# Output the lines up to the end of the current maintainer block
$count = 1;
$line = $maintline;
foreach (split /\n/, $CHANGES) {
print O $_ . "\n";
$count++;
last if $count == $maintline;
}
} else {
# The first lines are as we have already found
print O $CHANGES;
}
if (!$opt_r) {
# Add a multi-maintainer header...
if ($multimaint
and (@closes_text or $TEXT or $opt_news or !$EMPTY_TEXT)) {
# ...unless there already is one for this maintainer.
if (!defined $maintline) {
print O "\n [ $MAINTAINER ]\n";
$line += 2;
}
}
if (@closes_text or $TEXT) {
foreach (@closes_text) { format_line($_, 0); }
if (length $TEXT) { format_line($TEXT, 0); }
} elsif ($opt_news) {
print O "\n \n";
$line++;
} elsif (!$EMPTY_TEXT) {
print O " * \n";
}
}
if (defined $count) {
# Output the remainder of the changes
$count = 1;
foreach (split /\n/, $CHANGES) {
$count++;
next unless $count > $maintline;
print O $_ . "\n";
}
}
if ($opt_t && $opt_a) {
print O "\n -- $changelog->{Maintainer} $changelog->{Date}\n";
} else {
print O "\n -- $MAINTAINER <$EMAIL> $DATE\n";
}
if ($lastheader) {
print O "\n$lastheader";
}
# Copy the rest of the changelog file to new one
# Slurp the rest....
local $/ = undef;
print O <S>;
} elsif ($opt_e && !$opt_create) {
# We don't do any fancy stuff with respect to versions or adding
# entries, we just update the timestamp and open the editor
print O $CHANGES;
if ($opt_t) {
print O "\n -- $changelog->{Maintainer} $changelog->{Date}\n";
} else {
print O "\n -- $MAINTAINER <$EMAIL> $DATE\n";
}
# Copy the rest of the changelog file to the new one
$line = -1;
while (<S>) { $line++; last if /^ --/; }
# Slurp the rest...
local $/ = undef;
print O <S>;
# Set the start-line to 0, as we don't know what they want to edit
$line = 0;
} elsif ($opt_create) {
if ( !$initial_release
and !$opt_news
and !$opt_empty
and !$TEXT
and !$EMPTY_TEXT) {
push @closes_text, "Initial release. (Closes: \#XXXXXX)\n";
}
my $urgency = $opt_u;
if ($opt_news) {
$urgency ||= $CL_URGENCY;
}
$urgency ||= 'medium';
print O "$PACKAGE ($VERSION) $DISTRIBUTION; urgency=$urgency\n\n";
if (@closes_text or $TEXT) {
foreach (@closes_text) { format_line($_, 1); }
if (length $TEXT) { format_line($TEXT, 1); }
} elsif ($opt_news) {
print O " \n";
} elsif ($opt_empty) {
# Do nothing, but skip the empty entry
} else { # this can't happen, but anyway...
print O " * \n";
}
print O "\n -- $MAINTAINER <$EMAIL> $DATE\n";
$line = 1;
} elsif (!$optionsok) {
fatal "Unknown changelog processing command line options - help!";
}
if (!$opt_create) {
close S or fatal "Error closing $changelog_path: $!";
}
close O or fatal "Error closing temporary $changelog_path: $!";
if ($warnings) {
if ($warnings > 1) {
warn
"$progname: Did you see those $warnings warnings? Press RETURN to continue...\n";
} else {
warn
"$progname: Did you see that warning? Press RETURN to continue...\n";
}
my $garbage = <STDIN>;
}
# Now Run the Editor; always run if doing "closes" to give a chance to check
if ( (!$TEXT and !$EMPTY_TEXT and !($opt_create and $opt_empty))
or @closes_text
or ($opt_create and !($PACKAGE ne 'PACKAGE' and $VERSION ne 'VERSION'))) {
my $mtime = (stat("$changelog_path.dch"))[9];
defined $mtime
or fatal
"Error getting modification time of temporary $changelog_path: $!";
$mtime--;
utime $mtime, $mtime, "$changelog_path.dch";
system("sensible-editor +$line $changelog_path.dch") == 0
or fatal "Error editing $changelog_path";
my $newmtime = (stat("$changelog_path.dch"))[9];
defined $newmtime
or fatal
"Error getting modification time of temporary $changelog_path: $!";
if ( $mtime == $newmtime
&& !$opt_create
&& (!$opt_r || ($opt_r && $opt_force_save_on_release))) {
warn "$progname: $changelog_path unmodified; exiting.\n";
exit 0;
}
}
copy("$changelog_path.dch", "$changelog_path")
or fatal "Couldn't replace $changelog_path with new version: $!";
# Now find out what the new package version number is if we need to
# rename the directory
if ( (basename(cwd()) =~ m%^\Q$PACKAGE\E-\Q$UVERSION\E$%)
&& !$opt_p
&& !$opt_create) {
# Find the current version number etc.
my $v;
my $changelog = changelog_parse();
if (exists $changelog->{Version}) {
$v = Dpkg::Version->new($changelog->{Version});
}
fatal "No version number in debian/changelog!"
unless defined($v)
and $v->is_valid();
my ($new_version, $new_uversion);
$new_version = $v->as_string(omit_epoch => 1);
$new_uversion = $v->as_string(omit_epoch => 1, omit_revision => 1);
if ($new_uversion ne $UVERSION) {
# Then we rename the directory
if (move(cwd(), "../$PACKAGE-$new_uversion")) {
warn
"$progname warning: your current directory has been renamed to:\n../$PACKAGE-$new_uversion\n";
} else {
warn "$progname warning: Couldn't rename directory: $!\n";
}
if (!$v->is_native()) {
# And check whether a new orig tarball exists
my @origs = glob("../$PACKAGE\_$new_uversion.*");
my $num_origs = grep {
/^..\/\Q$PACKAGE\E_\Q$new_uversion\E\.orig\.tar\.$compression_re$/
} @origs;
if ($num_origs == 0) {
warn
"$progname warning: no orig tarball found for the new version.\n";
}
}
}
}
exit 0;
{
no warnings 'uninitialized';
# Format for standard Debian changelogs
format CHANGELOG =
* ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$CHGLINE
~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$CHGLINE
.
# Format for NEWS files.
format NEWS =
^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$CHGLINE
~~^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$CHGLINE
.
}
my $linecount = 0;
sub format_line {
$CHGLINE = shift;
my $newentry = shift;
# Work around the fact that write() with formats
# seems to assume that characters are single-byte
# See https://rt.perl.org/Public/Bug/Display.html?id=33832
# and Debian bugs #473769 and #541484
# This relies on $CHGLINE being a sequence of unicode characters. We can
# compare how many unicode characters we have to how many bytes we have
# when encoding to utf8 and therefore how many spaces we need to pad.
my $count = length(encode_utf8($CHGLINE)) - length($CHGLINE);
$CHGLINE .= " " x $count;
print O "\n" if $opt_news && !($newentry || $linecount);
$linecount++;
my $f = select(O);
if ($opt_news) {
$~ = 'NEWS';
} else {
$~ = 'CHANGELOG';
}
write O;
select $f;
}
BEGIN {
# Initialise the variable
$tmpchk = 0;
}
END {
if ($tmpchk) {
unlink "$changelog_path.dch"
or warn "$progname warning: Could not remove $changelog_path.dch\n";
unlink "$changelog_path.dch~"; # emacs backup file
}
}
sub fatal($) {
my ($pack, $file, $line);
($pack, $file, $line) = caller();
(my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d;
$msg =~ s/\n\n$/\n/;
die $msg;
}
# Is the environment variable valid or not?
sub check_env_utf8 {
my $envvar = $_[0];
if (exists $ENV{$envvar} and $ENV{$envvar} ne '') {
if (!decode_utf8($ENV{$envvar})) {
warn
"$progname warning: environment variable $envvar not UTF-8 encoded; ignoring\n";
} else {
$env{$envvar} = decode_utf8($ENV{$envvar});
}
}
}
View git blame Copy permalink