From 0d5ea3be11b20bbd02012b89062fc78f4490132f Mon Sep 17 00:00:00 2001 From: simonraven Date: Tue, 16 Oct 2007 05:01:37 +0000 Subject: [PATCH] * New Changelog update script forked from dch (debian changelog) git-svn-id: https://svn.code.sf.net/p/infobot/code/branches/rebranding@1553 c11ca15a-4712-0410-83d8-924469b57eb5 --- scripts/dch.pl | 739 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 739 insertions(+) create mode 100755 scripts/dch.pl diff --git a/scripts/dch.pl b/scripts/dch.pl new file mode 100755 index 0000000..7ce60d0 --- /dev/null +++ b/scripts/dch.pl @@ -0,0 +1,739 @@ +#! /usr/bin/perl -w + +# debchange: update the debian changelog using your favorite visual editor +# For options, see the usage message below. +# +# When creating a new changelog section, if either of the environment +# variables DEBEMAIL or EMAIL is set, debchange will use this as the +# uploader's email address (with the former taking precedence), and if +# DEBFULLNAME or NAME is set, it will use this as the uploader's full name. +# Otherwise, it will take the standard values for the current user or, +# failing that, just copy the values from the previous changelog entry. +# +# Originally by Christoph Lameter +# Modified extensively by Julian Gilbey +# +# Copyright 1999-2005 by Julian Gilbey +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, 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 filetest 'access'; # use access rather than stat for -w +use Encode 'decode_utf8'; # for checking whether user names are valid +use Getopt::Long; +use File::Copy; +use File::Basename; +use Cwd; + +BEGIN { + # Load the URI::Escape module safely + eval { require URI::Escape; }; + if ($@) { + my $progname = basename $0; + if ($@ =~ /^Can\'t locate URI\/Escape\.pm/) { + die "$progname: you must have the liburi-perl package installed\nto use this script\n"; + } + die "$progname: problem loading the URI::Escape module:\n $@\nHave you installed the liburi-perl package?\n"; + } + import URI::Escape; +} + +# Predeclare functions +sub fatal($); +my $warnings = 0; + +# And global variables +my $progname = basename($0); +my $modified_conf_msg; +my %env; +my $CHGLINE; # used by the format O section at the end + +sub usage () { + print <<"EOF"; +Usage: $progname [options] [changelog entry] +Options: + -a, --append + Append a new entry to the current changelog + -i, --increment + Increase the Infobot release number, adding a new changelog entry + -v , --newversion= + Add a new changelog entry with version number specified + -e, --edit + Don't change version number or add a new changelog entry, just + update the changelog's stamp and open up an editor + -r, --release + Update the changelog timestamp. + -d, --fromdirname + Add a new changelog entry with version taken from the directory name + -p, --preserve + Preserve the directory name + --no-preserve + Do not preserve the directory name (default) + --help, -h + Display this help message and exit + --version + Display version information + At most one of -a, -i, -e, -r, -v, -d (or their long equivalents) + may be used. + With no options, one of -i or -a is chosen by looking for a .upload + file in the parent directory and checking its contents. + +Default settings modified by devscripts configuration files: +$modified_conf_msg +EOF +} + +sub version () { + print <<"EOF"; +This is $progname, ripped from the Debian devscripts package, version 2.10.9 +This code is copyright 1999-2003 by Julian Gilbey, all rights reserved. +Based on code by Christoph Lameter. +This program comes with ABSOLUTELY NO WARRANTY. +You are free to redistribute this code under the terms of the +GNU General Public License, version 2 or later. +EOF +} + +# Start by setting default values +my $check_dirname_level = 1; +my $check_dirname_regex = 'PACKAGE(-.*)?'; +my $opt_p = 0; +my $opt_query = 1; +my $opt_release_heuristic = 'log'; +my $opt_multimaint = 1; +my $opt_multimaint_merge = 0; +my $opt_tz = undef; +my $opt_mainttrailer = 0; + +# Next, read configuration files and then command line +# The next stuff is boilerplate + +if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) { + $modified_conf_msg = " (no configuration files read)"; + shift; +} else { + my @config_files = ('~/.infobot-dev.conf'); + my %config_vars = ( + 'CHANGE_PRESERVE' => 'no', + 'CHANGE_TZ' => $ENV{TZ}, # undef if TZ unset + ); + $config_vars{'CHANGE_TZ'} ||= ''; + my %config_default = %config_vars; + + my $shell_cmd; + # Set defaults + foreach my $var (keys %config_vars) { + $shell_cmd .= qq[$var="$config_vars{$var}";\n]; + } + $shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n"; + $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n"; + # Read back values + foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" } + my $shell_out = `/bin/bash -c '$shell_cmd'`; + @config_vars{keys %config_vars} = split /\n/, $shell_out, -1; + + # Check validity + $config_vars{'CHANGE_PRESERVE'} =~ /^(yes|no)$/ + or $config_vars{'CHANGE_PRESERVE'}='no'; + + foreach my $var (sort keys %config_vars) { + if ($config_vars{$var} ne $config_default{$var}) { + $modified_conf_msg .= " $var=$config_vars{$var}\n"; + } + } + $modified_conf_msg ||= " (none)\n"; + chomp $modified_conf_msg; + + $opt_p = $config_vars{'CHANGE_PRESERVE'} eq 'yes' ? 1 : 0; + $opt_tz = $config_vars{'CHANGE_TZ'}; +} + +# We use bundling so that the short option behaviour is the same as +# with older debchange versions. +my ($opt_help, $opt_version); +my ($opt_i, $opt_a, $opt_e, $opt_r, $opt_v, $opt_b, $opt_d, $opt_D, $opt_u, $opt_t); +my ($opt_n, $opt_qa, $opt_bpo, $opt_c, $opt_m, $opt_create, $opt_package, @closes); +my ($opt_news); +my ($opt_ignore, $opt_level, $opt_regex, $opt_noconf); + +Getopt::Long::Configure('bundling'); +GetOptions("help|h" => \$opt_help, + "version" => \$opt_version, + "i|increment" => \$opt_i, + "a|append" => \$opt_a, + "e|edit" => \$opt_e, + "r|release" => \$opt_r, + "v|newversion=s" => \$opt_v, + "p" => \$opt_p, + "preserve!" => \$opt_p, + "release-heuristic=s" => \$opt_release_heuristic, + ) + or die "Usage: $progname [options] [changelog entry]\nRun $progname --help for more details\n"; + +if ($opt_noconf) { + fatal "--no-conf is only acceptable as the first command-line option!"; +} +if ($opt_help) { usage; exit 0; } +if ($opt_version) { version; exit 0; } + +# dirname stuff +if ($opt_ignore) { + fatal "--ignore-dirname has been replaced by --check-dirname-level and\n--check-dirname-regex; run $progname --help for more details"; +} + +if (defined $opt_level) { + if ($opt_level =~ /^[012]$/) { $check_dirname_level = $opt_level; } + else { + fatal "Unrecognised --check-dirname-level value (allowed are 0,1,2)"; + } +} + +if (defined $opt_regex) { $check_dirname_regex = $opt_regex; } + +# Only allow at most one non-help option +fatal "Only one of -a, -i, -e, -r, -v, -d is allowed;\ntry $progname --help for more help" + if ($opt_i?1:0) + ($opt_a?1:0) + ($opt_e?1:0) + ($opt_r?1:0) + ($opt_v?1:0) + ($opt_d?1:0) + ($opt_n?1:0) + ($opt_qa?1:0) + ($opt_bpo?1:0) > 1; + +my $changelog_path = $opt_c || $ENV{'CHANGELOG'} || 'Changelog'; +my $real_changelog_path = $changelog_path; +if ($changelog_path ne 'Changelog') { + $check_dirname_level = 0; +} + +if ($opt_create) { + if ($opt_a || $opt_i || $opt_e || $opt_r || $opt_b || $opt_n || $opt_qa || $opt_bpo) { + warn "$progname warning: ignoring -a/-i/-e/-r/-b/-n/--qa/--bpo options with --create\n"; + $warnings++; + } + if ($opt_package && $opt_d) { + fatal "Can only use one of --package and -d"; + } +} + + +@closes = split(/,/, join(',', @closes)); +map { s/^\#//; } @closes; # remove any leading # from bug numbers + +# We'll process the rest of the command line later. + +# Look for the changelog +my $chdir = 0; +if (! $opt_create) { + if ($changelog_path eq 'Changelog' or $opt_news) { + until (-f $changelog_path) { + $chdir = 1; + chdir '..' or fatal "Can't chdir ..: $!"; + if (cwd() eq '/') { + fatal "Cannot find $changelog_path anywhere!\nAre you in the source code tree?\n(You could use --create if you wish to create this file.)"; + } + } + + # Can't write, so stop now. + if (! -w $changelog_path) { + fatal "$changelog_path is not writable!"; + } + } + else { + unless (-f $changelog_path) { + fatal "Cannot find $changelog_path!\nAre you in the correct directory?\n(You could use --create if you wish to create this file.)"; + } + + # Can't write, so stop now. + if (! -w $changelog_path) { + fatal "$changelog_path is not writable!"; + } + } +} +else { # $opt_create + unless (-d dirname $changelog_path) { + fatal "Cannot find " . (dirname $changelog_path) . " directory!\nAre you in the correct directory?"; + } + if (-f $changelog_path) { + fatal "File $changelog_path already exists!"; + } + unless (-w dirname $changelog_path) { + fatal "Cannot find " . (dirname $changelog_path) . " directory!\nAre you in the correct directory?"; + } + if ($opt_news && ! -f 'debian/changelog') { + fatal "I can't create $opt_news without debian/changelog present"; + } +} + +##### + +# Find the current version number etc. +my %changelog; +my $PACKAGE = 'PACKAGE'; +my $VERSION = 'VERSION'; +my $MAINTAINER = 'MAINTAINER'; +my $EMAIL = 'EMAIL'; +my $DISTRIBUTION = 'UNRELEASED'; +my $CHANGES = ''; + +# Clean up after old versions of debchange +if (-f "debian/RELEASED") { + unlink("debian/RELEASED"); +} + +if ( -e "$changelog_path.clg" ) { + fatal "The backup file $changelog_path.clg 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('FULLNAME'); +check_env_utf8('NAME'); +check_env_utf8('EMAIL'); + +if (exists $env{'EMAIL'} and $env{'EMAIL'} =~ /^(.*)\s+<(.*)>$/) { + $env{'FULLNAME'} = $1 unless exists $env{'FULLNAME'}; + $env{'EMAIL'} = $2; +} +if (! exists $env{'EMAIL'} or ! exists $env{'FULLNAME'}) { + if (exists $env{'EMAIL'} and $env{'EMAIL'} =~ /^(.*)\s+<(.*)>$/) { + $env{'FULLNAME'} = $1 unless exists $env{'FULLNAME'}; + $env{'EMAIL'} = $2; + } +} + +# Now use the gleaned values to detemine our MAINTAINER and EMAIL values +if (! $opt_m) { + if (exists $env{'FULLNAME'}) { + $MAINTAINER = $env{'FULLNAME'}; + } elsif (exists $env{'NAME'}) { + $MAINTAINER = $env{'NAME'}; + } else { + my @pw = getpwuid $<; + if (defined($pw[6])) { + if (my $pw = decode_utf8($pw[6])) { + $pw =~ s/,.*//; + $MAINTAINER = $pw; + } else { + warn "$progname warning: passwd full name field for uid $<\nis not UTF-8 encoded; ignoring\n"; + $warnings++; + } + } + } + # Otherwise, $MAINTAINER retains its default value of the last + # changelog entry + + # Email is easier + if (exists $env{'EMAIL'}) { $EMAIL = $env{'EMAIL'}; } + elsif (exists $env{'EMAIL'}) { $EMAIL = $env{'EMAIL'}; } + else { + my $addr; + if (open MAILNAME, '/etc/mailname') { + chomp($addr = ); + 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 +} # if (! $opt_m) + +##### + +# Get a possible changelog entry from the command line +my $ARGS=join(' ', @ARGV); +my $TEXT=decode_utf8($ARGS); +my $EMPTY_TEXT=0; + +if (@ARGV and ! $TEXT) { + if ($ARGS) { + warn "$progname warning: command-line changelog entry not UTF-8 encoded; ignoring\n"; + $TEXT=''; + } else { + $EMPTY_TEXT = 1; + } +} + +# Get the date +my $date_cmd = ($opt_tz ? "TZ=$opt_tz " : "") . "date -R"; +chomp(my $DATE=`$date_cmd`); + +# Are we going to have to figure things out for ourselves? +if (! $opt_i && ! $opt_v && ! $opt_d && ! $opt_a && ! $opt_e && ! $opt_r && + ! $opt_create) { + # Yes, we are + if ($opt_release_heuristic eq 'log') { + my @UPFILES = glob("../$PACKAGE\_$SVERSION\_*.upload"); + if (@UPFILES > 1) { + fatal "Found more than one appropriate .upload file!\n" . + "Please use an explicit -a, -i or -v option instead."; + } + elsif (@UPFILES == 0) { $opt_a = 1 } + else { + open UPFILE, "<${UPFILES[0]}" + or fatal "Couldn't open .upload file for reading: $!\n" . + "Please use an explicit -a, -i or -v option instead."; + while () { + if (m%^(s|Successfully uploaded) (/.*/)?\Q$PACKAGE\E\_\Q$SVERSION\E\_[\w\-\+]+\.changes %) { + $opt_i = 1; + last; + } + } + close UPFILE + or fatal "Problems experienced reading .upload file: $!\n" . + "Please use an explicit -a, -i or -v option instead."; + if (! $opt_i) { + warn "$progname warning: A successful upload of the current version was not logged\n" . + "in the upload log file; adding log entry to current version."; + $opt_a = 1; + } + } + } +} + +# Open in anticipation.... +unless ($opt_create) { + open S, $changelog_path or fatal "Cannot open existing $changelog_path: $!"; +} +open O, ">$changelog_path.clg" + 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 || $opt_n || $opt_qa || $opt_bpo || $opt_v || $opt_d || + ($opt_news && $VERSION ne $changelog{'Version'})) && ! $opt_create) { + + # Check that a given explicit version number is sensible. + if ($opt_v || $opt_d) { + if($opt_v) { + $NEW_VERSION=$opt_v; + } else { + my $pwd = basename(cwd()); + # The directory name should be - + my $version_chars = '0-9a-zA-Z+\.~'; + $version_chars .= ':' if defined $EPOCH; + $version_chars .= '\-' if $UVERSION ne $SVERSION; + if ($pwd =~ m/^\Q$PACKAGE\E-([0-9][$version_chars]*)$/) { + $NEW_VERSION=$1; + if ($NEW_VERSION eq $UVERSION) { + # So it's a Debian-native package + if ($SVERSION eq $UVERSION) { + fatal "New version taken from directory ($NEW_VERSION) is equal to\n" . + "the current version number ($UVERSION)!"; + } + # So we just increment the Debian revision + warn "$progname warning: Incrementing Infobot revision without altering\n version number.\n"; + $VERSION =~ /^(.*?)([a-yA-Y][a-zA-Z]*|\d*)$/; + my $end = $2; + if ($end eq '') { + fatal "Cannot determine new revision; please use -v option!"; + } + $end++; + $NEW_VERSION="$1$end"; + } else { + $NEW_VERSION = "$EPOCH:$NEW_VERSION" if defined $EPOCH; + $NEW_VERSION .= "-1"; + } + } else { + fatal "The directory name must be - for -d to work!\n" . + "No underscores allowed!"; + } + # Don't try renaming the directory in this case! + $opt_p=1; + } + + if (system("dpkg --compare-versions $VERSION lt $NEW_VERSION" . + " 2>/dev/null 1>&2")) { + if ($opt_b) { + warn "$progname warning: new version ($NEW_VERSION) is less than\n" . + "the current version number ($VERSION).\n"; + } else { + fatal "New version specified ($NEW_VERSION) is less than\n" . + "the current version number ($VERSION)! Use -b to force."; + } + } + + ($NEW_SVERSION=$NEW_VERSION) =~ s/^\d+://; + ($NEW_UVERSION=$NEW_SVERSION) =~ s/-[^-]*$//; + } + + # We use the following criteria for the version and release number: + # the last component of the version number is used as the + # release number. If this is not a Debian native package, then the + # upstream version number is everything up to the final '-', not + # including epochs. + + if (! $NEW_VERSION) { + if ($VERSION =~ /(.*?)([a-yA-Y][a-zA-Z]*|\d+)$/i) { + my $end=$2; + my $start=$1; + # If it's not already an NMU make it so + # otherwise we can be safe if we behave like dch -i + if ($opt_n and (not $start =~ /\.$/ or $VERSION eq $UVERSION)) { + if ($VERSION eq $UVERSION) { + # First NMU of a Debian native package + $end .= "-0.1"; + } else { + $end += 0.1; + } + } elsif ($opt_qa and $start =~/(.*?)-(\d+)\.$/) { + # Drop NMU revision when doing a QA upload + my $upstream_version = $1; + my $debian_revision = $2; + $debian_revision++; + $start = "$upstream_version-$debian_revision"; + $end = ""; + } elsif ($opt_bpo and not $start =~ /~bpo\.$/) { + # If it's not already a backport make it so + # otherwise we can be safe if we behave like dch -i + $end .= "~bpo40+1"; + } elsif (!$opt_news) { + # Don't bump the version of a NEWS file in this case as we're + # using the version from the changelog + $end++; + } + $NEW_VERSION = "$start$end"; + ($NEW_SVERSION=$NEW_VERSION) =~ s/^\d+://; + ($NEW_UVERSION=$NEW_SVERSION) =~ s/-[^-]*$//; + } else { + fatal "Error parsing version number: $VERSION"; + } + } + + $line += 3; + print O "\n -- $MAINTAINER <$EMAIL> $DATE\n\n"; + + # Copy the old changelog file to the new one + local $/ = undef; + print O ; +} +elsif (($opt_r || $opt_a) && ! $opt_create) { + # This means we just have to generate a new * entry in changelog + # and if a multi-developer changelog is detected, add developer names. + + $NEW_VERSION=$VERSION; + $NEW_SVERSION=$SVERSION; + $NEW_UVERSION=$UVERSION; + + # Read and discard maintainer line, see who made the + # last entry, and determine whether there are existing + # multi-developer changes by the current maintainer. + $line=-1; + my ($lastmaint, $nextmaint, $maintline, $count, $lastheader, $lastdist); + my $savedline = $line;; + while () { + $line++; + # Start of existing changes by the current maintainer + if (/^ \[ $MAINTAINER \]$/) { + # If there's more than one such block, + # we only care about the first + $maintline ||= $line; + } + elsif (defined $lastmaint) { + if (m/^\w[-+0-9a-z.]* \([^\(\) \t]+\)((?:\s+[-+0-9a-z.]+)+)\;/i) { + $lastheader = $_; + $lastdist = $1; + $lastdist =~ s/^\s+//; + undef $lastdist if $lastdist eq "UNRELEASED"; + # Revert to our previously saved position + $line = $savedline; + last; + } + } + elsif (/^ --\s+([^<]+)\s+/) { + $lastmaint=$1; + # Remember where we are so we can skip back afterwards + $savedline = $line; + } + + if (defined $maintline && !defined $nextmaint) { + $maintline++; + } + } + + if (defined $maintline && defined $nextmaint) { + # Output the lines up to the end of the current maintainer block + $count=1; + $line=$maintline; + foreach (split /\n/, $CHANGES) { + print O $_ . "\n"; + $count++; + last if $count==$maintline; + } + } else { + # The first lines are as we have already found + print O $CHANGES; + }; + + if (defined $count) { + # Output the remainder of the changes + $count=1; + foreach (split /\n/, $CHANGES) { + $count++; + next unless $count>$maintline; + print O $_ . "\n"; + } + } + + if ($opt_t && $opt_a) { + print O "\n -- $changelog{'Maintainer'} $changelog{'Date'}\n"; + } else { + print O "\n -- $MAINTAINER <$EMAIL> $DATE\n"; + } + + if ($lastheader) { + print O "\n$lastheader"; + } + + # Copy the rest of the changelog file to new one + # Slurp the rest.... + local $/ = undef; + print O ; +} +elsif ($opt_e && ! $opt_create) { + # We don't do any fancy stuff with respect to versions or adding + # entries, we just update the timestamp and open the editor + + print O $CHANGES; + + if ($opt_t) { + print O "\n -- $changelog{'Maintainer'} $changelog{'Date'}\n"; + } else { + print O "\n -- $MAINTAINER <$EMAIL> $DATE\n"; + } + + # Copy the rest of the changelog file to the new one + $line=-1; + while () { $line++; last if /^ --/; } + # Slurp the rest... + local $/ = undef; + print O ; + + # Set the start-line to 0, as we don't know what they want to edit + $line=0; +} + +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 = ; +} + +# Now Run the Editor; always run if doing "closes" to give a chance to check +if (!$TEXT and !$EMPTY_TEXT) { + my $mtime = (stat("$changelog_path.clg"))[9]; + defined $mtime or fatal + "Error getting modification time of temporary $changelog_path: $!"; + + system("sensible-editor +$line $changelog_path.clg") == 0 or + fatal "Error editing $changelog_path"; +} + +copy("$changelog_path.clg","$changelog_path") or + fatal "Couldn't replace $changelog_path with new version: $!"; + +exit 0; + + +# Format for standard Debian changelogs +format CHANGELOG = + * ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $CHGLINE + ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $CHGLINE +. +# Format for NEWS files. +format NEWS = + ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $CHGLINE +~~^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $CHGLINE +. + +my $linecount=0; +sub format_line { + $CHGLINE=shift; + my $newentry=shift; + + print O "\n" if $opt_news && ! ($newentry || $linecount); + $linecount++; + my $f=select(O); + if ($opt_news) { + $~='NEWS'; + } + else { + $~='CHANGELOG'; + } + write O; + select $f; +} + +BEGIN { + # Initialise the variable + $tmpchk=0; +} + +END { + if ($tmpchk) { + unlink "$changelog_path.clg" or + warn "$progname warning: Could not remove $changelog_path.clg"; + unlink "$changelog_path.clg~"; # emacs backup file + } +} + +sub fatal($) { + my ($pack,$file,$line); + ($pack,$file,$line) = caller(); + (my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d; + $msg =~ s/\n\n$/\n/; + die $msg; +} + +# Is the environment variable valid or not? +sub check_env_utf8 { + my $envvar = $_[0]; + + if (exists $ENV{$envvar} and $ENV{$envvar} ne '') { + if (! decode_utf8($ENV{$envvar})) { + warn "$progname warning: environment variable $envvar not UTF-8 encoded; ignoring\n"; + } else { + $env{$envvar} = decode_utf8($ENV{$envvar}); + } + } +} + -- 2.39.5