#!/usr/bin/perl

# locale-gen
#
# Generates a glibc locale archive from templates, potentially limiting itself
# to a set of locales defined by the admin, typically within /etc/locale.gen.

use v5.36;

use Errno qw(ENOENT);
use File::Spec::Functions qw(canonpath catfile catdir path splitpath);
use File::Temp qw(tempdir);
use Getopt::Long ();
use List::Util qw(any first);
use Term::ANSIColor qw(colored);

# Formally stable as of v5.40; sufficiently functional in both v5.36 and v5.38.
use experimental qw(try);

my $PROGRAM = basename(__FILE__);
my $VERSION = '3.9';

my $DEFERRED_SIGNAL = '';
my $PID = $$;
my @TEMPFILES;

# Unset BASH_ENV for security reasons. Even as sh(1), bash acts upon it.
delete $ENV{'BASH_ENV'};

# Prevent the --verbose option of localedef(1) from being implicitly enabled.
delete $ENV{'POSIXLY_CORRECT'};

# Protect against the inheritance of an unduly restrictive umask.
umask 0022;

{
	# Determine the locale directory, as reported by localedef(1).
	my $locale_dir = get_locale_dir();

	# Infer the path of a Gentoo Prefix environment, if any.
	my $gentoo_prefix = '';
	if (defined $locale_dir) {
		$gentoo_prefix = detect_gentoo_prefix($locale_dir);
		if (length $gentoo_prefix) {
			$locale_dir =~ s/^\Q$gentoo_prefix//;
		}
	}

	# Collect any supported options and option-arguments.
	my %opt = parse_opts($gentoo_prefix, @ARGV);
	my $prefix = $opt{'prefix'} // $gentoo_prefix;

	# Ensure that locale/charmap files are opened relative to the prefix.
	$ENV{'I18NPATH'} = catdir($prefix, '/usr/share/i18n');

	# For the directory to be unknown strongly implies the absence of glibc.
	if (! defined $locale_dir) {
		die "$PROGRAM: Aborting because the OS does not appear to use GNU libc\n";
	}

	# Honour the --quiet option.
	if ($opt{'quiet'} && ! open *STDOUT, '>/dev/null') {
		die "Can't direct STDOUT to /dev/null: $!";
	}

	# Ensure that the C.UTF-8 locale is made available.
	my @locales = ([ 'C', 'UTF-8', 'C.UTF-8', 'C.UTF-8' ]);

	# Compose a list of up to two configuration files to be read.
	my @config_files = select_config_files($prefix, %opt);

	# Compose a dictionary of supported locale/charmap combinations.
	my $supported_by = map_supported_combinations($prefix);

	# Collect the locales that are being requested for installation.
	push @locales, read_config($prefix, $supported_by, @config_files);

	# Compose a dictionary of installed locales for the --update option.
	my %installed_by;
	if ($opt{'update'}) {
		# If localedef(1) originates from a Gentoo Prefix environment,
		# the prefix will already have been hard-coded by the utility.
		my $explicit_prefix = length $gentoo_prefix ? undef : $prefix;
		%installed_by = map +( $_ => 1 ), list_locales($explicit_prefix);
	}

	# Filter out locales that are duplicates or that are already installed.
	my %requested_by;
	my $i = 0;
	while ($i <= $#locales) {
		my $canonical = $locales[$i][2];
		my $normal = normalize($canonical);
		if ($requested_by{$normal}++ || $installed_by{$normal}) {
			splice @locales, $i, 1;
		} else {
			++$i;
		}
	}

	# If a non-actionable update was requested, proceed no further.
	if (! @locales) {
		print "All of the requested locales are presently installed.\n";
		exit;
	}

	# A proxy check is justified because compilation may take a long time.
	check_archive_dir($prefix, $locale_dir);

	# Create a temporary directory and switch to it.
	push @TEMPFILES, enter_tempdir($prefix);

	# Compile the selected locales.
	generate_locales($opt{'jobs'}, @locales);

	# Determine the eventual destination path of the archive.
	my $dst_path = catfile($prefix, $locale_dir, 'locale-archive');
	print "The location of the archive shall be '$dst_path'.\n";

	# Integrate the compiled locales into a new locale archive.
	my $src_path = do {
		my $prior_archive = $opt{'update'} ? $dst_path : undef;
		my @names = map +( $_->[3] ), @locales;
		generate_archive($gentoo_prefix, $locale_dir, $prior_archive, @names);
	};

	# Install the new locale archive.
	my $is_prefixed = length $prefix && ! is_eq_file($prefix, '/');
	my $size = install_archive($src_path, $dst_path, ! $is_prefixed);

	my $total = scalar @locales + scalar %installed_by;
	printf "Successfully installed an archive containing %d locale%s, of %s MiB in size.\n",
		$total, plural($total), round($size / 2 ** 20);

	# Issue a warning if the effective locale does not specify a charmap.
	if (! $is_prefixed) {
		check_effective_locale($supported_by);
	}
}

