#! /usr/bin/perl -w

# This is a modified version of debchange for backports.org
#
# debchange --help (or -h) prints a usage message.
#
# 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 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-2003 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, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use 5.008;  # We're using PerlIO layers
use strict;
use open ':utf8';  # changelogs are written with UTF-8 encoding
use Encode 'decode_utf8';  # for checking whether user names are valid
use Getopt::Long;
use File::Copy;
use File::Basename;
use Cwd;

# Predeclare functions
sub fatal($);

# And global variables
my $progname = basename($0);
my $modified_conf_msg;
my %env;
my $CHGLINE;  # used by the format O section at the end

sub usage () {
    print <<"EOF";
Usage: $progname [options] [changelog entry]
Options:
  -i, --increment
         If this is already a backport package, increase the backports.org
         release number, otherwise decrease the Debian release number and
         add ".backports.org.1", adding a new changelog entry
  -a, --append
         Append a new entry to the current changelog
  --help, -h
         Display this help message and exit
  --version
         Display version information
  At most one of -a and -i (or their long equivalents) may be used.
  With no options, -i is chosen if the current version isn't a backport
  otherwise -a is chosen.

Default settings modified by devscripts configuration files:
$modified_conf_msg
EOF
}

sub version () {
    print <<"EOF";
This is $progname version 2.7.95.1.backports.org.1
This code is copyright 2004 by Jörg Sommer, all rights reserved.
Based on debchange, from the Debian devscripts package, by Julian Gilbey.
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
}

# 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_u, $opt_D);
$opt_u = 'low';

Getopt::Long::Configure('bundling');
GetOptions("help|h" => \$opt_help,
	   "version" => \$opt_version,
	   "i|increment" => \$opt_i,
	   "a|append" => \$opt_a,
           "D|distribution=s" => \$opt_D,
           "u|urgency=s" => \$opt_u,
	   )
    or die "Usage: $progname [options] [changelog entry]\nRun $progname --help for more details\n";

if ($opt_help) { usage; exit 0; }
if ($opt_version) { version; exit 0; }

# Only allow at most one non-help option
fatal "Only one of -a, -i is allowed; try $progname -h for more help"
    if ($opt_i?1:0) + ($opt_a?1:0) > 1;

# We'll process the rest of the command line later.

# Look for the debian changelog
my $chdir = 0;
until (-f 'debian/changelog') {
    $chdir = 1;
    chdir '..' or die "$progname: can't chdir ..: $!\n";
    if (cwd() eq '/') {
	die "$progname: cannot find debian/changelog anywhere!\nAre you in the source code tree?\n";
    }
}

#####

# Find the current version number etc.
my %changelog;
open PARSED, "dpkg-parsechangelog |"
    or fatal "Cannot execute dpkg-parsechangelog: $!";
my $last;
while (<PARSED>) {
    chomp;
    if (/^(\S+):\s(.+?)\s*$/) { $changelog{$1}=$2; $last=$1; }
    elsif (/^(\S+):\s$/) { $changelog{$1}=''; $last=$1; }
    elsif (/^\s\.$/) { $changelog{$last}.="\n"; }
    elsif (/^\s(.+)$/) { $changelog{$last}.="$1\n"; }
    else {
	fatal "Don't understand dpkg-parsechangelog output: $_";
    }
}

close PARSED
    or fatal "Problem executing dpkg-parsechangelog: $!";
if ($?) { fatal "dpkg-parsechangelog failed!" }

# 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'};
my $PACKAGE = $changelog{'Source'};
fatal "No version number in changelog!"
    unless exists $changelog{'Version'};
my $VERSION=$changelog{'Version'};
# fatal "No maintainer in changelog!"
#     unless exists $changelog{'Maintainer'};
# my ($MAINTAINER,$EMAIL) = ($changelog{'Maintainer'} =~ /^([^<]+) <(.*)>/);
my ($MAINTAINER,$EMAIL);
fatal "No distribution in changelog!"
    unless exists $changelog{'Distribution'};
my $DISTRIBUTION=$changelog{'Distribution'};
fatal "No changes in changelog!"
    unless exists $changelog{'Changes'};
my $CHANGES=$changelog{'Changes'};

if ( -e "debian/changelog.dch" ) {
    fatal "The backup file debian/changelog.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('DEBEMAIL');
check_env_utf8('EMAIL');

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;
    }
}

