scripts/dch.pl

   1 #! /usr/bin/perl -w
   2
   3 # debchange: update the debian changelog using your favorite visual editor
   4 # For options, see the usage message below.
   5 #
   6 # When creating a new changelog section, if either of the environment
   7 # variables DEBEMAIL or EMAIL is set, debchange will use this as the
   8 # uploader's email address (with the former taking precedence), and if
   9 # DEBFULLNAME or NAME is set, it will use this as the uploader's full name.
  10 # Otherwise, it will take the standard values for the current user or,
  11 # failing that, just copy the values from the previous changelog entry.
  12 #
  13 # Originally by Christoph Lameter <clameter@debian.org>
  14 # Modified extensively by Julian Gilbey <jdg@debian.org>
  15 #
  16 # Copyright 1999-2005 by Julian Gilbey
  17 #
  18 # This program is free software; you can redistribute it and/or modify
  19 # it under the terms of the GNU General Public License as published by
  20 # the Free Software Foundation; either version 2 of the License, or
  21 # (at your option) any later version.
  22 #
  23 # This program is distributed in the hope that it will be useful,
  24 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  25 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  26 # GNU General Public License for more details.
  27 #
  28 # You should have received a copy of the GNU General Public License
  29 # along with this program; if not, write to the Free Software
  30 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  31
  32 use 5.008;  # We're using PerlIO layers
  33 use strict;
  34 use open ':utf8';  # changelogs are written with UTF-8 encoding
  35 use filetest 'access';  # use access rather than stat for -w
  36 use Encode 'decode_utf8';  # for checking whether user names are valid
  37 use Getopt::Long;
  38 use File::Copy;
  39 use File::Basename;
  40 use Cwd;
  41
  42 BEGIN {
  43     # Load the URI::Escape module safely
  44     eval { require URI::Escape; };
  45     if ($@) {
  46         my $progname = basename $0;
  47         if ($@ =~ /^Can\'t locate URI\/Escape\.pm/) {
  48             die "$progname: you must have the liburi-perl package installed\nto use this script\n";
  49         }
  50         die "$progname: problem loading the URI::Escape module:\n  $@\nHave you installed the liburi-perl package?\n";
  51     }
  52     import URI::Escape;
  53 }
  54
  55 # Predeclare functions
  56 sub fatal($);
  57 my $warnings = 0;
  58
  59 # And global variables
  60 my $progname = basename($0);
  61 my $modified_conf_msg;
  62 my %env;
  63 my $CHGLINE;  # used by the format O section at the end
  64
  65 sub usage () {
  66     print <<"EOF";
  67 Usage: $progname [options] [changelog entry]
  68 Options:
  69   -a, --append
  70          Append a new entry to the current changelog
  71   -i, --increment
  72          Increase the Infobot release number, adding a new changelog entry
  73   -v <version>, --newversion=<version>
  74          Add a new changelog entry with version number specified
  75   -e, --edit
  76          Don't change version number or add a new changelog entry, just
  77          update the changelog's stamp and open up an editor
  78   -r, --release
  79          Update the changelog timestamp.
  80   -d, --fromdirname
  81          Add a new changelog entry with version taken from the directory name
  82   -p, --preserve
  83          Preserve the directory name
  84   --no-preserve
  85          Do not preserve the directory name (default)
  86   --help, -h
  87          Display this help message and exit
  88   --version
  89          Display version information
  90   At most one of -a, -i, -e, -r, -v, -d (or their long equivalents)
  91   may be used.
  92   With no options, one of -i or -a is chosen by looking for a .upload
  93   file in the parent directory and checking its contents.
  94
  95 Default settings modified by devscripts configuration files:
  96 $modified_conf_msg
  97 EOF
  98 }
  99
 100 sub version () {
 101     print <<"EOF";
 102 This is $progname, ripped from the Debian devscripts package, version 2.10.9
 103 This code is copyright 1999-2003 by Julian Gilbey, all rights reserved.
 104 Based on code by Christoph Lameter.
 105 This program comes with ABSOLUTELY NO WARRANTY.
 106 You are free to redistribute this code under the terms of the
 107 GNU General Public License, version 2 or later.
 108 EOF
 109 }
 110
 111 # Start by setting default values
 112 my $check_dirname_level = 1;
 113 my $check_dirname_regex = 'PACKAGE(-.*)?';
 114 my $opt_p = 0;
 115 my $opt_query = 1;
 116 my $opt_release_heuristic = 'log';
 117 my $opt_multimaint = 1;
 118 my $opt_multimaint_merge = 0;
 119 my $opt_tz = undef;
 120 my $opt_mainttrailer = 0;
 121
 122 # Next, read configuration files and then command line
 123 # The next stuff is boilerplate
 124
 125 if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
 126     $modified_conf_msg = "  (no configuration files read)";
 127     shift;
 128 } else {
 129     my @config_files = ('~/.infobot-dev.conf');
 130     my %config_vars = (
 131                        'CHANGE_PRESERVE' => 'no',
 132                        'CHANGE_TZ' => $ENV{TZ}, # undef if TZ unset
 133                        );
 134     $config_vars{'CHANGE_TZ'} ||= '';
 135     my %config_default = %config_vars;
 136
 137     my $shell_cmd;
 138     # Set defaults
 139     foreach my $var (keys %config_vars) {
 140         $shell_cmd .= qq[$var="$config_vars{$var}";\n];
 141     }
 142     $shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
 143     $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
 144     # Read back values
 145     foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
 146     my $shell_out = `/bin/bash -c '$shell_cmd'`;
 147     @config_vars{keys %config_vars} = split /\n/, $shell_out, -1;
 148
 149     # Check validity
 150     $config_vars{'CHANGE_PRESERVE'} =~ /^(yes|no)$/
 151         or $config_vars{'CHANGE_PRESERVE'}='no';
 152
 153     foreach my $var (sort keys %config_vars) {
 154         if ($config_vars{$var} ne $config_default{$var}) {
 155             $modified_conf_msg .= "  $var=$config_vars{$var}\n";
 156         }
 157     }
 158     $modified_conf_msg ||= "  (none)\n";
 159     chomp $modified_conf_msg;
 160
 161     $opt_p = $config_vars{'CHANGE_PRESERVE'} eq 'yes' ? 1 : 0;
 162     $opt_tz = $config_vars{'CHANGE_TZ'};
 163 }
 164
 165 # We use bundling so that the short option behaviour is the same as
 166 # with older debchange versions.
 167 my ($opt_help, $opt_version);
 168 my ($opt_i, $opt_a, $opt_e, $opt_r, $opt_v, $opt_b, $opt_d, $opt_D, $opt_u, $opt_t);
 169 my ($opt_n, $opt_qa, $opt_bpo, $opt_c, $opt_m, $opt_create, $opt_package, @closes);
 170 my ($opt_news);
 171 my ($opt_ignore, $opt_level, $opt_regex, $opt_noconf);
 172
 173 Getopt::Long::Configure('bundling');
 174 GetOptions("help|h" => \$opt_help,
 175            "version" => \$opt_version,
 176            "i|increment" => \$opt_i,
 177            "a|append" => \$opt_a,
 178            "e|edit" => \$opt_e,
 179            "r|release" => \$opt_r,
 180            "v|newversion=s" => \$opt_v,
 181            "p" => \$opt_p,
 182            "preserve!" => \$opt_p,
 183            "release-heuristic=s" => \$opt_release_heuristic,
 184            )
 185     or die "Usage: $progname [options] [changelog entry]\nRun $progname --help for more details\n";
 186
 187 if ($opt_noconf) {
 188     fatal "--no-conf is only acceptable as the first command-line option!";
 189 }
 190 if ($opt_help) { usage; exit 0; }
 191 if ($opt_version) { version; exit 0; }
 192
 193 # dirname stuff
 194 if ($opt_ignore) {
 195     fatal "--ignore-dirname has been replaced by --check-dirname-level and\n--check-dirname-regex; run $progname --help for more details";
 196 }
 197
 198 if (defined $opt_level) {
 199     if ($opt_level =~ /^[012]$/) { $check_dirname_level = $opt_level; }
 200     else {
 201         fatal "Unrecognised --check-dirname-level value (allowed are 0,1,2)";
 202     }
 203 }
 204
 205 if (defined $opt_regex) { $check_dirname_regex = $opt_regex; }
 206
 207 # Only allow at most one non-help option
 208 fatal "Only one of -a, -i, -e, -r, -v, -d is allowed;\ntry $progname --help for more help"
 209     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_qa?1:0) + ($opt_bpo?1:0) > 1;
 210
 211 my $changelog_path = $opt_c || $ENV{'CHANGELOG'} || 'Changelog';
 212 my $real_changelog_path = $changelog_path;
 213 if ($changelog_path ne 'Changelog') {
 214     $check_dirname_level = 0;
 215 }
 216
 217 if ($opt_create) {
 218     if ($opt_a || $opt_i || $opt_e || $opt_r || $opt_b || $opt_n || $opt_qa || $opt_bpo) {
 219         warn "$progname warning: ignoring -a/-i/-e/-r/-b/-n/--qa/--bpo options with --create\n";
 220         $warnings++;
 221     }
 222     if ($opt_package && $opt_d) {
 223         fatal "Can only use one of --package and -d";
 224     }
 225 }
 226
 227
 228 @closes = split(/,/, join(',', @closes));
 229 map { s/^\#//; } @closes;  # remove any leading # from bug numbers
 230
 231 # We'll process the rest of the command line later.
 232
 233 # Look for the changelog
 234 my $chdir = 0;
 235 if (! $opt_create) {
 236     if ($changelog_path eq 'Changelog' or $opt_news) {
 237         until (-f $changelog_path) {
 238             $chdir = 1;
 239             chdir '..' or fatal "Can't chdir ..: $!";
 240             if (cwd() eq '/') {
 241                 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.)";
 242             }
 243         }
 244
 245         # Can't write, so stop now.
 246         if (! -w $changelog_path) {
 247             fatal "$changelog_path is not writable!";
 248         }
 249     }
 250     else {
 251         unless (-f $changelog_path) {
 252             fatal "Cannot find $changelog_path!\nAre you in the correct directory?\n(You could use --create if you wish to create this file.)";
 253         }
 254
 255         # Can't write, so stop now.
 256         if (! -w $changelog_path) {
 257             fatal "$changelog_path is not writable!";
 258         }
 259     }
 260 }
 261 else {  # $opt_create
 262     unless (-d dirname $changelog_path) {
 263         fatal "Cannot find " . (dirname $changelog_path) . " directory!\nAre you in the correct directory?";
 264     }
 265     if (-f $changelog_path) {
 266         fatal "File $changelog_path already exists!";
 267     }
 268     unless (-w dirname $changelog_path) {
 269         fatal "Cannot find " . (dirname $changelog_path) . " directory!\nAre you in the correct directory?";
 270     }
 271     if ($opt_news && ! -f 'debian/changelog') {
 272         fatal "I can't create $opt_news without debian/changelog present";
 273     }
 274 }
 275
 276 #####
 277
 278 # Find the current version number etc.
 279 my %changelog;
 280 my $PACKAGE = 'PACKAGE';
 281 my $VERSION = 'VERSION';
 282 my $MAINTAINER = 'MAINTAINER';
 283 my $EMAIL = 'EMAIL';
 284 my $DISTRIBUTION = 'UNRELEASED';
 285 my $CHANGES = '';
 286
 287 # Clean up after old versions of debchange
 288 if (-f "debian/RELEASED") {
 289     unlink("debian/RELEASED");
 290 }
 291
 292 if ( -e "$changelog_path.clg" ) {
 293     fatal "The backup file $changelog_path.clg already exists --\n" .
 294                   "please move it before trying again";
 295 }
 296
 297
 298 # Is this a native Debian package, i.e., does it have a - in the
 299 # version number?
 300 (my $EPOCH) = ($VERSION =~ /^(\d+):/);
 301 (my $SVERSION=$VERSION) =~ s/^\d+://;
 302 (my $UVERSION=$SVERSION) =~ s/-[^-]*$//;
 303
 304 # Check, sanitise and decode these environment variables
 305 check_env_utf8('FULLNAME');
 306 check_env_utf8('NAME');
 307 check_env_utf8('EMAIL');
 308
 309 if (exists $env{'EMAIL'} and $env{'EMAIL'} =~ /^(.*)\s+<(.*)>$/) {
 310     $env{'FULLNAME'} = $1 unless exists $env{'FULLNAME'};
 311     $env{'EMAIL'} = $2;
 312 }
 313 if (! exists $env{'EMAIL'} or ! exists $env{'FULLNAME'}) {
 314     if (exists $env{'EMAIL'} and $env{'EMAIL'} =~ /^(.*)\s+<(.*)>$/) {
 315         $env{'FULLNAME'} = $1 unless exists $env{'FULLNAME'};
 316         $env{'EMAIL'} = $2;
 317     }
 318 }
 319
 320 # Now use the gleaned values to detemine our MAINTAINER and EMAIL values
 321 if (! $opt_m) {
 322     if (exists $env{'FULLNAME'}) {
 323         $MAINTAINER = $env{'FULLNAME'};
 324     } elsif (exists $env{'NAME'}) {
 325         $MAINTAINER = $env{'NAME'};
 326     } else {
 327         my @pw = getpwuid $<;
 328         if (defined($pw[6])) {
 329             if (my $pw = decode_utf8($pw[6])) {
 330                 $pw =~ s/,.*//;
 331                 $MAINTAINER = $pw;
 332             } else {
 333                 warn "$progname warning: passwd full name field for uid $<\nis not UTF-8 encoded; ignoring\n";
 334                 $warnings++;
 335             }
 336         }
 337     }
 338     # Otherwise, $MAINTAINER retains its default value of the last
 339     # changelog entry
 340
 341     # Email is easier
 342     if (exists $env{'EMAIL'}) { $EMAIL = $env{'EMAIL'}; }
 343     elsif (exists $env{'EMAIL'}) { $EMAIL = $env{'EMAIL'}; }
 344     else {
 345         my $addr;
 346         if (open MAILNAME, '/etc/mailname') {
 347             chomp($addr = <MAILNAME>);
 348             close MAILNAME;
 349         }
 350         if (!$addr) {
 351             chomp($addr = `hostname --fqdn 2>/dev/null`);
 352             $addr = undef if $?;
 353         }
 354         if ($addr) {
 355             my $user = getpwuid $<;
 356             if (!$user) {
 357                 $addr = undef;
 358             }
 359             else {
 360                 $addr = "$user\@$addr";
 361             }
 362         }
 363         $EMAIL = $addr if $addr;
 364     }
 365     # Otherwise, $EMAIL retains its default value of the last changelog entry
 366 } # if (! $opt_m)
 367
 368 #####
 369
 370 # Get a possible changelog entry from the command line
 371 my $ARGS=join(' ', @ARGV);
 372 my $TEXT=decode_utf8($ARGS);
 373 my $EMPTY_TEXT=0;
 374
 375 if (@ARGV and ! $TEXT) {
 376     if ($ARGS) {
 377         warn "$progname warning: command-line changelog entry not UTF-8 encoded; ignoring\n";
 378         $TEXT='';
 379     } else {
 380         $EMPTY_TEXT = 1;
 381     }
 382 }
 383
 384 # Get the date
 385 my $date_cmd = ($opt_tz ? "TZ=$opt_tz " : "") . "date -R";
 386 chomp(my $DATE=`$date_cmd`);
 387
 388 # Are we going to have to figure things out for ourselves?
 389 if (! $opt_i && ! $opt_v && ! $opt_d && ! $opt_a && ! $opt_e && ! $opt_r &&
 390     ! $opt_create) {
 391     # Yes, we are
 392     if ($opt_release_heuristic eq 'log') {
 393         my @UPFILES = glob("../$PACKAGE\_$SVERSION\_*.upload");
 394         if (@UPFILES > 1) {
 395             fatal "Found more than one appropriate .upload file!\n" .
 396                 "Please use an explicit -a, -i or -v option instead.";
 397         }
 398         elsif (@UPFILES == 0) { $opt_a = 1 }
 399         else {
 400             open UPFILE, "<${UPFILES[0]}"
 401                 or fatal "Couldn't open .upload file for reading: $!\n" .
 402                     "Please use an explicit -a, -i or -v option instead.";
 403             while (<UPFILE>) {
 404                 if (m%^(s|Successfully uploaded) (/.*/)?\Q$PACKAGE\E\_\Q$SVERSION\E\_[\w\-\+]+\.changes %) {
 405                    $opt_i = 1;
 406                    last;
 407                 }
 408             }
 409             close UPFILE
 410                 or fatal "Problems experienced reading .upload file: $!\n" .
 411                             "Please use an explicit -a, -i or -v option instead.";
 412             if (! $opt_i) {
 413                 warn "$progname warning: A successful upload of the current version was not logged\n" .
 414                     "in the upload log file; adding log entry to current version.";
 415                 $opt_a = 1;
 416             }
 417         }
 418     }
 419 }
 420
 421 # Open in anticipation....
 422 unless ($opt_create) {
 423     open S, $changelog_path or fatal "Cannot open existing $changelog_path: $!";
 424 }
 425 open O, ">$changelog_path.clg"
 426     or fatal "Cannot write to temporary file: $!";
 427 # Turn off form feeds; taken from perlform
 428 select((select(O), $^L = "")[0]);
 429
 430 # Note that we now have to remove it
 431 my $tmpchk=1;
 432 my ($NEW_VERSION, $NEW_SVERSION, $NEW_UVERSION);
 433 my $line;
 434
 435 if (($opt_i || $opt_n || $opt_qa || $opt_bpo || $opt_v || $opt_d ||
 436     ($opt_news && $VERSION ne $changelog{'Version'})) && ! $opt_create) {
 437
 438     # Check that a given explicit version number is sensible.
 439     if ($opt_v || $opt_d) {
 440         if($opt_v) {
 441             $NEW_VERSION=$opt_v;
 442         } else {
 443             my $pwd = basename(cwd());
 444             # The directory name should be <package>-<version>
 445             my $version_chars = '0-9a-zA-Z+\.~';
 446             $version_chars .= ':' if defined $EPOCH;
 447             $version_chars .= '\-' if $UVERSION ne $SVERSION;
 448             if ($pwd =~ m/^\Q$PACKAGE\E-([0-9][$version_chars]*)$/) {
 449                 $NEW_VERSION=$1;
 450                 if ($NEW_VERSION eq $UVERSION) {
 451                     # So it's a Debian-native package
 452                     if ($SVERSION eq $UVERSION) {
 453                         fatal "New version taken from directory ($NEW_VERSION) is equal to\n" .
 454                             "the current version number ($UVERSION)!";
 455                     }
 456                     # So we just increment the Debian revision
 457                     warn "$progname warning: Incrementing Infobot revision without altering\n version number.\n";
 458                     $VERSION =~ /^(.*?)([a-yA-Y][a-zA-Z]*|\d*)$/;
 459                     my $end = $2;
 460                     if ($end eq '') {
 461                         fatal "Cannot determine new revision; please use -v option!";
 462                     }
 463                     $end++;
 464                     $NEW_VERSION="$1$end";
 465                 } else {
 466                     $NEW_VERSION = "$EPOCH:$NEW_VERSION" if defined $EPOCH;
 467                     $NEW_VERSION .= "-1";
 468                 }
 469             } else {
 470                 fatal "The directory name must be <package>-<version> for -d to work!\n" .
 471                     "No underscores allowed!";
 472             }
 473             # Don't try renaming the directory in this case!
 474             $opt_p=1;
 475         }
 476
 477         if (system("dpkg --compare-versions $VERSION lt $NEW_VERSION" .
 478                   " 2>/dev/null 1>&2")) {
 479             if ($opt_b) {
 480                 warn "$progname warning: new version ($NEW_VERSION) is less than\n" .
 481                     "the current version number ($VERSION).\n";
 482             } else {
 483                 fatal "New version specified ($NEW_VERSION) is less than\n" .
 484                     "the current version number ($VERSION)!  Use -b to force.";
 485             }
 486         }
 487
 488         ($NEW_SVERSION=$NEW_VERSION) =~ s/^\d+://;
 489         ($NEW_UVERSION=$NEW_SVERSION) =~ s/-[^-]*$//;
 490     }
 491
 492     # We use the following criteria for the version and release number:
 493     # the last component of the version number is used as the
 494     # release number.  If this is not a Debian native package, then the
 495     # upstream version number is everything up to the final '-', not
 496     # including epochs.
 497
 498     if (! $NEW_VERSION) {
 499         if ($VERSION =~ /(.*?)([a-yA-Y][a-zA-Z]*|\d+)$/i) {
 500             my $end=$2;
 501             my $start=$1;
 502             # If it's not already an NMU make it so
 503             # otherwise we can be safe if we behave like dch -i
 504             if ($opt_n and (not $start =~ /\.$/ or $VERSION eq $UVERSION)) {
 505                 if ($VERSION eq $UVERSION) {
 506                     # First NMU of a Debian native package
 507                     $end .= "-0.1";
 508                 } else {
 509                     $end += 0.1;
 510                 }
 511             } elsif ($opt_qa and $start =~/(.*?)-(\d+)\.$/) {
 512                     # Drop NMU revision when doing a QA upload
 513                     my $upstream_version = $1;
 514                     my $debian_revision = $2;
 515                     $debian_revision++;
 516                     $start = "$upstream_version-$debian_revision";
 517                     $end = "";
 518             } elsif ($opt_bpo and not $start =~ /~bpo\.$/) {
 519                 # If it's not already a backport make it so
 520                 # otherwise we can be safe if we behave like dch -i
 521                 $end .= "~bpo40+1";
 522             } elsif (!$opt_news) {
 523                 # Don't bump the version of a NEWS file in this case as we're
 524                 # using the version from the changelog
 525                 $end++;
 526             }
 527             $NEW_VERSION = "$start$end";
 528             ($NEW_SVERSION=$NEW_VERSION) =~ s/^\d+://;
 529             ($NEW_UVERSION=$NEW_SVERSION) =~ s/-[^-]*$//;
 530         } else {
 531             fatal "Error parsing version number: $VERSION";
 532         }
 533     }
 534
 535     $line += 3;
 536     print O "\n -- $MAINTAINER <$EMAIL>  $DATE\n\n";
 537
 538     # Copy the old changelog file to the new one
 539     local $/ = undef;
 540     print O <S>;
 541 }
 542 elsif (($opt_r || $opt_a) && ! $opt_create) {
 543     # This means we just have to generate a new * entry in changelog
 544     # and if a multi-developer changelog is detected, add developer names.
 545
 546     $NEW_VERSION=$VERSION;
 547     $NEW_SVERSION=$SVERSION;
 548     $NEW_UVERSION=$UVERSION;
 549
 550     # Read and discard maintainer line, see who made the
 551     # last entry, and determine whether there are existing
 552     # multi-developer changes by the current maintainer.
 553     $line=-1;
 554     my ($lastmaint, $nextmaint, $maintline, $count, $lastheader, $lastdist);
 555     my $savedline = $line;;
 556     while (<S>) {
 557         $line++;
 558         # Start of existing changes by the current maintainer
 559         if (/^  \[ $MAINTAINER \]$/) {
 560             # If there's more than one such block,
 561             # we only care about the first
 562             $maintline ||= $line;
 563         }
 564         elsif (defined $lastmaint) {
 565             if (m/^\w[-+0-9a-z.]* \([^\(\) \t]+\)((?:\s+[-+0-9a-z.]+)+)\;/i) {
 566                 $lastheader = $_;
 567                 $lastdist = $1;
 568                 $lastdist =~ s/^\s+//;
 569                 undef $lastdist if $lastdist eq "UNRELEASED";
 570                 # Revert to our previously saved position
 571                 $line = $savedline;
 572                 last;
 573             }
 574         }
 575         elsif (/^ --\s+([^<]+)\s+/) {
 576             $lastmaint=$1;
 577             # Remember where we are so we can skip back afterwards
 578             $savedline = $line;
 579         }
 580
 581         if (defined $maintline && !defined $nextmaint) {
 582             $maintline++;
 583         }
 584     }
 585
 586     if (defined $maintline && defined $nextmaint) {
 587         # Output the lines up to the end of the current maintainer block
 588         $count=1;
 589         $line=$maintline;
 590         foreach (split /\n/, $CHANGES) {
 591             print O $_ . "\n";
 592             $count++;
 593             last if $count==$maintline;
 594         }
 595     } else {
 596         # The first lines are as we have already found
 597         print O $CHANGES;
 598     };
 599
 600     if (defined $count) {
 601         # Output the remainder of the changes
 602         $count=1;
 603         foreach (split /\n/, $CHANGES) {
 604             $count++;
 605             next unless $count>$maintline;
 606             print O $_ . "\n";
 607         }
 608     }
 609
 610     if ($opt_t && $opt_a) {
 611         print O "\n -- $changelog{'Maintainer'}  $changelog{'Date'}\n";
 612     } else {
 613         print O "\n -- $MAINTAINER <$EMAIL>  $DATE\n";
 614     }
 615
 616     if ($lastheader) {
 617         print O "\n$lastheader";
 618     }
 619
 620     # Copy the rest of the changelog file to new one
 621     # Slurp the rest....
 622     local $/ = undef;
 623     print O <S>;
 624 }
 625 elsif ($opt_e && ! $opt_create) {
 626     # We don't do any fancy stuff with respect to versions or adding
 627     # entries, we just update the timestamp and open the editor
 628
 629     print O $CHANGES;
 630
 631     if ($opt_t) {
 632         print O "\n -- $changelog{'Maintainer'}  $changelog{'Date'}\n";
 633     } else {
 634         print O "\n -- $MAINTAINER <$EMAIL>  $DATE\n";
 635     }
 636
 637     # Copy the rest of the changelog file to the new one
 638     $line=-1;
 639     while (<S>) { $line++; last if /^ --/; }
 640     # Slurp the rest...
 641     local $/ = undef;
 642     print O <S>;
 643
 644     # Set the start-line to 0, as we don't know what they want to edit
 645     $line=0;
 646 }
 647
 648 if ($warnings) {
 649     if ($warnings>1) {
 650         warn "$progname: Did you see those $warnings warnings?  Press RETURN to continue...\n";
 651     } else {
 652         warn "$progname: Did you see that warning?  Press RETURN to continue...\n";
 653     }
 654     my $garbage = <STDIN>;
 655 }
 656
 657 # Now Run the Editor; always run if doing "closes" to give a chance to check
 658 if (!$TEXT and !$EMPTY_TEXT) {
 659     my $mtime = (stat("$changelog_path.clg"))[9];
 660     defined $mtime or fatal
 661         "Error getting modification time of temporary $changelog_path: $!";
 662
 663     system("sensible-editor +$line $changelog_path.clg") == 0 or
 664         fatal "Error editing $changelog_path";
 665 }
 666
 667 copy("$changelog_path.clg","$changelog_path") or
 668     fatal "Couldn't replace $changelog_path with new version: $!";
 669
 670 exit 0;
 671
 672
 673 # Format for standard Debian changelogs
 674 format CHANGELOG =
 675   * ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 676     $CHGLINE
 677  ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 678     $CHGLINE
 679 .
 680 # Format for NEWS files.
 681 format NEWS =
 682   ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 683     $CHGLINE
 684 ~~^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 685     $CHGLINE
 686 .
 687
 688 my $linecount=0;
 689 sub format_line {
 690     $CHGLINE=shift;
 691     my $newentry=shift;
 692
 693     print O "\n" if $opt_news && ! ($newentry || $linecount);
 694     $linecount++;
 695     my $f=select(O);
 696     if ($opt_news) {
 697         $~='NEWS';
 698     }
 699     else {
 700         $~='CHANGELOG';
 701     }
 702     write O;
 703     select $f;
 704 }
 705
 706 BEGIN {
 707     # Initialise the variable
 708     $tmpchk=0;
 709 }
 710
 711 END {
 712     if ($tmpchk) {
 713         unlink "$changelog_path.clg" or
 714             warn "$progname warning: Could not remove $changelog_path.clg";
 715         unlink "$changelog_path.clg~";  # emacs backup file
 716     }
 717 }
 718
 719 sub fatal($) {
 720     my ($pack,$file,$line);
 721     ($pack,$file,$line) = caller();
 722     (my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d;
 723     $msg =~ s/\n\n$/\n/;
 724     die $msg;
 725 }
 726
 727 # Is the environment variable valid or not?
 728 sub check_env_utf8 {
 729     my $envvar = $_[0];
 730
 731     if (exists $ENV{$envvar} and $ENV{$envvar} ne '') {
 732         if (! decode_utf8($ENV{$envvar})) {
 733             warn "$progname warning: environment variable $envvar not UTF-8 encoded; ignoring\n";
 734         } else {
 735             $env{$envvar} = decode_utf8($ENV{$envvar});
 736         }
 737     }
 738 }
 739
 740 # vim:ts=4:sw=4:expandtab:tw=80