sub get_locale_dir () {
	my $stdout = qx{ LC_ALL=C localedef --help 2>/dev/null };
	if ($? == 0 && $stdout =~ m/\hlocale path\h*:\s+(\/[^:]+)/) {
		return canonpath($1);
	} elsif (($? & 0x7F) == 0) {
		# The child terminated normally (in the sense of WIFEXITED).
		return undef;
	} else {
		throw_child_error('localedef');
	}
}

sub detect_gentoo_prefix ($path) {
	if ($path !~ s/\/usr\/lib\/locale\z//) {
		die "Can't handle unexpected locale directory of '$path'";
	} elsif (length $path && -e "$path/etc/gentoo-release") {
		return $path;
	} else {
		return '';
	}
}

sub parse_opts ($known_prefix, @args) {
	my @options = (
		[ 'config|c=s' => "The file containing the chosen locales (default: $known_prefix/etc/locale.gen)" ],
		[ 'all|A'      => 'Select all locales, ignoring the config file' ],
		[ 'update|u'   => 'Skip any chosen locales that are already installed', ],
		[ 'jobs|j=i'   => 'Maximum number of localedef(1) instances to run in parallel' ],
		[ 'prefix|p=s' => 'The prefix of the root filesystem' ],
		[ 'quiet|q'    => 'Only show errors' ],
		[ 'version|V'  => 'Output version information and exit' ],
		[ 'help|h'     => 'Display this help and exit' ]
	);

	# Parse the provided arguments.
	my $parser = Getopt::Long::Parser->new;
	$parser->configure(qw(posix_default bundling_values no_ignore_case));
	my %opt;
	{
		# Decorate option validation errors while also not permitting
		# for more than one to be reported.
		local $SIG{'__WARN__'} = sub ($error) { die "$PROGRAM: $error" };
		$parser->getoptionsfromarray(\@args, \%opt, map +( $_->[0] ), @options);
	}

	# If either --help or --version was specified, exclusively attend to it.
	if ($opt{'help'}) {
		show_usage(@options);
		exit;
	} elsif ($opt{'version'}) {
		show_version();
		exit;
	}

	# Validate the options and option-arguments.
	if ($opt{'all'} && exists $opt{'config'}) {
		die "$PROGRAM: The --all and --config options are mutually exclusive\n";
	} elsif (length $opt{'prefix'} && $opt{'prefix'} !~ m/^\//) {
		die "$PROGRAM: The --prefix option must specify either a null string or an absolute path\n";
	}

	# Assign values for unspecified options that need them.
	if (! exists $opt{'jobs'} || $opt{'jobs'} < 1) {
		$opt{'jobs'} = get_nprocs() || 1;
	}

	# Replace the special <hyphen-minus> operand with "/dev/stdin".
	if (exists $opt{'config'} && $opt{'config'} eq '-') {
		$opt{'config'} = '/dev/stdin';
	}

	return %opt;
}

sub select_config_files ($prefix, %opt) {
	my $path1 = catfile($prefix, '/etc', 'locale.gen');
	my $path2 = catfile($prefix, '/usr/share/i18n', 'SUPPORTED');
	return do {
		if (exists $opt{'config'}) {
			$opt{'config'};
		} elsif ($opt{'all'}) {
			$path2;
		} elsif (exists $ENV{'LOCALEGEN_CONFIG'}) {
			$ENV{'LOCALEGEN_CONFIG'};
		} else {
			$path1, $path2;
		}
	};
}

sub show_usage (@options) {
	print "Usage: locale-gen [OPTION]...\n\n";
	my $pipe;
	if (! open $pipe, "| column -t -s \037") {
		exit 1;
	}
	for my $row (@options) {
		my ($spec, $description) = $row->@*;
		my ($long, $short) = split /[|=]/, $spec;
		printf {$pipe} "-%s, --%s\037%s\n", $short, $long, $description;
	}
	close $pipe;
	print "\nSee also: locale-gen(8), locale.gen(5)\n";
}

