1#!/usr/bin/perl 2# vim: set ai shiftwidth=4 tabstop=4 expandtab: 3 4# debchange: update the debian changelog using your favorite visual editor 5# For options, see the usage message below. 6# 7# When creating a new changelog section, if either of the environment 8# variables DEBEMAIL or EMAIL is set, debchange will use this as the 9# uploader's email address (with the former taking precedence), and if 10# DEBFULLNAME or NAME is set, it will use this as the uploader's full name. 11# Otherwise, it will take the standard values for the current user or, 12# failing that, just copy the values from the previous changelog entry. 13# 14# Originally by Christoph Lameter <clameter@debian.org> 15# Modified extensively by Julian Gilbey <jdg@debian.org> 16# 17# Copyright 1999-2005 by Julian Gilbey 18# 19# This program is free software; you can redistribute it and/or modify 20# it under the terms of the GNU General Public License as published by 21# the Free Software Foundation; either version 2 of the License, or 22# (at your option) any later version. 23# 24# This program is distributed in the hope that it will be useful, 25# but WITHOUT ANY WARRANTY; without even the implied warranty of 26# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 27# GNU General Public License for more details. 28# 29# You should have received a copy of the GNU General Public License 30# along with this program. If not, see <https://www.gnu.org/licenses/>. 31 32use 5.008; # We're using PerlIO layers 33use strict; 34use warnings; 35use open ':utf8'; # changelogs are written with UTF-8 encoding 36use filetest 'access'; # use access rather than stat for -w 37# for checking whether user names are valid and making format() behave 38use Encode qw/decode_utf8 encode_utf8/; 39use Getopt::Long qw(:config bundling permute no_getopt_compat); 40use File::Copy; 41use File::Basename; 42use Cwd; 43use Dpkg::Vendor qw(get_current_vendor); 44use Dpkg::Changelog::Parse qw(changelog_parse); 45use Dpkg::Control; 46use Dpkg::Version; 47use Devscripts::Compression; 48use Devscripts::Debbugs; 49use POSIX qw(locale_h strftime); 50 51setlocale(LC_TIME, "C"); # so that strftime is locale independent 52 53# Predeclare functions 54sub fatal($); 55my $warnings = 0; 56 57# And global variables 58my $progname = basename($0); 59my $modified_conf_msg; 60my %env; 61my $CHGLINE; # used by the format O section at the end 62 63my $compression_re = compression_get_file_extension_regex(); 64 65my $debian_distro_info; 66 67sub get_debian_distro_info { 68 return $debian_distro_info if defined $debian_distro_info; 69 eval { require Debian::DistroInfo; }; 70 if ($@) { 71 printf "libdistro-info-perl is not installed, Debian release names " 72 . "are not known.\n"; 73 $debian_distro_info = 0; 74 } else { 75 $debian_distro_info = DebianDistroInfo->new(); 76 } 77 return $debian_distro_info; 78} 79 80my $ubuntu_distro_info; 81 82sub get_ubuntu_distro_info { 83 return $ubuntu_distro_info if defined $ubuntu_distro_info; 84 eval { require Debian::DistroInfo; }; 85 if ($@) { 86 printf "libdistro-info-perl is not installed, Ubuntu release names " 87 . "are not known.\n"; 88 $ubuntu_distro_info = 0; 89 } else { 90 $ubuntu_distro_info = UbuntuDistroInfo->new(); 91 } 92 return $ubuntu_distro_info; 93} 94 95sub get_ubuntu_devel_distro { 96 my $ubu_info = get_ubuntu_distro_info(); 97 if ($ubu_info == 0 or !$ubu_info->devel()) { 98 warn "$progname warning: Unable to determine the current Ubuntu " 99 . "development release. Using UNRELEASED instead.\n"; 100 return 'UNRELEASED'; 101 } else { 102 return $ubu_info->devel(); 103 } 104} 105 106sub usage () { 107 print <<"EOF"; 108Usage: $progname [options] [changelog entry] 109Options: 110 -a, --append 111 Append a new entry to the current changelog 112 -i, --increment 113 Increase the Debian release number, adding a new changelog entry 114 -v <version>, --newversion=<version> 115 Add a new changelog entry with version number specified 116 -e, --edit 117 Don't change version number or add a new changelog entry, just 118 opens an editor 119 -r, --release 120 Update the changelog timestamp. If the distribution is set to 121 "UNRELEASED", change it to unstable (or another distribution as 122 specified by --distribution, or the name of the current development 123 release when run under Ubuntu). 124 --force-save-on-release 125 When --release is used and an editor opened to allow inspection 126 of the changelog, require the user to save the changelog their 127 editor opened. Otherwise, the original changelog will not be 128 modified. (default) 129 --no-force-save-on-release 130 Do not do so. Note that a dummy changelog entry may be supplied 131 in order to achieve the same effect - e.g. $progname --release "" 132 The entry will not be added to the changelog but its presence will 133 suppress the editor 134 --create 135 Create a new changelog (default) or NEWS file (with --news) and 136 open for editing 137 --empty 138 When creating a new changelog, don't add any changes to it 139 (i.e. only include the header and trailer lines) 140 --package <package> 141 Specify the package name when using --create (optional) 142 --auto-nmu 143 Attempt to intelligently determine whether a change to the 144 changelog represents an NMU (default) 145 --no-auto-nmu 146 Do not do so 147 -n, --nmu 148 Increment the Debian release number for a non-maintainer upload 149 --bin-nmu 150 Increment the Debian release number for a binary non-maintainer upload 151 -q, --qa 152 Increment the Debian release number for a Debian QA Team upload 153 -R, --rebuild 154 Increment the Debian release number for a no-change rebuild 155 -s, --security 156 Increment the Debian release number for a Debian Security Team upload 157 --lts 158 Increment the Debian release number for a LTS Security Team upload 159 --team 160 Increment the Debian release number for a team upload 161 -U, --upstream 162 Increment the Debian release number without any appended derivative 163 distribution name 164 --bpo 165 Increment the Debian release number for a backports upload 166 to "bullseye-backports" 167 --stable 168 Increment the Debian release number for a stable upload. 169 -l, --local <suffix> 170 Add a suffix to the Debian version number for a local build 171 -b, --force-bad-version 172 Force a version to be less than the current one (e.g., when 173 backporting) 174 --allow-lower-version <pattern> 175 Allow a version to be less than the current one (e.g., when 176 backporting) if it matches the specified pattern 177 --force-distribution 178 Force the provided distribution to be used, even if it doesn't match 179 the list of known distributions 180 --closes nnnnn[,nnnnn,...] 181 Add entries for closing these bug numbers, 182 getting bug titles from the BTS (bug-tracking system, bugs.debian.org) 183 --[no]query 184 [Don\'t] try contacting the BTS to get bug titles (default: do query) 185 -d, --fromdirname 186 Add a new changelog entry with version taken from the directory name 187 -p, --preserve 188 Preserve the directory name 189 --no-preserve 190 Do not preserve the directory name (default) 191 --vendor <vendor> 192 Override the distributor ID from dpkg-vendor. 193 -D, --distribution <dist> 194 Use the specified distribution in the changelog entry being edited 195 -u, --urgency <urgency> 196 Use the specified urgency in the changelog entry being edited 197 -c, --changelog <changelog> 198 Specify the name of the changelog to use in place of debian/changelog 199 No directory traversal or checking is performed in this case. 200 --news <newsfile> 201 Specify that the newsfile (default debian/NEWS) is to be edited 202 --[no]multimaint 203 When appending an entry to a changelog section (-a), [do not] 204 indicate if multiple maintainers are now involved (default: do so) 205 --[no]multimaint-merge 206 When appending an entry to a changelog section, [do not] merge the 207 entry into an existing changelog section for the current author. 208 (default: do not) 209 -m, --maintmaint 210 Don\'t change (maintain) the maintainer details in the changelog entry 211 -M, --controlmaint 212 Use maintainer name and email from the debian/control Maintainer field 213 -t, --mainttrailer 214 Don\'t change (maintain) the trailer line in the changelog entry; i.e. 215 maintain the maintainer and date/time details 216 --check-dirname-level N 217 How much to check directory names: 218 N=0 never 219 N=1 only if program changes directory (default) 220 N=2 always 221 --check-dirname-regex REGEX 222 What constitutes a matching directory name; REGEX is 223 a Perl regular expression; the string \`PACKAGE\' will 224 be replaced by the package name; see manpage for details 225 (default: 'PACKAGE(-.+)?') 226 --no-conf, --noconf 227 Don\'t read devscripts config files; must be the first option given 228 --release-heuristic log|changelog 229 Select heuristic used to determine if a package has been released. 230 (default: changelog) 231 --help, -h 232 Display this help message and exit 233 --version 234 Display version information 235 At most one of -a, -i, -e, -r, -v, -d, -n, --bin-nmu, -q, --qa, -R, -s, 236 --lts, --team, --bpo, --stable, -l (or their long equivalents) may be used. 237 With no options, one of -i or -a is chosen by looking at the release 238 specified in the changelog. 239 240Default settings modified by devscripts configuration files: 241$modified_conf_msg 242EOF 243} 244 245sub version () { 246 print <<"EOF"; 247This is $progname, from the Debian devscripts package, version 2.17.10 248This code is copyright 1999-2003 by Julian Gilbey, all rights reserved. 249Based on code by Christoph Lameter. 250This program comes with ABSOLUTELY NO WARRANTY. 251You are free to redistribute this code under the terms of the 252GNU General Public License, version 2 or later. 253EOF 254} 255 256# Start by setting default values 257my $check_dirname_level = 1; 258my $check_dirname_regex = 'PACKAGE(-.+)?'; 259my $opt_p = 0; 260my $opt_query = 1; 261my $opt_release_heuristic = 'changelog'; 262my $opt_release_heuristic_re = '^(changelog|log)$'; 263my $opt_multimaint = 1; 264my $opt_multimaint_merge = 0; 265my $opt_tz = undef; 266my $opt_t = ''; 267my $opt_allow_lower = ''; 268my $opt_auto_nmu = 1; 269my $opt_force_save_on_release = 1; 270my $opt_vendor = undef; 271 272# Next, read configuration files and then command line 273# The next stuff is boilerplate 274 275if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) { 276 $modified_conf_msg = " (no configuration files read)"; 277 shift; 278} else { 279 my @config_files = ('/etc/devscripts.conf', '~/.devscripts'); 280 my %config_vars = ( 281 'DEBCHANGE_PRESERVE' => 'no', 282 'DEBCHANGE_QUERY_BTS' => 'yes', 283 'DEVSCRIPTS_CHECK_DIRNAME_LEVEL' => 1, 284 'DEVSCRIPTS_CHECK_DIRNAME_REGEX' => 'PACKAGE(-.+)?', 285 'DEBCHANGE_RELEASE_HEURISTIC' => 'changelog', 286 'DEBCHANGE_MULTIMAINT' => 'yes', 287 'DEBCHANGE_TZ' => $ENV{TZ}, # undef if TZ unset 288 'DEBCHANGE_MULTIMAINT_MERGE' => 'no', 289 'DEBCHANGE_MAINTTRAILER' => '', 290 'DEBCHANGE_LOWER_VERSION_PATTERN' => '', 291 'DEBCHANGE_AUTO_NMU' => 'yes', 292 'DEBCHANGE_FORCE_SAVE_ON_RELEASE' => 'yes', 293 'DEBCHANGE_VENDOR' => '', 294 ); 295 $config_vars{'DEBCHANGE_TZ'} ||= ''; 296 my %config_default = %config_vars; 297 298 my $shell_cmd; 299 # Set defaults 300 foreach my $var (keys %config_vars) { 301 $shell_cmd .= qq[$var="$config_vars{$var}";\n]; 302 } 303 $shell_cmd .= 'for file in ' . join(" ", @config_files) . "; do\n"; 304 $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n"; 305 # Read back values 306 foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" } 307 my $shell_out = `/bin/bash -c '$shell_cmd'`; 308 @config_vars{ keys %config_vars } = split /\n/, $shell_out, -1; 309 310 # Check validity 311 $config_vars{'DEBCHANGE_PRESERVE'} =~ /^(yes|no)$/ 312 or $config_vars{'DEBCHANGE_PRESERVE'} = 'no'; 313 $config_vars{'DEBCHANGE_QUERY_BTS'} =~ /^(yes|no)$/ 314 or $config_vars{'DEBCHANGE_QUERY_BTS'} = 'yes'; 315 $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} =~ /^[012]$/ 316 or $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} = 1; 317 $config_vars{'DEBCHANGE_RELEASE_HEURISTIC'} =~ $opt_release_heuristic_re 318 or $config_vars{'DEBCHANGE_RELEASE_HEURISTIC'} = 'changelog'; 319 $config_vars{'DEBCHANGE_MULTIMAINT'} =~ /^(yes|no)$/ 320 or $config_vars{'DEBCHANGE_MULTIMAINT'} = 'yes'; 321 $config_vars{'DEBCHANGE_MULTIMAINT_MERGE'} =~ /^(yes|no)$/ 322 or $config_vars{'DEBCHANGE_MULTIMAINT_MERGE'} = 'no'; 323 $config_vars{'DEBCHANGE_AUTO_NMU'} =~ /^(yes|no)$/ 324 or $config_vars{'DEBCHANGE_AUTO_NMU'} = 'yes'; 325 $config_vars{'DEBCHANGE_FORCE_SAVE_ON_RELEASE'} =~ /^(yes|no)$/ 326 or $config_vars{'DEBCHANGE_FORCE_SAVE_ON_RELEASE'} = 'yes'; 327 328 foreach my $var (sort keys %config_vars) { 329 if ($config_vars{$var} ne $config_default{$var}) { 330 $modified_conf_msg .= " $var=$config_vars{$var}\n"; 331 } 332 } 333 $modified_conf_msg ||= " (none)\n"; 334 chomp $modified_conf_msg; 335 336 $opt_p = $config_vars{'DEBCHANGE_PRESERVE'} eq 'yes' ? 1 : 0; 337 $opt_query = $config_vars{'DEBCHANGE_QUERY_BTS'} eq 'no' ? 0 : 1; 338 $check_dirname_level = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'}; 339 $check_dirname_regex = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_REGEX'}; 340 $opt_release_heuristic = $config_vars{'DEBCHANGE_RELEASE_HEURISTIC'}; 341 $opt_multimaint = $config_vars{'DEBCHANGE_MULTIMAINT'} eq 'no' ? 0 : 1; 342 $opt_tz = $config_vars{'DEBCHANGE_TZ'}; 343 $opt_multimaint_merge 344 = $config_vars{'DEBCHANGE_MULTIMAINT_MERGE'} eq 'no' ? 0 : 1; 345 $opt_t = ($config_vars{'DEBCHANGE_MAINTTRAILER'} eq 'no' ? 0 : 1) 346 if $config_vars{'DEBCHANGE_MAINTTRAILER'}; 347 $opt_allow_lower = $config_vars{'DEBCHANGE_LOWER_VERSION_PATTERN'}; 348 $opt_auto_nmu = $config_vars{'DEBCHANGE_AUTO_NMU'} eq 'yes'; 349 $opt_force_save_on_release 350 = $config_vars{'DEBCHANGE_FORCE_SAVE_ON_RELEASE'} eq 'yes' ? 1 : 0; 351 $opt_vendor = $config_vars{'DEBCHANGE_VENDOR'}; 352} 353 354# We use bundling so that the short option behaviour is the same as 355# with older debchange versions. 356my ($opt_help, $opt_version); 357my ( 358 $opt_i, $opt_a, $opt_e, $opt_r, $opt_v, 359 $opt_b, $opt_d, $opt_D, $opt_u, $opt_force_dist 360); 361my ( 362 $opt_n, $opt_bn, $opt_qa, $opt_R, $opt_s, 363 $opt_lts, $opt_team, $opt_U, $opt_bpo, $opt_stable, 364 $opt_l, $opt_c, $opt_m, $opt_M, $opt_create, 365 $opt_package, @closes 366); 367my ($opt_news); 368my ($opt_noconf, $opt_empty); 369 370Getopt::Long::Configure('bundling'); 371GetOptions( 372 "help|h" => \$opt_help, 373 "version" => \$opt_version, 374 "i|increment" => \$opt_i, 375 "a|append" => \$opt_a, 376 "e|edit" => \$opt_e, 377 "r|release" => \$opt_r, 378 "create" => \$opt_create, 379 "package=s" => \$opt_package, 380 "v|newversion=s" => \$opt_v, 381 "b|force-bad-version" => \$opt_b, 382 "allow-lower-version=s" => \$opt_allow_lower, 383 "force-distribution" => \$opt_force_dist, 384 "d|fromdirname" => \$opt_d, 385 "p" => \$opt_p, 386 "preserve!" => \$opt_p, 387 "D|distribution=s" => \$opt_D, 388 "u|urgency=s" => \$opt_u, 389 "n|nmu" => \$opt_n, 390 "bin-nmu" => \$opt_bn, 391 "q|qa" => \$opt_qa, 392 "R|rebuild" => \$opt_R, 393 "s|security" => \$opt_s, 394 "team" => \$opt_team, 395 "U|upstream" => \$opt_U, 396 "bpo" => \$opt_bpo, 397 "lts" => \$opt_lts, 398 "stable" => \$opt_stable, 399 "l|local=s" => \$opt_l, 400 "query!" => \$opt_query, 401 "closes=s" => \@closes, 402 "c|changelog=s" => \$opt_c, 403 "news:s" => \$opt_news, 404 "multimaint!" => \$opt_multimaint, 405 "multi-maint!" => \$opt_multimaint, 406 'multimaint-merge!' => \$opt_multimaint_merge, 407 'multi-maint-merge!' => \$opt_multimaint_merge, 408 "m|maintmaint" => \$opt_m, 409 "M|controlmaint" => \$opt_M, 410 "t|mainttrailer!" => \$opt_t, 411 "check-dirname-level=s" => \$check_dirname_level, 412 "check-dirname-regex=s" => \$check_dirname_regex, 413 "noconf" => \$opt_noconf, 414 "no-conf" => \$opt_noconf, 415 "release-heuristic=s" => \$opt_release_heuristic, 416 "empty" => \$opt_empty, 417 "auto-nmu!" => \$opt_auto_nmu, 418 "force-save-on-release!" => \$opt_force_save_on_release, 419 "vendor=s" => \$opt_vendor, 420 ) 421 or die 422"Usage: $progname [options] [changelog entry]\nRun $progname --help for more details\n"; 423 424# So that we can distinguish, if required, between an explicit 425# passing of -a / -i and their values being automagically deduced 426# later on 427my $opt_a_passed = $opt_a || 0; 428my $opt_i_passed = $opt_i || 0; 429$opt_news = 'debian/NEWS' if defined $opt_news and $opt_news eq ''; 430 431if ($opt_t eq '' && $opt_release_heuristic eq 'changelog') { 432 $opt_t = 1; 433} 434 435if ($opt_noconf) { 436 fatal "--no-conf is only acceptable as the first command-line option!"; 437} 438if ($opt_help) { usage; exit 0; } 439if ($opt_version) { version; exit 0; } 440 441if ($check_dirname_level !~ /^[012]$/) { 442 fatal "Unrecognised --check-dirname-level value (allowed are 0,1,2)"; 443} 444if ($opt_release_heuristic !~ $opt_release_heuristic_re) { 445 fatal "Allowed values for --release-heuristics are log and changelog."; 446} 447 448# Only allow at most one non-help option 449fatal 450"Only one of -a, -i, -e, -r, -v, -d, -n/--nmu, --bin-nmu, -q/--qa, -R/--rebuild, -s/--security, --lts, --team, --bpo, --stable, -l/--local is allowed;\ntry $progname --help for more help" 451 if ($opt_i ? 1 : 0) 452 + ($opt_a ? 1 : 0) 453 + ($opt_e ? 1 : 0) 454 + ($opt_r ? 1 : 0) 455 + ($opt_v ? 1 : 0) 456 + ($opt_d ? 1 : 0) 457 + ($opt_n ? 1 : 0) 458 + ($opt_bn ? 1 : 0) 459 + ($opt_qa ? 1 : 0) 460 + ($opt_R ? 1 : 0) 461 + ($opt_s ? 1 : 0) 462 + ($opt_lts ? 1 : 0) 463 + ($opt_team ? 1 : 0) 464 + ($opt_bpo ? 1 : 0) 465 + ($opt_stable ? 1 : 0) 466 + ($opt_l ? 1 : 0) > 1; 467 468if ($opt_s) { 469 $opt_u = "high"; 470} 471 472if (defined $opt_u) { 473 fatal "Urgency can only be one of: low, medium, high, critical, emergency" 474 unless $opt_u =~ /^(low|medium|high|critical|emergency)$/; 475} 476 477# See if we're Debian, Ubuntu or someone else, if we can 478my $vendor; 479if (defined $opt_vendor && $opt_vendor) { 480 $vendor = $opt_vendor; 481} else { 482 if (defined $opt_D) { 483 # Try to guess the vendor based on the given distribution name 484 my $distro = $opt_D; 485 $distro =~ s/-.*//; 486 my $deb_info = get_debian_distro_info(); 487 my $ubu_info = get_ubuntu_distro_info(); 488 if ($deb_info != 0 and $deb_info->valid($distro)) { 489 $vendor = 'Debian'; 490 } elsif ($ubu_info != 0 and $ubu_info->valid($distro)) { 491 $vendor = 'Ubuntu'; 492 } 493 } 494 if (not defined $vendor) { 495 # Get the vendor from dpkg-vendor (dpkg-vendor --query Vendor) 496 $vendor = get_current_vendor(); 497 } 498} 499$vendor ||= 'Debian'; 500if ($vendor eq 'Ubuntu' 501 and ($opt_n or $opt_bn or $opt_qa or $opt_bpo or $opt_stable or $opt_lts)) 502{ 503 $vendor = 'Debian'; 504} 505 506# Check the distro name given. 507if (defined $opt_D) { 508 if ($vendor eq 'Debian') { 509 unless ($opt_D 510 =~ /^(experimental|unstable|sid|UNRELEASED|((old){0,2}stable|testing|wheezy|jessie|stretch|buster|bullseye)(-proposed-updates|-security)?|proposed-updates)$/ 511 ) { 512 my $deb_info = get_debian_distro_info(); 513 my ($oldstable_backports, $stable_backports) = ("", ""); 514 if ($deb_info == 0) { 515 warn 516"$progname warning: Unable to determine Debian's backport distributions.\n"; 517 } else { 518 $stable_backports = $deb_info->stable() . "-backports"; 519# Silence any potential warnings $deb_info emits when oldstable is no longer supported 520 local $SIG{__WARN__} = sub { }; 521 my $oldstable = $deb_info->old(); 522 $oldstable_backports = "$oldstable-backports" if $oldstable; 523 } 524 if ( $deb_info == 0 525 || $opt_D 526 !~ m/^(\Q$stable_backports\E|\Q$oldstable_backports\E)$/) { 527 $stable_backports = ", " . $stable_backports 528 if $stable_backports; 529 $oldstable_backports = ", " . $oldstable_backports 530 if $oldstable_backports; 531 warn "$progname warning: Recognised distributions are: \n" 532 . "experimental, unstable, testing, stable, oldstable, oldoldstable,\n" 533 . "{bullseye,buster,stretch,jessie,wheezy}-proposed-updates,\n" 534 . "{testing,stable,oldstable,oldoldstable}-proposed-updates,\n" 535 . "{bullseye,buster,stretch,jessie,wheezy}-security,\n" 536 . "{testing,stable,oldstable,oldoldstable}}-security$oldstable_backports$stable_backports and UNRELEASED.\n" 537 . "Using your request anyway.\n"; 538 $warnings++ if not $opt_force_dist; 539 } 540 } 541 } elsif ($vendor eq 'Ubuntu') { 542 if ($opt_D eq 'UNRELEASED') { 543 ; 544 } else { 545 my $ubu_release = $opt_D; 546 $ubu_release =~ s/(-updates|-security|-proposed|-backports)$//; 547 my $ubu_info = get_ubuntu_distro_info(); 548 if ($ubu_info == 0) { 549 warn "$progname warning: Unable to determine if $ubu_release " 550 . "is a valid Ubuntu release.\n"; 551 } elsif (!$ubu_info->valid($ubu_release)) { 552 warn "$progname warning: Recognised distributions are:\n{" 553 . join(',', $ubu_info->supported()) 554 . "}{,-updates,-security,-proposed,-backports} and UNRELEASED.\n" 555 . "Using your request anyway.\n"; 556 $warnings++ if not $opt_force_dist; 557 } 558 } 559 } else { 560 # Unknown vendor, skip check 561 } 562} 563 564fatal 565"--closes should not be used with --news; put bug numbers in the changelog not the NEWS file" 566 if $opt_news && @closes; 567 568# hm, this can probably be used with more than just -i. 569fatal "--package can only be used with --create, --increment and --newversion" 570 if $opt_package && !($opt_create || $opt_i || $opt_v); 571 572my $changelog_path = $opt_c || $ENV{'CHANGELOG'} || 'debian/changelog'; 573my $real_changelog_path = $changelog_path; 574if ($opt_news) { $changelog_path = $opt_news; } 575if ($changelog_path ne 'debian/changelog' and not $opt_news) { 576 $check_dirname_level = 0; 577} 578 579# extra --create checks 580fatal "--package cannot be used when creating a NEWS file" 581 if $opt_package && $opt_news; 582 583if ($opt_create) { 584 if ( $opt_a 585 || $opt_i 586 || $opt_e 587 || $opt_r 588 || $opt_b 589 || $opt_n 590 || $opt_bn 591 || $opt_qa 592 || $opt_R 593 || $opt_s 594 || $opt_lts 595 || $opt_team 596 || $opt_bpo 597 || $opt_stable 598 || $opt_l 599 || $opt_allow_lower) { 600 warn 601"$progname warning: ignoring -a/-i/-e/-r/-b/--allow-lower-version/-n/--bin-nmu/-q/--qa/-R/-s/--lts/--team/--bpo/--stable,-l options with --create\n"; 602 $warnings++; 603 } 604 if ($opt_package && $opt_d) { 605 fatal "Can only use one of --package and -d"; 606 } 607} 608 609@closes = split(/,/, join(',', @closes)); 610map { s/^\#//; } @closes; # remove any leading # from bug numbers 611 612# We'll process the rest of the command line later. 613 614# Look for the changelog 615my $chdir = 0; 616if (!$opt_create) { 617 if ($changelog_path eq 'debian/changelog' or $opt_news) { 618 until (-f $changelog_path) { 619 $chdir = 1; 620 chdir '..' or fatal "Can't chdir ..: $!"; 621 if (cwd() eq '/') { 622 fatal 623"Cannot find $changelog_path anywhere!\nAre you in the source code tree?\n(You could use --create if you wish to create this file.)"; 624 } 625 } 626 627 # Can't write, so stop now. 628 if (!-w $changelog_path) { 629 fatal "$changelog_path is not writable!"; 630 } 631 } else { 632 unless (-f $changelog_path) { 633 fatal 634"Cannot find $changelog_path!\nAre you in the correct directory?\n(You could use --create if you wish to create this file.)"; 635 } 636 637 # Can't write, so stop now. 638 if (!-w $changelog_path) { 639 fatal "$changelog_path is not writable!"; 640 } 641 } 642} else { # $opt_create 643 unless (-d dirname $changelog_path) { 644 fatal "Cannot find " 645 . (dirname $changelog_path) 646 . " directory!\nAre you in the correct directory?"; 647 } 648 if (-f $changelog_path) { 649 fatal "File $changelog_path already exists!"; 650 } 651 unless (-w dirname $changelog_path) { 652 fatal "Cannot find " 653 . (dirname $changelog_path) 654 . " directory!\nAre you in the correct directory?"; 655 } 656 if ($opt_news && !-f 'debian/changelog') { 657 fatal "I can't create $opt_news without debian/changelog present"; 658 } 659} 660 661##### 662 663# Find the current version number etc. 664my $changelog; 665my $PACKAGE = 'PACKAGE'; 666my $VERSION = 'VERSION'; 667my $MAINTAINER = 'MAINTAINER'; 668my $EMAIL = 'EMAIL'; 669my $DISTRIBUTION = 'UNRELEASED'; 670# when updating the lines below also update the help text, the manpage and the testcases. 671my %dists = ( 672 8, 'jessie', 9, 'stretch', 10, 'buster', 673 11, 'bullseye', 12, 'bookworm', 13, 'trixie' 674); 675my $lts_dist = '9'; 676my $latest_dist = '11'; 677# dist guessed from backports, SRU, security uploads... 678my $guessed_dist = ''; 679my $CHANGES = ''; 680# Changelog urgency, possibly propagated to NEWS files 681my $CL_URGENCY = ''; 682 683if (!$opt_create || ($opt_create && $opt_news)) { 684 my $file = $opt_create ? 'debian/changelog' : $changelog_path; 685 $changelog = changelog_parse(file => $file); 686 687 # Now we've read the changelog, set some variables and then 688 # let's check the directory name is sensible 689 fatal "No package name in changelog!" 690 unless exists $changelog->{Source}; 691 $PACKAGE = $changelog->{Source}; 692 fatal "No version number in changelog!" 693 unless exists $changelog->{Version}; 694 $VERSION = $changelog->{Version}; 695 fatal "No maintainer in changelog!" 696 unless exists $changelog->{Maintainer}; 697 $changelog->{Maintainer} = decode_utf8($changelog->{Maintainer}); 698 ($MAINTAINER, $EMAIL) = ($changelog->{Maintainer} =~ /^([^<]*) <(.*)>/); 699 $MAINTAINER ||= ''; 700 fatal "No distribution in changelog!" 701 unless exists $changelog->{Distribution}; 702 703 if ($vendor eq 'Ubuntu') { 704 # In Ubuntu the development release regularly changes, don't just copy 705 # the previous name. 706 $DISTRIBUTION = get_ubuntu_devel_distro(); 707 } else { 708 $DISTRIBUTION = $changelog->{Distribution}; 709 } 710 fatal "No changes in changelog!" 711 unless exists $changelog->{Changes}; 712 713 # Find the current package version 714 if ($opt_news) { 715 my $found_version = 0; 716 my $found_urgency = 0; 717 my $clog = changelog_parse(file => $real_changelog_path); 718 $VERSION = $clog->{Version}; 719 $VERSION =~ s/~$//; 720 721 $CL_URGENCY = $clog->{Urgency}; 722 } 723 724 # Is the directory name acceptable? 725 if ($check_dirname_level == 2 726 or ($check_dirname_level == 1 and $chdir)) { 727 my $re = $check_dirname_regex; 728 $re =~ s/PACKAGE/\\Q$PACKAGE\\E/g; 729 my $gooddir; 730 if ($re =~ m%/%) { $gooddir = eval "cwd() =~ /^$re\$/;"; } 731 else { $gooddir = eval "basename(cwd()) =~ /^$re\$/;"; } 732 733 if (!$gooddir) { 734 my $pwd = cwd(); 735 fatal <<"EOF"; 736Found debian/changelog for package $PACKAGE in the directory 737 $pwd 738but this directory name does not match the package name according to the 739regex $check_dirname_regex. 740 741To run $progname on this package, see the --check-dirname-level and 742--check-dirname-regex options; run $progname --help for more info. 743EOF 744 } 745 } 746} else { 747 # we're creating and we don't know much about our package 748 if ($opt_d) { 749 my $pwd = basename(cwd()); 750 # The directory name should be <package>-<version> 751 my $version_chars = '0-9a-zA-Z+\.\-'; 752 if ($pwd =~ m/^([a-z0-9][a-z0-9+\-\.]+)-([0-9][$version_chars]*)$/) { 753 $PACKAGE = $1; 754 $VERSION = "$2-1"; # introduce a Debian version of -1 755 } elsif ($pwd =~ m/^[a-z0-9][a-z0-9+\-\.]+$/) { 756 $PACKAGE = $pwd; 757 } else { 758 # don't know anything 759 } 760 } 761 if ($opt_v) { 762 $VERSION = $opt_v; 763 } 764 if ($opt_D) { 765 $DISTRIBUTION = $opt_D; 766 } 767} 768 769if ($opt_package) { 770 if ($opt_package =~ m/^[a-z0-9][a-z0-9+\-\.]+$/) { 771 $PACKAGE = $opt_package; 772 } else { 773 warn 774"$progname warning: illegal package name used with --package: $opt_package\n"; 775 $warnings++; 776 } 777} 778 779# Clean up after old versions of debchange 780if (-f "debian/RELEASED") { 781 unlink("debian/RELEASED"); 782} 783 784if (-e "$changelog_path.dch") { 785 fatal "The backup file $changelog_path.dch already exists --\n" 786 . "please move it before trying again"; 787} 788 789# Is this a native Debian package, i.e., does it have a - in the 790# version number? 791(my $EPOCH) = ($VERSION =~ /^(\d+):/); 792(my $SVERSION = $VERSION) =~ s/^\d+://; 793(my $UVERSION = $SVERSION) =~ s/-[^-]*$//; 794 795# Check, sanitise and decode these environment variables 796check_env_utf8('DEBFULLNAME'); 797check_env_utf8('NAME'); 798check_env_utf8('DEBEMAIL'); 799check_env_utf8('EMAIL'); 800check_env_utf8('UBUMAIL'); 801 802if (exists $env{'DEBEMAIL'} and $env{'DEBEMAIL'} =~ /^(.*)\s+<(.*)>$/) { 803 $env{'DEBFULLNAME'} = $1 unless exists $env{'DEBFULLNAME'}; 804 $env{'DEBEMAIL'} = $2; 805} 806if (!exists $env{'DEBEMAIL'} or !exists $env{'DEBFULLNAME'}) { 807 if (exists $env{'EMAIL'} and $env{'EMAIL'} =~ /^(.*)\s+<(.*)>$/) { 808 $env{'DEBFULLNAME'} = $1 unless exists $env{'DEBFULLNAME'}; 809 $env{'EMAIL'} = $2; 810 } 811} 812if (exists $env{'UBUMAIL'} and $env{'UBUMAIL'} =~ /^(.*)\s+<(.*)>$/) { 813 $env{'DEBFULLNAME'} = $1 unless exists $env{'DEBFULLNAME'}; 814 $env{'UBUMAIL'} = $2; 815} 816 817# Now use the gleaned values to determine our MAINTAINER and EMAIL values 818if (!$opt_m and !$opt_M) { 819 if (exists $env{'DEBFULLNAME'}) { 820 $MAINTAINER = $env{'DEBFULLNAME'}; 821 } elsif (exists $env{'NAME'}) { 822 $MAINTAINER = $env{'NAME'}; 823 } else { 824 my @pw = getpwuid $<; 825 if ($pw[6]) { 826 if (my $pw = decode_utf8($pw[6])) { 827 $pw =~ s/,.*//; 828 $MAINTAINER = $pw; 829 } else { 830 warn 831"$progname warning: passwd full name field for uid $<\nis not UTF-8 encoded; ignoring\n"; 832 $warnings++; 833 } 834 } 835 } 836 # Otherwise, $MAINTAINER retains its default value of the last 837 # changelog entry 838 839 # Email is easier 840 if ($vendor eq 'Ubuntu' and exists $env{'UBUMAIL'}) { 841 $EMAIL = $env{'UBUMAIL'}; 842 } elsif (exists $env{'DEBEMAIL'}) { 843 $EMAIL = $env{'DEBEMAIL'}; 844 } elsif (exists $env{'EMAIL'}) { 845 $EMAIL = $env{'EMAIL'}; 846 } else { 847 warn 848"$progname warning: neither DEBEMAIL nor EMAIL environment variable is set\n"; 849 $warnings++; 850 my $addr; 851 if (open MAILNAME, '/etc/mailname') { 852 warn 853"$progname warning: building email address from username and mailname\n"; 854 $warnings++; 855 chomp($addr = <MAILNAME>); 856 close MAILNAME; 857 } 858 if (!$addr) { 859 warn 860"$progname warning: building email address from username and FQDN\n"; 861 $warnings++; 862 chomp($addr = `hostname --fqdn 2>/dev/null`); 863 $addr = undef if $?; 864 } 865 if ($addr) { 866 my $user = getpwuid $<; 867 if (!$user) { 868 $addr = undef; 869 } else { 870 $addr = "$user\@$addr"; 871 } 872 } 873 $EMAIL = $addr if $addr; 874 } 875 # Otherwise, $EMAIL retains its default value of the last changelog entry 876} # if (! $opt_m and ! $opt_M) 877 878if ($opt_M) { 879 if (-f 'debian/control') { 880 my $parser = Dpkg::Control->new(type => CTRL_INFO_SRC); 881 $parser->load('debian/control'); 882 my $maintainer = decode_utf8($parser->{Maintainer}); 883 if ($maintainer =~ /^(.*)\s+<(.*)>$/) { 884 $MAINTAINER = $1; 885 $EMAIL = $2; 886 } else { 887 fatal "$progname: invalid debian/control Maintainer field value\n"; 888 } 889 } else { 890 fatal "Missing file debian/control"; 891 } 892} 893 894##### 895 896if ( 897 $opt_auto_nmu 898 and !$opt_v 899 and !$opt_l 900 and !$opt_s 901 and !$opt_lts 902 and !$opt_team 903 and !$opt_qa 904 and !$opt_R 905 and !$opt_bpo 906 and !$opt_bn 907 and !$opt_n 908 and !$opt_c 909 and !$opt_stable 910 and !(exists $ENV{'CHANGELOG'} and length $ENV{'CHANGELOG'}) 911 and !$opt_M 912 and !$opt_create 913 and !$opt_a_passed 914 and !$opt_r 915 and !$opt_e 916 and $vendor ne 'Ubuntu' 917 and $vendor ne 'Tanglu' 918 and !( 919 $opt_release_heuristic eq 'changelog' 920 and $changelog->{Distribution} eq 'UNRELEASED' 921 and !$opt_i_passed 922 ) 923) { 924 925 if (-f 'debian/control') { 926 my $parser = Dpkg::Control->new(type => CTRL_INFO_SRC); 927 $parser->load('debian/control'); 928 my $uploader = decode_utf8($parser->{Uploaders}) || ''; 929 $uploader =~ s/^\s+//; 930 my $maintainer = decode_utf8($parser->{Maintainer}); 931 my @uploaders = split(/\s*,\s*/, $uploader); 932 933 my $packager = "$MAINTAINER <$EMAIL>"; 934 935 if ( $maintainer !~ m/<packages\@qa\.debian\.org>/ 936 and !grep { $_ eq $packager } ($maintainer, @uploaders) 937 and $packager ne $changelog->{Maintainer} 938 and !$opt_team) { 939 $opt_n = 1; 940 $opt_a = 0; 941 } 942 } else { 943 fatal "Missing file debian/control"; 944 } 945} 946##### 947 948# Do we need to generate "closes" entries? 949 950my @closes_text = (); 951my $initial_release = 0; 952if (@closes and $opt_query) { # and we have to query the BTS 953 if (!Devscripts::Debbugs::have_soap) { 954 warn 955"$progname warning: libsoap-lite-perl not installed, so cannot query the bug-tracking system\n"; 956 $opt_query = 0; 957 $warnings++; 958 # This will now go and execute the "if (@closes and ! $opt_query)" code 959 } else { 960 my $bugs = Devscripts::Debbugs::select("src:" . $PACKAGE); 961 my $statuses = Devscripts::Debbugs::status( 962 map { [bug => $_, indicatesource => 1] } @{$bugs}); 963 if ($statuses eq "") { 964 warn "$progname: No bugs found for package $PACKAGE\n"; 965 } 966 foreach my $close (@closes) { 967 if ($statuses and exists $statuses->{$close}) { 968 my $title = $statuses->{$close}->{subject}; 969 my $pkg = $statuses->{$close}->{package}; 970 $title =~ s/^($pkg|$PACKAGE): //; 971 push @closes_text, 972"Fix \"$title\" <explain what you changed and why> (Closes: \#$close)\n"; 973 } else { # not our package, or wnpp 974 my $bug = Devscripts::Debbugs::status( 975 [bug => $close, indicatesource => 1]); 976 if ($bug eq "") { 977 warn 978"$progname warning: unknown bug \#$close does not belong to $PACKAGE,\n disabling closing changelog entry\n"; 979 $warnings++; 980 push @closes_text, 981 "Closes?? \#$close: UNKNOWN BUG IN WRONG PACKAGE!!\n"; 982 } else { 983 my $bugtitle = $bug->{$close}->{subject}; 984 $bugtitle ||= ''; 985 my $bugpkg = $bug->{$close}->{package}; 986 $bugpkg ||= '?'; 987 my $bugsrcpkg = $bug->{$close}->{source}; 988 $bugsrcpkg ||= '?'; 989 if ($bugsrcpkg eq $PACKAGE) { 990 warn 991"$progname warning: bug \#$close appears to be already archived,\n disabling closing changelog entry\n"; 992 $warnings++; 993 push @closes_text, 994"Closes?? \#$close: ALREADY ARCHIVED? $bugtitle!!\n"; 995 } elsif ($bugpkg eq 'wnpp') { 996 if ($bugtitle =~ /(^(O|RFA|ITA): )/) { 997 push @closes_text, 998"New maintainer. (Closes: \#$close: $bugtitle)\n"; 999 } elsif ($bugtitle =~ /(^(RFP|ITP): )/) { 1000 push @closes_text, 1001"Initial release. (Closes: \#$close: $bugtitle)\n"; 1002 $initial_release = 1; 1003 } 1004 } else { 1005 warn 1006"$progname warning: bug \#$close belongs to package $bugpkg (src $bugsrcpkg),\n not to $PACKAGE: disabling closing changelog entry\n"; 1007 $warnings++; 1008 push @closes_text, 1009 "Closes?? \#$close: WRONG PACKAGE!! $bugtitle\n"; 1010 } 1011 } 1012 } 1013 } 1014 } 1015} 1016 1017if (@closes and !$opt_query) { # and we don't have to query the BTS 1018 foreach my $close (@closes) { 1019 unless ($close =~ /^\d{3,}$/) { 1020 warn "$progname warning: Bug number $close is invalid; ignoring\n"; 1021 $warnings++; 1022 next; 1023 } 1024 push @closes_text, "Closes: \#$close: \n"; 1025 } 1026} 1027 1028# Get a possible changelog entry from the command line 1029my $ARGS = join(' ', @ARGV); 1030my $TEXT = decode_utf8($ARGS); 1031my $EMPTY_TEXT = 0; 1032 1033if (@ARGV and !$TEXT) { 1034 if ($ARGS) { 1035 warn 1036"$progname warning: command-line changelog entry not UTF-8 encoded; ignoring\n"; 1037 $TEXT = ''; 1038 } else { 1039 $EMPTY_TEXT = 1; 1040 } 1041} 1042 1043# Get the date 1044my $DATE; 1045{ 1046 local $ENV{TZ} = $opt_tz if $opt_tz; 1047 $DATE = strftime "%a, %d %b %Y %T %z", localtime(); 1048} 1049 1050if ($opt_news && !$opt_i && !$opt_a) { 1051 if ($VERSION eq $changelog->{Version} && !$opt_v && !$opt_l) { 1052 $opt_a = 1; 1053 } else { 1054 $opt_i = 1; 1055 } 1056} 1057 1058# Are we going to have to figure things out for ourselves? 1059if ( !$opt_i 1060 && !$opt_v 1061 && !$opt_d 1062 && !$opt_a 1063 && !$opt_e 1064 && !$opt_r 1065 && !$opt_n 1066 && !$opt_bn 1067 && !$opt_qa 1068 && !$opt_R 1069 && !$opt_s 1070 && !$opt_lts 1071 && !$opt_team 1072 && !$opt_bpo 1073 && !$opt_stable 1074 && !$opt_l 1075 && !$opt_create) { 1076 # Yes, we are 1077 if ($opt_release_heuristic eq 'log') { 1078 my @UPFILES = glob("../$PACKAGE\_$SVERSION\_*.upload"); 1079 if (@UPFILES > 1) { 1080 fatal "Found more than one appropriate .upload file!\n" 1081 . "Please use an explicit -a, -i or -v option instead."; 1082 } elsif (@UPFILES == 0) { 1083 $opt_a = 1; 1084 } else { 1085 open UPFILE, "<${UPFILES[0]}" 1086 or fatal "Couldn't open .upload file for reading: $!\n" 1087 . "Please use an explicit -a, -i or -v option instead."; 1088 while (<UPFILE>) { 1089 if ( 1090m%^(s|Successfully uploaded) (/.*/)?\Q$PACKAGE\E\_\Q$SVERSION\E\_[\w\-\+]+\.changes % 1091 ) { 1092 $opt_i = 1; 1093 last; 1094 } 1095 } 1096 close UPFILE 1097 or fatal "Problems experienced reading .upload file: $!\n" 1098 . "Please use an explicit -a, -i or -v option instead."; 1099 if (!$opt_i) { 1100 warn 1101"$progname warning: A successful upload of the current version was not logged\n" 1102 . "in the upload log file; adding log entry to current version.\n"; 1103 $opt_a = 1; 1104 } 1105 } 1106 } elsif ($opt_release_heuristic eq 'changelog') { 1107 if ($changelog->{Distribution} eq 'UNRELEASED') { 1108 $opt_a = 1; 1109 } elsif ($EMPTY_TEXT == 1) { 1110 $opt_a = 1; 1111 } else { 1112 $opt_i = 1; 1113 } 1114 } else { 1115 fatal "Bad release heuristic value"; 1116 } 1117} 1118 1119# Open in anticipation.... 1120unless ($opt_create) { 1121 open S, $changelog_path 1122 or fatal "Cannot open existing $changelog_path: $!"; 1123 1124 # Read the first stanza from the changelog file 1125 # We do this directly rather than reusing $changelog->{Changes} 1126 # so that we have the verbatim changes rather than a (albeit very 1127 # slightly) reformatted version. See Debian bug #452806 1128 1129 while (<S>) { 1130 last if /^ --/; 1131 1132 $CHANGES .= $_; 1133 } 1134 1135 chomp $CHANGES; 1136 1137 # Reset file pointer 1138 seek(S, 0, 0); 1139} 1140open O, ">$changelog_path.dch" 1141 or fatal "Cannot write to temporary file: $!"; 1142# Turn off form feeds; taken from perlform 1143select((select(O), $^L = "")[0]); 1144 1145# Note that we now have to remove it 1146my $tmpchk = 1; 1147my ($NEW_VERSION, $NEW_SVERSION, $NEW_UVERSION); 1148my $line; 1149my $optionsok = 0; 1150my $merge = 0; 1151 1152if (( 1153 $opt_i 1154 || $opt_n 1155 || $opt_bn 1156 || $opt_qa 1157 || $opt_R 1158 || $opt_s 1159 || $opt_lts 1160 || $opt_team 1161 || $opt_bpo 1162 || $opt_stable 1163 || $opt_l 1164 || $opt_v 1165 || $opt_d 1166 || ($opt_news && $VERSION ne $changelog->{Version})) 1167 && !$opt_create 1168) { 1169 1170 $optionsok = 1; 1171 1172 # Check that a given explicit version number is sensible. 1173 if ($opt_v || $opt_d) { 1174 if ($opt_v) { 1175 $NEW_VERSION = $opt_v; 1176 } else { 1177 my $pwd = basename(cwd()); 1178 # The directory name should be <package>-<version> 1179 my $version_chars = '0-9a-zA-Z+\.~'; 1180 $version_chars .= ':' if defined $EPOCH; 1181 $version_chars .= '\-' if $UVERSION ne $SVERSION; 1182 if ($pwd =~ m/^\Q$PACKAGE\E-([0-9][$version_chars]*)$/) { 1183 $NEW_VERSION = $1; 1184 if ($NEW_VERSION eq $UVERSION) { 1185 # So it's a Debian-native package 1186 if ($SVERSION eq $UVERSION) { 1187 fatal 1188"New version taken from directory ($NEW_VERSION) is equal to\n" 1189 . "the current version number ($UVERSION)!"; 1190 } 1191 # So we just increment the Debian revision 1192 warn 1193"$progname warning: Incrementing Debian revision without altering\nupstream version number.\n"; 1194 $VERSION =~ /^(.*?)([a-yA-Y][a-zA-Z]*|\d*)$/; 1195 my $end = $2; 1196 if ($end eq '') { 1197 fatal 1198"Cannot determine new Debian revision; please use -v option!"; 1199 } 1200 $end++; 1201 $NEW_VERSION = "$1$end"; 1202 } else { 1203 $NEW_VERSION = "$EPOCH:$NEW_VERSION" if defined $EPOCH; 1204 $NEW_VERSION .= "-1"; 1205 } 1206 } else { 1207 fatal 1208"The directory name must be <package>-<version> for -d to work!\n" 1209 . "No underscores allowed!"; 1210 } 1211 # Don't try renaming the directory in this case! 1212 $opt_p = 1; 1213 } 1214 1215 if (version_compare($VERSION, $NEW_VERSION) == 1) { 1216 if ($opt_b 1217 or ($opt_allow_lower and $NEW_VERSION =~ /$opt_allow_lower/)) { 1218 warn 1219"$progname warning: new version ($NEW_VERSION) is less than\n" 1220 . "the current version number ($VERSION).\n"; 1221 } else { 1222 fatal "New version specified ($NEW_VERSION) is less than\n" 1223 . "the current version number ($VERSION)! Use -b to force."; 1224 } 1225 } 1226 1227 ($NEW_SVERSION = $NEW_VERSION) =~ s/^\d+://; 1228 ($NEW_UVERSION = $NEW_SVERSION) =~ s/-[^-]*$//; 1229 } 1230 1231 # We use the following criteria for the version and release number: 1232 # the last component of the version number is used as the 1233 # release number. If this is not a Debian native package, then the 1234 # upstream version number is everything up to the final '-', not 1235 # including epochs. 1236 1237 if (!$NEW_VERSION) { 1238 if ($VERSION =~ /(.*?)([a-yA-Y][a-zA-Z]*|\d+)([+~])?$/i) { 1239 my $extra = $3 || ''; 1240 my $useextra = 0; 1241 my $end = $2; 1242 my $start = $1; 1243 # If it's not already an NMU make it so 1244 # otherwise we can be safe if we behave like dch -i 1245 1246 if ( 1247 ($opt_n or $opt_s) 1248 and $vendor ne 'Ubuntu' 1249 and $vendor ne 'Tanglu' 1250 and ( ($VERSION eq $UVERSION and not $start =~ /\+nmu/) 1251 or ($VERSION ne $UVERSION and not $start =~ /\.$/)) 1252 ) { 1253 1254 if ($VERSION eq $UVERSION) { 1255 # First NMU of a Debian native package 1256 $end .= "+nmu1"; 1257 } else { 1258 $end += 0.1; 1259 } 1260 } elsif ($opt_bn and not $start =~ /\+b/) { 1261 $end .= "+b1"; 1262 } elsif ($opt_qa and $start =~ /(.*?)-(\d+)\.$/) { 1263 # Drop NMU revision when doing a QA upload 1264 my $upstream_version = $1; 1265 my $debian_revision = $2; 1266 $debian_revision++; 1267 $start = "$upstream_version-$debian_revision"; 1268 $end = ""; 1269 } elsif ($opt_R 1270 and $vendor eq 'Ubuntu' 1271 and not $start =~ /build/ 1272 and not $start =~ /ubuntu/) { 1273 $end .= "build1"; 1274 } elsif ($opt_R 1275 and $vendor eq 'Tanglu' 1276 and not "$start$end" =~ /(b\d+)$/ 1277 and not $start =~ /tanglu/) { 1278 $end .= "b1"; 1279 } elsif ($opt_bpo and not $start =~ /~bpo[0-9]+\+$/) { 1280 # If it's not already a backport make it so 1281 # otherwise we can be safe if we behave like dch -i 1282 $end .= "~bpo$latest_dist+1"; 1283 } elsif ($opt_stable and not $start =~ /\+deb\d+u/) { 1284 $end .= "+deb${latest_dist}u1"; 1285 } elsif ($opt_lts and not $start =~ /\+deb\d+u/) { 1286 $end .= "+deb${lts_dist}u1"; 1287 $guessed_dist = $dists{$lts_dist} . '-security'; 1288 } elsif ($opt_l and not $start =~ /\Q$opt_l\E/) { 1289 # If it's not already a local package make it so 1290 # otherwise we can be safe if we behave like dch -i 1291 $end .= $opt_l . "1"; 1292 } elsif (!$opt_news) { 1293 # Don't bump the version of a NEWS file in this case as we're 1294 # using the version from the changelog 1295 if ( ($opt_i or $opt_s) 1296 and $vendor eq 'Ubuntu' 1297 and $start !~ /(ubuntu|~ppa)(\d+\.)*$/ 1298 and not $opt_U) { 1299 1300 if ($start =~ /build/) { 1301 # Drop buildX suffix in favor of ubuntu1 1302 $start =~ s/build//; 1303 $end = ""; 1304 } 1305 $end .= "ubuntu1"; 1306 } elsif (($opt_i or $opt_s) 1307 and $vendor eq 'Tanglu' 1308 and $start !~ /(tanglu)(\d+\.)*$/ 1309 and not $opt_U) { 1310 1311 if ("$start$end" =~ /(b\d+)$/) { 1312 # Drop bX suffix in favor of tanglu1 1313 $start =~ s/b$//; 1314 $end = ""; 1315 } 1316 $end .= "tanglu1"; 1317 } else { 1318 $end++; 1319 } 1320 1321 # Attempt to set the distribution for a stable upload correctly 1322 # based on the version of the previous upload 1323 if ($opt_stable || $opt_bpo || $opt_s || $opt_lts) { 1324 my $previous_dist = $start; 1325 $previous_dist =~ s/^.*[+~](?:deb|bpo)(\d+)(?:u\+)$/$1/; 1326 if ( defined $previous_dist 1327 and defined $dists{$previous_dist}) { 1328 if ($opt_s || $opt_lts) { 1329 $guessed_dist 1330 = $dists{$previous_dist} . '-security'; 1331 } elsif ($opt_bpo) { 1332 +$guessed_dist 1333 = $dists{$previous_dist} . '-backports'; 1334 } elsif ($opt_stable) { 1335 $guessed_dist = $dists{$previous_dist}; 1336 } 1337 } elsif ($opt_s) { 1338 $guessed_dist = $dists{$latest_dist} . '-security'; 1339 } elsif ($opt_lts) { 1340 $guessed_dist = $dists{$lts_dist} . '-security'; 1341 } else { 1342 # Fallback to using the previous distribution 1343 $guessed_dist = $changelog->{Distribution}; 1344 } 1345 } 1346 1347 if ( 1348 !( 1349 $opt_s 1350 or $opt_n 1351 or $vendor eq 'Ubuntu' 1352 or $vendor eq 'Tanglu' 1353 ) 1354 ) { 1355 if ($start =~ /(.*?)-(\d+)\.$/) { 1356 # Drop NMU revision 1357 my $upstream_version = $1; 1358 my $debian_revision = $2; 1359 $debian_revision++; 1360 $start = "$upstream_version-$debian_revision"; 1361 $end = ""; 1362 } 1363 } 1364 1365 if (!($opt_qa or $opt_bpo or $opt_stable or $opt_l)) { 1366 $useextra = 1; 1367 } 1368 } 1369 $NEW_VERSION = "$start$end"; 1370 if ($useextra) { 1371 $NEW_VERSION .= $extra; 1372 } 1373 ($NEW_SVERSION = $NEW_VERSION) =~ s/^\d+://; 1374 ($NEW_UVERSION = $NEW_SVERSION) =~ s/-[^-]*$//; 1375 } else { 1376 fatal "Error parsing version number: $VERSION"; 1377 } 1378 } 1379 1380 if ($NEW_VERSION eq $NEW_UVERSION and $VERSION ne $UVERSION) { 1381 warn 1382"$progname warning: New package version is Debian native whilst previous version was not\n"; 1383 } elsif ($NEW_VERSION ne $NEW_UVERSION and $VERSION eq $UVERSION) { 1384 warn 1385"$progname warning: Previous package version was Debian native whilst new version is not\n" 1386 unless $opt_n or $opt_s; 1387 } 1388 1389 if ($opt_bpo) { 1390 $guessed_dist ||= $dists{$latest_dist} . '-backports'; 1391 } 1392 if ($opt_stable) { 1393 $guessed_dist ||= $dists{$latest_dist}; 1394 } 1395 my $distribution 1396 = $opt_D 1397 || $guessed_dist 1398 || ( 1399 ($opt_release_heuristic eq 'changelog') 1400 ? "UNRELEASED" 1401 : $DISTRIBUTION 1402 ); 1403 1404 my $urgency = $opt_u; 1405 if ($opt_news) { 1406 $urgency ||= $CL_URGENCY; 1407 } 1408 $urgency ||= 'medium'; 1409 1410 if ( ($opt_v or $opt_i or $opt_l or $opt_d) 1411 and $opt_release_heuristic eq 'changelog' 1412 and $changelog->{Distribution} eq 'UNRELEASED') { 1413 1414 $merge = 1; 1415 } else { 1416 print O "$PACKAGE ($NEW_VERSION) $distribution; urgency=$urgency"; 1417 print O ", binary-only=yes" if ($opt_bn); 1418 print O "\n\n"; 1419 if ($opt_n && !$opt_news) { 1420 print O " * Non-maintainer upload.\n"; 1421 $line = 1; 1422 } elsif ($opt_bn && !$opt_news) { 1423 my $arch = qx/dpkg-architecture -qDEB_BUILD_ARCH/; 1424 chomp($arch); 1425 print O 1426" * Binary-only non-maintainer upload for $arch; no source changes.\n"; 1427 $line = 1; 1428 } elsif ($opt_qa && !$opt_news) { 1429 print O " * QA upload.\n"; 1430 $line = 1; 1431 } elsif ($opt_s && !$opt_news) { 1432 if ($vendor eq 'Ubuntu' or $vendor eq 'Tanglu') { 1433 print O " * SECURITY UPDATE:\n"; 1434 print O " * References\n"; 1435 } else { 1436 print O " * Non-maintainer upload by the Security Team.\n"; 1437 } 1438 $line = 1; 1439 } elsif ($opt_lts && !$opt_news) { 1440 print O " * Non-maintainer upload by the LTS Security Team.\n"; 1441 $line = 1; 1442 } elsif ($opt_team && !$opt_news) { 1443 print O " * Team upload.\n"; 1444 $line = 1; 1445 } elsif ($opt_bpo && !$opt_news) { 1446 print O " * Rebuild for $guessed_dist.\n"; 1447 $line = 1; 1448 } 1449 if (@closes_text or $TEXT or $EMPTY_TEXT) { 1450 foreach (@closes_text) { format_line($_, 1); } 1451 if (length $TEXT) { format_line($TEXT, 1); } 1452 } elsif ($opt_news) { 1453 print O " \n"; 1454 } else { 1455 print O " * \n"; 1456 } 1457 $line += 3; 1458 print O "\n -- $MAINTAINER <$EMAIL> $DATE\n\n"; 1459 1460 # Copy the old changelog file to the new one 1461 local $/ = undef; 1462 print O <S>; 1463 } 1464} 1465if (($opt_r || $opt_a || $merge) && !$opt_create) { 1466 # This means we just have to generate a new * entry in changelog 1467 # and if a multi-developer changelog is detected, add developer names. 1468 1469 $NEW_VERSION = $VERSION unless $NEW_VERSION; 1470 $NEW_SVERSION = $SVERSION unless $NEW_SVERSION; 1471 $NEW_UVERSION = $UVERSION unless $NEW_UVERSION; 1472 1473 # Read and discard maintainer line, see who made the 1474 # last entry, and determine whether there are existing 1475 # multi-developer changes by the current maintainer. 1476 $line = -1; 1477 my ($lastmaint, $nextmaint, $maintline, $count, $lastheader, $lastdist, 1478 $dist_indicator); 1479 my $savedline = $line; 1480 while (<S>) { 1481 $line++; 1482 # Start of existing changes by the current maintainer 1483 if (/^ \[ \Q$MAINTAINER\E \]$/ && $opt_multimaint_merge) { 1484 # If there's more than one such block, 1485 # we only care about the first 1486 $maintline ||= $line; 1487 } elsif (/^ \[ (.*) \]$/ && defined $maintline) { 1488 # Start of existing changes following those by the current 1489 # maintainer 1490 $nextmaint ||= $1; 1491 } elsif ( 1492m/^\w[-+0-9a-z.]* \(([^\(\) \t]+)\)((?:\s+[-+0-9a-z.]+)+)\;\s+urgency=(\w+)/i 1493 ) { 1494 if (defined $lastmaint) { 1495 $lastheader = $_; 1496 $lastdist = $2; 1497 $lastdist =~ s/^\s+//; 1498 undef $lastdist if $lastdist eq "UNRELEASED"; 1499 # Revert to our previously saved position 1500 $line = $savedline; 1501 last; 1502 } else { 1503 my $tmpver = $1; 1504 $tmpver =~ s/^\s+//; 1505 if ($tmpver =~ m/~bpo(\d+)\+/ && exists $dists{$1}) { 1506 $dist_indicator = "$dists{$1}-backports"; 1507 } 1508 if ($tmpver =~ m/\+deb(\d+)u/ && exists $dists{$1}) { 1509 $dist_indicator = "$dists{$1}"; 1510 } 1511 } 1512 } elsif (/ \* (?:Upload to|Rebuild for) (\S+).*$/) { 1513 ($dist_indicator = $1) =~ s/[!:.,;]$//; 1514 chomp $dist_indicator; 1515 } elsif (/^ --\s+([^<]+)\s+/ || /^ --\s+<(.+?)>/) { 1516 $lastmaint = $1; 1517 # Remember where we are so we can skip back afterwards 1518 $savedline = $line; 1519 } 1520 1521 if (defined $maintline && !defined $nextmaint) { 1522 $maintline++; 1523 } 1524 } 1525 1526 # Munging of changelog for multimaintainer mode. 1527 my $multimaint = 0; 1528 if (!$opt_news) { 1529 my $lastmultimaint; 1530 1531 # Parse the changelog for multi-maintainer maintainer lines of 1532 # the form [ Full Name ] and record the last of these. 1533 while ($CHANGES =~ /.*\n^\s+\[\s+([^\]]+)\s+]\s*$/mg) { 1534 $lastmultimaint = $1; 1535 } 1536 1537 if (( 1538 !defined $lastmultimaint 1539 && defined $lastmaint 1540 && $lastmaint ne $MAINTAINER 1541 && $opt_multimaint 1542 ) 1543 || (defined $lastmultimaint && $lastmultimaint ne $MAINTAINER) 1544 || (defined $nextmaint) 1545 ) { 1546 $multimaint = 1; 1547 1548 if (!$lastmultimaint) { 1549 # Add a multi-maintainer header to the top of the existing 1550 # changelog. 1551 my $newchanges = ''; 1552 $CHANGES =~ s/^( .+)$/ [ $lastmaint ]\n$1/m; 1553 } 1554 } 1555 } 1556 1557 # based on /usr/lib/dpkg/parsechangelog/debian 1558 if ($CHANGES 1559 =~ m/^\w[-+0-9a-z.]* \([^\(\) \t]+\)((?:\s+[-+0-9a-z.]+)+)\;\s+urgency=(\w+)/i 1560 ) { 1561 my $distribution = $1; 1562 my $urgency = $2; 1563 if ($opt_news) { 1564 $urgency = $CL_URGENCY; 1565 } 1566 $distribution =~ s/^\s+//; 1567 if ($opt_r) { 1568 # Change the distribution from UNRELEASED for release 1569 if ($distribution eq "UNRELEASED") { 1570 if ($dist_indicator and not $opt_D) { 1571 $distribution = $dist_indicator; 1572 } elsif ($vendor eq 'Ubuntu') { 1573 if ($opt_D) { 1574 $distribution = $opt_D; 1575 } else { 1576 $distribution = get_ubuntu_devel_distro(); 1577 } 1578 } else { 1579 $distribution = $opt_D || $lastdist || "unstable"; 1580 } 1581 } elsif ($opt_D) { 1582 warn 1583"$progname warning: ignoring distribution passed to --release as changelog has already been released\n"; 1584 } 1585 # Set the start-line to 1, as we don't know what they want to edit 1586 $line = 1; 1587 } else { 1588 $distribution = $opt_D if $opt_D; 1589 } 1590 $urgency = $opt_u if $opt_u; 1591 $CHANGES 1592 =~ s/^(\w[-+0-9a-z.]* \([^\(\) \t]+\))(?:\s+[-+0-9a-z.]+)+\;\s+urgency=\w+/$PACKAGE ($NEW_VERSION) $distribution; urgency=$urgency/i; 1593 } else { 1594 warn 1595 "$progname: couldn't parse first changelog line, not touching it\n"; 1596 $warnings++; 1597 } 1598 1599 if (defined $maintline && defined $nextmaint) { 1600 # Output the lines up to the end of the current maintainer block 1601 $count = 1; 1602 $line = $maintline; 1603 foreach (split /\n/, $CHANGES) { 1604 print O $_ . "\n"; 1605 $count++; 1606 last if $count == $maintline; 1607 } 1608 } else { 1609 # The first lines are as we have already found 1610 print O $CHANGES; 1611 } 1612 1613 if (!$opt_r) { 1614 # Add a multi-maintainer header... 1615 if ($multimaint 1616 and (@closes_text or $TEXT or $opt_news or !$EMPTY_TEXT)) { 1617 # ...unless there already is one for this maintainer. 1618 if (!defined $maintline) { 1619 print O "\n [ $MAINTAINER ]\n"; 1620 $line += 2; 1621 } 1622 } 1623 1624 if (@closes_text or $TEXT) { 1625 foreach (@closes_text) { format_line($_, 0); } 1626 if (length $TEXT) { format_line($TEXT, 0); } 1627 } elsif ($opt_news) { 1628 print O "\n \n"; 1629 $line++; 1630 } elsif (!$EMPTY_TEXT) { 1631 print O " * \n"; 1632 } 1633 } 1634 1635 if (defined $count) { 1636 # Output the remainder of the changes 1637 $count = 1; 1638 foreach (split /\n/, $CHANGES) { 1639 $count++; 1640 next unless $count > $maintline; 1641 print O $_ . "\n"; 1642 } 1643 } 1644 1645 if ($opt_t && $opt_a) { 1646 print O "\n -- $changelog->{Maintainer} $changelog->{Date}\n"; 1647 } else { 1648 print O "\n -- $MAINTAINER <$EMAIL> $DATE\n"; 1649 } 1650 1651 if ($lastheader) { 1652 print O "\n$lastheader"; 1653 } 1654 1655 # Copy the rest of the changelog file to new one 1656 # Slurp the rest.... 1657 local $/ = undef; 1658 print O <S>; 1659} elsif ($opt_e && !$opt_create) { 1660 # We don't do any fancy stuff with respect to versions or adding 1661 # entries, we just update the timestamp and open the editor 1662 1663 print O $CHANGES; 1664 1665 if ($opt_t) { 1666 print O "\n -- $changelog->{Maintainer} $changelog->{Date}\n"; 1667 } else { 1668 print O "\n -- $MAINTAINER <$EMAIL> $DATE\n"; 1669 } 1670 1671 # Copy the rest of the changelog file to the new one 1672 $line = -1; 1673 while (<S>) { $line++; last if /^ --/; } 1674 # Slurp the rest... 1675 local $/ = undef; 1676 print O <S>; 1677 1678 # Set the start-line to 0, as we don't know what they want to edit 1679 $line = 0; 1680} elsif ($opt_create) { 1681 if ( !$initial_release 1682 and !$opt_news 1683 and !$opt_empty 1684 and !$TEXT 1685 and !$EMPTY_TEXT) { 1686 push @closes_text, "Initial release. (Closes: \#XXXXXX)\n"; 1687 } 1688 1689 my $urgency = $opt_u; 1690 if ($opt_news) { 1691 $urgency ||= $CL_URGENCY; 1692 } 1693 $urgency ||= 'medium'; 1694 print O "$PACKAGE ($VERSION) $DISTRIBUTION; urgency=$urgency\n\n"; 1695 1696 if (@closes_text or $TEXT) { 1697 foreach (@closes_text) { format_line($_, 1); } 1698 if (length $TEXT) { format_line($TEXT, 1); } 1699 } elsif ($opt_news) { 1700 print O " \n"; 1701 } elsif ($opt_empty) { 1702 # Do nothing, but skip the empty entry 1703 } else { # this can't happen, but anyway... 1704 print O " * \n"; 1705 } 1706 1707 print O "\n -- $MAINTAINER <$EMAIL> $DATE\n"; 1708 1709 $line = 1; 1710} elsif (!$optionsok) { 1711 fatal "Unknown changelog processing command line options - help!"; 1712} 1713 1714if (!$opt_create) { 1715 close S or fatal "Error closing $changelog_path: $!"; 1716} 1717close O or fatal "Error closing temporary $changelog_path: $!"; 1718 1719if ($warnings) { 1720 if ($warnings > 1) { 1721 warn 1722"$progname: Did you see those $warnings warnings? Press RETURN to continue...\n"; 1723 } else { 1724 warn 1725"$progname: Did you see that warning? Press RETURN to continue...\n"; 1726 } 1727 my $garbage = <STDIN>; 1728} 1729 1730# Now Run the Editor; always run if doing "closes" to give a chance to check 1731if ( (!$TEXT and !$EMPTY_TEXT and !($opt_create and $opt_empty)) 1732 or @closes_text 1733 or ($opt_create and !($PACKAGE ne 'PACKAGE' and $VERSION ne 'VERSION'))) { 1734 1735 my $mtime = (stat("$changelog_path.dch"))[9]; 1736 defined $mtime 1737 or fatal 1738 "Error getting modification time of temporary $changelog_path: $!"; 1739 $mtime--; 1740 utime $mtime, $mtime, "$changelog_path.dch"; 1741 1742 system("sensible-editor +$line $changelog_path.dch") == 0 1743 or fatal "Error editing $changelog_path"; 1744 1745 my $newmtime = (stat("$changelog_path.dch"))[9]; 1746 defined $newmtime 1747 or fatal 1748 "Error getting modification time of temporary $changelog_path: $!"; 1749 if ( $mtime == $newmtime 1750 && !$opt_create 1751 && (!$opt_r || ($opt_r && $opt_force_save_on_release))) { 1752 1753 warn "$progname: $changelog_path unmodified; exiting.\n"; 1754 exit 0; 1755 } 1756} 1757 1758copy("$changelog_path.dch", "$changelog_path") 1759 or fatal "Couldn't replace $changelog_path with new version: $!"; 1760 1761# Now find out what the new package version number is if we need to 1762# rename the directory 1763 1764if ( (basename(cwd()) =~ m%^\Q$PACKAGE\E-\Q$UVERSION\E$%) 1765 && !$opt_p 1766 && !$opt_create) { 1767 # Find the current version number etc. 1768 my $v; 1769 my $changelog = changelog_parse(); 1770 if (exists $changelog->{Version}) { 1771 $v = Dpkg::Version->new($changelog->{Version}); 1772 } 1773 1774 fatal "No version number in debian/changelog!" 1775 unless defined($v) 1776 and $v->is_valid(); 1777 1778 my ($new_version, $new_uversion); 1779 $new_version = $v->as_string(omit_epoch => 1); 1780 $new_uversion = $v->as_string(omit_epoch => 1, omit_revision => 1); 1781 1782 if ($new_uversion ne $UVERSION) { 1783 # Then we rename the directory 1784 if (move(cwd(), "../$PACKAGE-$new_uversion")) { 1785 warn 1786"$progname warning: your current directory has been renamed to:\n../$PACKAGE-$new_uversion\n"; 1787 } else { 1788 warn "$progname warning: Couldn't rename directory: $!\n"; 1789 } 1790 if (!$v->is_native()) { 1791 # And check whether a new orig tarball exists 1792 my @origs = glob("../$PACKAGE\_$new_uversion.*"); 1793 my $num_origs = grep { 1794/^..\/\Q$PACKAGE\E_\Q$new_uversion\E\.orig\.tar\.$compression_re$/ 1795 } @origs; 1796 if ($num_origs == 0) { 1797 warn 1798"$progname warning: no orig tarball found for the new version.\n"; 1799 } 1800 } 1801 } 1802} 1803 1804exit 0; 1805 1806{ 1807 no warnings 'uninitialized'; 1808 # Format for standard Debian changelogs 1809 format CHANGELOG = 1810 * ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1811 $CHGLINE 1812 ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1813 $CHGLINE 1814. 1815 # Format for NEWS files. 1816 format NEWS = 1817 ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1818 $CHGLINE 1819~~^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 1820 $CHGLINE 1821. 1822} 1823 1824my $linecount = 0; 1825 1826sub format_line { 1827 $CHGLINE = shift; 1828 my $newentry = shift; 1829 1830 # Work around the fact that write() with formats 1831 # seems to assume that characters are single-byte 1832 # See https://rt.perl.org/Public/Bug/Display.html?id=33832 1833 # and Debian bugs #473769 and #541484 1834 # This relies on $CHGLINE being a sequence of unicode characters. We can 1835 # compare how many unicode characters we have to how many bytes we have 1836 # when encoding to utf8 and therefore how many spaces we need to pad. 1837 my $count = length(encode_utf8($CHGLINE)) - length($CHGLINE); 1838 $CHGLINE .= " " x $count; 1839 1840 print O "\n" if $opt_news && !($newentry || $linecount); 1841 $linecount++; 1842 my $f = select(O); 1843 if ($opt_news) { 1844 $~ = 'NEWS'; 1845 } else { 1846 $~ = 'CHANGELOG'; 1847 } 1848 write O; 1849 select $f; 1850} 1851 1852BEGIN { 1853 # Initialise the variable 1854 $tmpchk = 0; 1855} 1856 1857END { 1858 if ($tmpchk) { 1859 unlink "$changelog_path.dch" 1860 or warn "$progname warning: Could not remove $changelog_path.dch\n"; 1861 unlink "$changelog_path.dch~"; # emacs backup file 1862 } 1863} 1864 1865sub fatal($) { 1866 my ($pack, $file, $line); 1867 ($pack, $file, $line) = caller(); 1868 (my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d; 1869 $msg =~ s/\n\n$/\n/; 1870 die $msg; 1871} 1872 1873# Is the environment variable valid or not? 1874sub check_env_utf8 { 1875 my $envvar = $_[0]; 1876 1877 if (exists $ENV{$envvar} and $ENV{$envvar} ne '') { 1878 if (!decode_utf8($ENV{$envvar})) { 1879 warn 1880"$progname warning: environment variable $envvar not UTF-8 encoded; ignoring\n"; 1881 } else { 1882 $env{$envvar} = decode_utf8($ENV{$envvar}); 1883 } 1884 } 1885} 1886