# Now use the gleaned values to detemine our MAINTAINER and EMAIL values
if (exists $env{'DEBFULLNAME'}) {
    $MAINTAINER = $env{'DEBFULLNAME'};
} else {
    my @pw = getpwuid $<;
    if (defined($pw[6])) {
	if (my $pw = decode_utf8($pw[6])) {
	    $pw =~ s/,.*//;
	    $MAINTAINER = $pw;
	} else {
	    die "$progname error: passwd full name field for uid $<\nis not UTF-8 encoded; you must use the environment variable DEBFULLNAME\n";
	}
    }
}
# Otherwise, $MAINTAINER retains its default value of the last changelog entry

# Email is easier
if (exists $env{'DEBEMAIL'}) { $EMAIL = $env{'DEBEMAIL'}; }
elsif (exists $env{'EMAIL'}) { $EMAIL = $env{'EMAIL'}; }
else {
    my $addr;
    if (open MAILNAME, '/etc/mailname') {
	chomp($addr = <MAILNAME>);
	close MAILNAME;
    }
    if (!$addr) {
	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

#####

my $warnings = 0;
# Get a possible changelog entry from the command line
my $TEXT=decode_utf8(join(' ', @ARGV));
if (@ARGV and ! $TEXT) {
    warn "$progname warning: command-line changelog entry not UTF-8 encoded; ignoring\n";
    $TEXT='';
}

# Get the date
chomp(my $DATE=`822-date`);

# Open in anticipation....
open S, "debian/changelog" or fatal "Cannot open changelog: $!";
open O, ">debian/changelog.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;

if ($opt_i or $VERSION !~ /backports\.org\.\d+$/) {
    # 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.

    my $new_backport=0;
    if ($VERSION =~ /(.*backports\.org\.)(\d+)$/) {
	my $end=$2; $end++;
	$NEW_VERSION = "$1$end";
    } else {
	if ( $VERSION =~ /(.*?)([a-yA-Y][a-zA-Z]*|\d*)$/ ) {
	    my $end=$2; $end--;
	    $NEW_VERSION = "$1$end.backports.org.1";
	    $new_backport = 1;
	} else {
	    fatal "Error parsing version number: $VERSION";
	}
    }
    ($NEW_SVERSION=$NEW_VERSION) =~ s/^\d+://;
    ($NEW_UVERSION=$NEW_SVERSION) =~ s/-[^-]*$//;

    my $distribution = $opt_D || $DISTRIBUTION;
    print O "$PACKAGE ($NEW_VERSION) $distribution; ",
        "urgency=$opt_u\n\n";

    if ($new_backport) {
	$CHGLINE = "Unstable version $VERSION recompiled for <http://www.backports.org/debian/>";
	write O;
    }
    
    # format it nicely
    if ($CHGLINE = $TEXT) {
	write O;
    } 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>;
}
else { # $opt_a = 1
    # This means we just have to generate a new * entry in changelog
    $NEW_VERSION=$VERSION;
    $NEW_SVERSION=$SVERSION;
    $NEW_UVERSION=$UVERSION;

    # The first lines are as we have already found
    print O $CHANGES;

    # format it nicely
    if ($CHGLINE = $TEXT) {
	write O;
    } else {
	print O "  * \n";
    }

    print O "\n -- $MAINTAINER <$EMAIL>  $DATE\n";

    # Copy the rest of the changelog file to new one
    $line=-1;
    while (<S>) { $line++; last if /^ --/; }
    # Slurp the rest....
    local $/ = undef;
    print O <S>;
}

close S or fatal "Error closing debian/changelog: $!";
close O or fatal "Error closing temporary changelog: $!";

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
if (! $TEXT) {
    my $mtime = (stat("debian/changelog.dch"))[9];
    defined $mtime or fatal
	"Error getting modification time of temporary changelog: $!";

    system("sensible-editor +$line debian/changelog.dch") == 0 or
    fatal "Error editing the changelog";

    my $newmtime = (stat("debian/changelog.dch"))[9];
    defined $newmtime or fatal
      "Error getting modification time of temporary changelog: $!";
    if ($mtime == $newmtime) {
	warn "$progname: Changelog unmodified; exiting.\n";
	exit 0;
    }
}

copy("debian/changelog.dch","debian/changelog") or
    fatal "Couldn't replace changelog with new changelog: $!";

# Now find out what the new package version number is if we need to
# rename the directory

exit 0;


# Format for standard Debian changelogs
format O =
  * ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    $CHGLINE
 ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    $CHGLINE
.

sub BEGIN {
    # Initialise the variable
    $tmpchk=0;
}

sub END {
    unlink "debian/changelog.dch" or
	warn "$progname warning: Could not remove debian/changelog.dch"
	    if $tmpchk;
}

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});
	}
    }
}