sub show_version () {
	print <<~EOF;
	locale-gen $VERSION
	Copyright 2024 Kerin Millar <kfm\@plushkava.net>
	License GPL-2.0-only <https://spdx.org/licenses/GPL-2.0-only.html>
	EOF
}

sub list_locales ($prefix) {
	if (! defined(my $pid = open my $pipe, '-|')) {
		die "Can't fork: $!";
	} elsif ($pid == 0) {
		my @args = ('--list-archive');
		if (length $prefix) {
			push @args, '--prefix', $prefix;
		}
		run('localedef', @args);
	} else {
		chomp(my @locales = readline $pipe);
		if (! close $pipe && $! == 0) {
			die "$PROGRAM: Can't obtain a list of the presently installed locales\n";
		}
		return @locales;
	}
}

sub normalize ($canonical) {
	# This is similar to the normalize_codeset() function of localedef(1).
	if ($canonical !~ m/(?<=\.)[^@]+/p) {
		die "Can't normalize " . render_printable($canonical);
	} else {
		# en_US.UTF-8 => en_US.utf8
		# de_DE.ISO-8859-15@euro => de_DE.iso885915@euro
		my $codeset = lc ${^MATCH} =~ tr/0-9A-Za-z//cdr;
		return ${^PREMATCH} . $codeset . ${^POSTMATCH};
	}
}

sub read_config ($prefix, $supported_by, @paths) {
	# Iterate over the given paths and return the first non-empty list of
	# valid locale declarations that can be found among them, if any.
	for my $i (keys @paths) {
		my $path = $paths[$i];
		my $fh;
		try {
			$fh = fopen($path);
		} catch ($e) {
			# Disregard open(2) errors concerning non-existent files
			# unless there are no more paths to be tried.
			if ($! == ENOENT && $i < $#paths) {
				next;
			} else {
				die $e;
			}
		}
		my @locales = parse_config($fh, $path, $supported_by);
		if (my $count = scalar @locales) {
			printf "Found %d locale declaration%s in '%s'.\n",
				$count, plural($count), $path;
			return @locales;
		}
	}

	# For no locales to have been discovered at this point is exceptional.
	my $path_list = render_printable(scalar @paths == 1 ? $paths[0] : \@paths);
	die "$PROGRAM: No locale declarations were found within $path_list\n";
}

sub map_supported_combinations ($prefix) {
	my $path = catfile($prefix, '/usr/share/i18n', 'SUPPORTED');
	my $fh = fopen($path);
	my %supported_by;
	while (my $line = readline $fh) {
		chomp $line;
		if (2 == (my ($locale, $charmap) = split ' ', $line)) {
			$supported_by{$locale}{$charmap} = 1;
			$supported_by{''}{$charmap} = 1;
		}
	}
	return \%supported_by;
}

sub parse_config ($fh, $path, $supported_by) {
	# Set up a helper routine to throw for validation errors.
	my $thrower = sub ($error, $line) {
		die sprintf "%s: %s at %s[%d]: %s\n",
			$PROGRAM, $error, $path, $., render_printable($line);
	};

	my @locales;
	while (my $line = readline $fh) {
		# Skip comments and blank lines. Note that \h will match only
		# " " and "\t", since the input stream is not being decoded.
		next if $line =~ m/^\h*($|#)/n;

		# Permit comments trailing locale declarations.
		$line =~ s/\h\K#\h.*//;

		# Expect for two fields, separated by horizontal whitespace.
		my ($locale, $charmap);
		chomp $line;
		if (2 != (($locale, $charmap) = split /\h+/, trim_line($line))) {
			$thrower->('Malformed locale declaration', $line);
		}

		# Handle "UTF8" as a special case. Though glibc tolerates it,
		# locale-gen would otherwise not because there is no charmap
		# file by that name. The intention is to encourage users to
		# amend their config files before eventually dropping support
		# for "UTF8" altogether.
		my @warnings;
		if ($locale =~ s/\.UTF\K8(?=@|\z)/-8/) {
			push @warnings,
				sprintf "Codeset specified as UTF8 (should be UTF-8) at %s[%d]: %s",
					$path, $., render_printable($line);
		}
		if ($charmap =~ s/^UTF\K8\z/-8/) {
			push @warnings,
				sprintf "Charmap specified as UTF8 (should be UTF-8) at %s[%d]: %s",
					$path, $., render_printable($line);
		}
		for my $warning (@warnings) {
			print_warning("WARNING! $warning\n");
		}

		# Validate both locale and character map before accepting.
		if (! $supported_by->{$locale}) {
			$thrower->('Invalid locale', $line);
		} elsif (! $supported_by->{''}{$charmap}) {
			$thrower->('Invalid charmap', $line);
		} elsif (! $supported_by->{$locale}{$charmap}) {
			$thrower->('Unsupported locale/charmap combination', $line);
		}

		# Determine the locale name in both the form that accords with
		# the subdirectories of /usr/share/i18n/locales, and in the
		# canonical form that incorporates the <codeset> part.
		($locale, my $canonical, my $name) = parse_entry($locale, $charmap);

		push @locales, [ $locale, $charmap, $canonical, $name ];
	}

	return @locales;
}

sub parse_entry ($locale, $charmap) {
	my $canonical;
	my $name;
	if (2 == (my @fields = split /@/, $locale, 3)) {
		# de_DE@euro ISO-8859-15 => de_DE.ISO-8859-15@euro
		$canonical = sprintf '%s.%s@%s', $fields[0], $charmap, $fields[1];
	} elsif (2 == (@fields = split /\./, $locale, 3)) {
		# en_US.UTF-8 UTF-8 => en_US.UTF-8
		$locale = $fields[0];
		$canonical = "$locale.$charmap";
	} elsif (1 == @fields) {
		# en_US ISO-8859-1 => en_US.ISO-8859-1
		$canonical = "$locale.$charmap";

		# Where given an input path whose name does not incorporate a
		# charmap, localedef(1) will incorporate it into the archive as
		# an alias of its canonical name. For example, "en_US" may refer
		# to "en_US.iso88591". It is strongly discouraged to rely on
		# this behaviour. Still, for now, ensure that the aliases exist.
		$name = $locale;
	}
	return $locale, $canonical, $name // $canonical;
}

sub check_archive_dir ($prefix, $locale_dir) {
	my $archive_dir = local $ENV{'DIR'} = catdir($prefix, $locale_dir);

	# Quietly attempt to create the directory if it does not already exist.
	system q{ mkdir -p -- "$DIR" 2>/dev/null };

	# Check whether the directory exists and can be modified by the EUID.
	if (! utime undef, undef, $archive_dir) {
		my $username = get_username();
		die "$PROGRAM: Aborting because '$username' can't modify '$archive_dir': $!\n";
	}
}

sub enter_tempdir ($prefix) {
	# Given that /tmp might be a tmpfs, prefer /var/tmp so as to avoid
	# undue memory pressure.
	my $dir = catdir($prefix, '/var/tmp');
	if (! -d $dir) {
		$dir = File::Spec->tmpdir;
	}
	my $tmpdir = tempdir('locale-gen.XXXXXXXXXX', 'DIR' => $dir);
	if (! chdir $tmpdir) {
		die "$PROGRAM: Can't chdir to '$tmpdir': $!\n";
	} else {
		return $tmpdir;
	}
}

sub generate_locales ($workers, @locales) {
	# Trap SIGINT and SIGTERM so that they may be handled gracefully.
	my $handler = sub ($signal) { $DEFERRED_SIGNAL ||= $signal };
	local @SIG{'INT', 'TERM'} = ($handler, $handler);

	my $total = scalar @locales;
	if ($total < $workers) {
		$workers = $total;
	}
	printf "Compiling %d locale%s with %d worker%s ...\n",
		$total, plural($total), $workers, plural($workers);

	my $num_width = length $total;
	my %status_by;
	for my $i (keys @locales) {
		# Ensure that the number of concurrent workers is bounded.
		if ($i >= $workers) {
			my $pid = wait;
			last if 0 != ($status_by{$pid} = $?);
		}

		my ($locale, $charmap, $canonical, $name) = $locales[$i]->@*;
		printf "[%*d/%d] Compiling locale: %s%s\n",
			$num_width,
			$i + 1,
			$total,
			$canonical,
			$name eq $canonical ? '' : " ($name)";

		# Fork and execute localedef(1) for locale compilation.
		if (! defined(my $pid = fork)) {
			warn "Can't fork: $!";
			last;
		} elsif ($pid == 0) {
			@SIG{'INT', 'TERM'} = ('DEFAULT', 'DEFAULT');
			compile_locale($locale, $charmap, $name);
		}
	} continue {
		last if $DEFERRED_SIGNAL;
	}

	# Reap any subprocesses that remain.
	if ($workers > 1) {
		print "Waiting for active workers to finish their jobs ...\n";
	}
	while (-1 != (my $pid = wait)) {
		$status_by{$pid} = $?;
	}

	# Abort if any of the collected status codes are found to be non-zero.
	# Should a subprocess be interrupted by a signal while another exited
	# non-zero, the resulting diagnostic shall allude only to the signal.
	for my $status (sort { $a <=> $b } values %status_by) {
		throw_child_error('localedef', $status);
	}

	if ($DEFERRED_SIGNAL) {
		# The signal shall be propagated by the END block.
		exit;
	} elsif (scalar %status_by != $total) {
		die "$PROGRAM: Aborting because not all of the selected locales were compiled\n";
	}
}

sub compile_locale ($locale, $charmap, $name) {
	my $output_dir = "./$name";
	run('localedef', '--no-archive', '-i', $locale, '-f', $charmap, '--', $output_dir);
}

sub generate_archive ($gentoo_prefix, $locale_dir, $prior_archive, @names) {
	# Create the temporary subdir that will contain the new locale archive.
	my $output_dir = catdir('.', $gentoo_prefix, $locale_dir);
	run('mkdir', '-p', '--', $output_dir);

	# If specified, make a copy of the prior archive for updating.
	if (length $prior_archive && -e $prior_archive) {
		run('cp', '--', $prior_archive, "$output_dir/");
	}

	# Integrate all of the compiled locales into the new locale archive.
	my $total = scalar @names;
	printf "Adding %d locale%s to the locale archive ...\n", $total, plural($total);
	my $stderr;
	if (! defined(my $pid = open my $pipe, '-|')) {
		die "Can't fork: $!";
	} elsif ($pid == 0) {
		if (! open *STDERR, '>&=', *STDOUT) {
			die "Can't direct STDERR to STDOUT: $!\n";
		}
		run(qw( localedef --prefix . --quiet --add-to-archive -- ), @names);
	} else {
		local $/;
		$stderr = readline $pipe;
		if (length $stderr) {
			warn $stderr;
		}
		close $pipe;
	}

	# Check the status code first.
	throw_child_error('localedef');

	# Sadly, the exit status of GNU localedef(1) is nigh on useless in the
	# case that the --add-to-archive option is provided. If anything was
	# printed to STDERR at all, act as if the utility had exited 1.
	if (length $stderr) {
		throw_child_error('localedef', 1 << 8);
	}

	return catfile($output_dir, 'locale-archive');
}

sub install_archive ($src_path, $dst_path, $may_reset_labels) {
	# Determine whether the underlying filesystem supports SELinux labels.
	my $has_seclabels = has_mount_option(dirname($dst_path), 'seclabel');

	# Determine whether a previously installed archive exists.
	my $has_archive = $has_seclabels && -e $dst_path;

	# The process of replacing the prior archive must not be interrupted.
	local @SIG{'INT', 'TERM'} = ('IGNORE', 'IGNORE');

	# Move the new archive into the appropriate filesystem. Use mv(1),
	# since there is a chance of crossing a filesystem boundary.
	push @TEMPFILES, my $interim_path = "$dst_path.$$";
	run('mv', '--', $src_path, $interim_path);

	# If a prior archive exists, attempt to preserve its SELinux label.
	if ($has_seclabels && $has_archive) {
		copy_security_context($dst_path, $interim_path);
	}

	# Activate the new archive by atomically renaming it into place.
	if (! rename $interim_path, $dst_path) {
		die "$PROGRAM: Can't rename '$interim_path' to '$dst_path': $!\n";
	}

	# If no prior archive existed, restore the appropriate SELinux label.
	if ($has_seclabels && ! $has_archive && $may_reset_labels && can_run('restorecon')) {
		run('restorecon', '-Fmv', '--', $dst_path);
	}

	# Return the size of the archive, in bytes.
	if (! (my @stat = stat $dst_path)) {
		die "$PROGRAM: Can't stat '$dst_path': $!\n";
	} else {
		return $stat[7];
	}
}

sub check_effective_locale ($supported_by) {
	my $locale = first(sub { length $_ }, @ENV{'LC_ALL', 'LANG'});
	if (! defined $locale || $locale =~ m/\./) {
		# No locale is effective, or that which is specifies a codeset.
		return;
	} elsif (exists $supported_by->{$locale}) {
		print_warning("WARNING! An ambiguous locale is currently in effect: $locale\n");
		my $utility;
		if (-d '/run/systemd') {
			$utility = 'localectl';
		} elsif (-d '/run/openrc') {
			$utility = 'eselect';
		}
		if (defined $utility) {
			print_warning("It is strongly recommended to choose another with the ${utility}(1) utility.\n");
		}
	}
}

sub copy_security_context ($src_path, $dst_path) {
	local @ENV{'SRC_PATH', 'DST_PATH'} = ($src_path, $dst_path);
	my $stderr = qx{ LC_ALL=C chcon --reference="\$SRC_PATH" -- "\$DST_PATH" 2>&1 >/dev/null };
	# Throw exceptions for any errors that are not a consequence of ENOTSUP.
	if ($? != 0 && $stderr !~ m/: Operation not supported$/m) {
		if (length $stderr) {
			warn $stderr;
		}
		throw_child_error('chcon');
	}
}

sub fopen ($path) {
	if (! open my $fh, '<', $path) {
		die "$PROGRAM: Can't open '$path': $!\n";
	} elsif (! -f $fh && canonpath($path) !~ m/^\/dev\/(null|stdin)\z/n) {
		die "$PROGRAM: Won't open '$path' because it is not a regular file\n";
	} else {
		return $fh;
	}
}

sub get_nprocs () {
	chomp(my $nproc = qx{ { nproc || getconf _NPROCESSORS_CONF; } 2>/dev/null });
	return $nproc;
}

sub plural ($int) {
	return $int == 1 ? '' : 's';
}

sub render_printable ($value) {
	require JSON::PP;
	return JSON::PP->new->ascii->space_after->encode($value)
}

sub run ($cmd, @args) {
	if ($$ == $PID) {
		system $cmd, @args;
		throw_child_error($cmd);
	} else {
		# Refrain from forking if called from a subprocess.
		exec $cmd, @args;
		exit ($! == ENOENT ? 127 : 126);
	}
}

sub throw_child_error ($cmd, $status = $?) {
	if ($status == -1) {
		# The program could not be started. Since Perl will already
		# have printed a warning, no supplemental diagnostic is needed.
		exit 1;
	} elsif ($status != 0) {
		my $fate = ($status & 0x7F) ? 'interrupted by a signal' : 'unsuccessful';
		die "$PROGRAM: Aborting because the execution of '$cmd' was $fate\n";
	}
}

sub trim_line ($line) {
	$line =~ s/^\h+//;
	$line =~ s/\h+$//;
	return $line;
}

sub get_username () {
	local $!;
	return getpwuid($>) // $ENV{'LOGNAME'};
}

sub round ($number) {
	# Evaluation conveniently trims insignificant trailing zeroes.
	return eval(sprintf '%.2f', $number);
}

sub basename ($path) {
	return (splitpath($path))[2];
}

sub dirname ($path) {
	return (splitpath($path))[1];
}

sub has_mount_option ($target, $option) {
	# Per bug 962817, / may not necessarily exist as a mountpoint. Assuming
	# it does not, ignore the case that findmnt(8) exits with a status of 1.
	local $ENV{'TARGET'} = $target;
	my $stdout = qx{
		findmnt -no options -T "\$TARGET"
		case \$? in 1) ! mountpoint -q / ;; *) exit "\$?" ;; esac
	};
	throw_child_error('findmnt');
	chomp $stdout;
	return ",$stdout," =~ m/\Q,$option,/;
}

sub can_run ($bin) {
	return any(sub { -f "$_/$bin" && -x _ }, path());
}

sub print_warning ($warning) {
	if (-t 2) {
		*STDOUT->flush;
		print STDERR colored($warning, 'bold yellow');
	} else {
		print STDERR $warning;
	}
}

sub is_eq_file ($path1, $path2) {
	# Compare the inode numbers, just as the test(1) -ef operator does.
	my @stat1 = stat $path1;
	my @stat2 = stat $path2;
	return @stat1 && @stat2 && $stat1[1] == $stat2[1];
}

END {
	if ($$ == $PID) {
		if (@TEMPFILES) {
			local $?;
			system 'rm', '-rf', '--', @TEMPFILES;
		}

		# The default SIGINT and SIGTERM handlers are suppressed by
		# generate_locales. The former is especially important, per
		# http://www.cons.org/cracauer/sigint.html.
		if ($DEFERRED_SIGNAL) {
			kill $DEFERRED_SIGNAL, $$;
		}
	}
}
