D7net Mini Sh3LL v1
| Current File : //../../usr/share/locale/mjw/../it/../he/../../iptables/../php/../perl5/Debian/Debhelper/Dh_Lib.pm |
#!/usr/bin/perl
#
# Library functions for debhelper programs, perl version.
#
# Joey Hess, GPL copyright 1997-2008.
package Debian::Debhelper::Dh_Lib;
use strict;
use warnings;
use utf8;
use constant {
# Lowest compat level supported
'MIN_COMPAT_LEVEL' => 5,
# Lowest compat level that does *not* cause deprecation
# warnings
'LOWEST_NON_DEPRECATED_COMPAT_LEVEL' => 9,
# Lowest compat level to generate "debhelper-compat (= X)"
# relations for.
'LOWEST_VIRTUAL_DEBHELPER_COMPAT_LEVEL' => 9,
# Highest compat level permitted
'MAX_COMPAT_LEVEL' => 13,
# Magic value for xargs
'XARGS_INSERT_PARAMS_HERE' => \'<INSERT-HERE>', #'# Hi emacs.
# Magic value for debhelper tools to request "current version"
'DH_BUILTIN_VERSION' => \'<DH_LIB_VERSION>', #'# Hi emacs.
# Default Package-Type / extension (must be aligned with dpkg)
'DEFAULT_PACKAGE_TYPE' => 'deb',
};
use constant {
# Package-Type / extension for dbgsym packages
# TODO: Find a way to determine this automatically from the vendor
# - blocked by Dpkg::Vendor having a rather high load time (for debhelper)
'DBGSYM_PACKAGE_TYPE' => 'ddeb',
};
use Errno qw(ENOENT EXDEV);
use Exporter qw(import);
use File::Glob qw(bsd_glob GLOB_CSH GLOB_NOMAGIC GLOB_TILDE);
our (@EXPORT, %dh);
@EXPORT = (
# debhelper basis functionality
qw(
init
%dh
compat
),
# External command tooling API
qw(
doit
doit_noerror
qx_cmd
xargs
XARGS_INSERT_PARAMS_HERE
print_and_doit
print_and_doit_noerror
complex_doit
escape_shell
),
# Logging/messaging/error handling
qw(
error
error_exitcode
warning
verbose_print
nonquiet_print
),
# Package related actions
qw(
getpackages
sourcepackage
tmpdir
dbgsym_tmpdir
default_sourcedir
pkgfile
pkgext
pkgfilename
package_is_arch_all
package_binary_arch
package_declared_arch
package_multiarch
package_section
package_arch
process_pkg
compute_doc_main_package
isnative
is_udeb
),
# File/path related actions
qw(
basename
dirname
install_file
install_prog
install_lib
install_dir
install_dh_config_file
make_symlink
make_symlink_raw_target
rename_path
find_hardlinks
rm_files
excludefile
is_so_or_exec_elf_file
is_empty_dir
reset_perm_and_owner
log_installed_files
filearray
filedoublearray
glob_expand
glob_expand_error_handler_reject
glob_expand_error_handler_warn_and_discard
glob_expand_error_handler_silently_ignore
glob_expand_error_handler_reject_nomagic_warn_discard
),
# Generate triggers, substvars, maintscripts, build-time temporary files
qw(
autoscript
autotrigger
addsubstvar
delsubstvar
generated_file
restore_file_on_clean
),
# Split tasks among different cores
qw(
on_pkgs_in_parallel
on_items_in_parallel
on_selected_pkgs_in_parallel
),
# R³ framework
qw(
should_use_root
gain_root_cmd
),
# Architecture, cross-tooling, build options and profiles
qw(
dpkg_architecture_value
hostarch
cross_command
is_cross_compiling
is_build_profile_active
get_buildoption
perl_cross_incdir
),
# Other
qw(
open_gz
get_source_date_epoch
deprecated_functionality
),
# Special-case functionality (e.g. tool specific), debhelper(-core) functionality and deprecated functions
qw(
inhibit_log
load_log
write_log
commit_override_log
debhelper_script_subst
is_make_jobserver_unavailable
clean_jobserver_makeflags
set_buildflags
DEFAULT_PACKAGE_TYPE
DBGSYM_PACKAGE_TYPE
DH_BUILTIN_VERSION
is_known_package
assert_opt_is_known_package
restore_all_files
buildarch
));
# The Makefile changes this if debhelper is installed in a PREFIX.
my $prefix="/usr";
my $MAX_PROCS = get_buildoption("parallel") || 1;
my $DH_TOOL_VERSION;
our $PKGNAME_REGEX = qr/[a-z0-9][-+\.a-z0-9]+/o;
our $PKGVERSION_REGEX = qr/
(?: \d+ : )? # Optional epoch
[0-9][0-9A-Za-z.+:~]* # Upstream version (with no hyphens)
(?: - [0-9A-Za-z.+:~]+ )* # Optional debian revision (+ upstreams versions with hyphens)
/xoa;
our $MAINTSCRIPT_TOKEN_REGEX = qr/[A-Za-z0-9_.+]+/o;
# From Policy 5.1:
#
# The field name is composed of US-ASCII characters excluding control
# characters, space, and colon (i.e., characters in the ranges U+0021
# (!) through U+0039 (9), and U+003B (;) through U+007E (~),
# inclusive). Field names must not begin with the comment character
# (U+0023 #), nor with the hyphen character (U+002D -).
our $DEB822_FIELD_REGEX = qr/
[\x21\x22\x24-\x2C\x2F-\x39\x3B-\x7F] # First character
[\x21-\x39\x3B-\x7F]* # Subsequent characters (if any)
/xoa;
our $PARSE_DH_SEQUENCE_INFO = 0;
# We need logging in compat 9 or in override/hook targets (for --remaining-packages to work)
# - This option is a global toggle to disable logs for special commands (e.g. dh or dh_clean)
# It is initialized during "init". This implies that commands that never calls init are
# not dh_* commands or do not need the log
my $write_log = undef;
sub init {
my %params=@_;
if ($params{internal_parse_dh_sequence_info}) {
$PARSE_DH_SEQUENCE_INFO = 1;
}
# Check if we can by-pass the expensive Getopt::Long by optimising for the
# common case of "-a" or "-i"
if (scalar(@ARGV) == 1 && ($ARGV[0] eq '-a' || $ARGV[0] eq '-i') &&
! (defined $ENV{DH_OPTIONS} && length $ENV{DH_OPTIONS}) &&
! (defined $ENV{DH_INTERNAL_OPTIONS} && length $ENV{DH_INTERNAL_OPTIONS})) {
# Single -i or -a as dh does it.
if ($ARGV[0] eq '-i') {
push(@{$dh{DOPACKAGES}}, getpackages('indep'));
$dh{DOINDEP} = 1;
} else {
push(@{$dh{DOPACKAGES}}, getpackages('arch'));
$dh{DOARCH} = 1;
}
if (! @{$dh{DOPACKAGES}}) {
if (! $dh{BLOCK_NOOP_WARNINGS}) {
warning("You asked that all arch in(dep) packages be built, but there are none of that type.");
}
exit(0);
}
# Clear @ARGV so we do not hit the expensive case below
@ARGV = ();
}
# Check to see if an option line starts with a dash,
# or DH_OPTIONS is set.
# If so, we need to pass this off to the resource intensive
# Getopt::Long, which I'd prefer to avoid loading at all if possible.
if ((defined $ENV{DH_OPTIONS} && length $ENV{DH_OPTIONS}) ||
(defined $ENV{DH_INTERNAL_OPTIONS} && length $ENV{DH_INTERNAL_OPTIONS}) ||
grep /^-/, @ARGV) {
eval { require Debian::Debhelper::Dh_Getopt; };
error($@) if $@;
Debian::Debhelper::Dh_Getopt::parseopts(%params);
}
# Another way to set excludes.
if (exists $ENV{DH_ALWAYS_EXCLUDE} && length $ENV{DH_ALWAYS_EXCLUDE}) {
push @{$dh{EXCLUDE}}, split(":", $ENV{DH_ALWAYS_EXCLUDE});
}
# Generate EXCLUDE_FIND.
if ($dh{EXCLUDE}) {
$dh{EXCLUDE_FIND}='';
foreach (@{$dh{EXCLUDE}}) {
my $x=$_;
$x=escape_shell($x);
$x=~s/\./\\\\./g;
$dh{EXCLUDE_FIND}.="-regex .\\*$x.\\* -or ";
}
$dh{EXCLUDE_FIND}=~s/ -or $//;
}
# Check to see if DH_VERBOSE environment variable was set, if so,
# make sure verbose is on. Otherwise, check DH_QUIET.
if (defined $ENV{DH_VERBOSE} && $ENV{DH_VERBOSE} ne "") {
$dh{VERBOSE}=1;
} elsif (defined $ENV{DH_QUIET} && $ENV{DH_QUIET} ne "" || get_buildoption("terse")) {
$dh{QUIET}=1;
}
# Check to see if DH_NO_ACT environment variable was set, if so,
# make sure no act mode is on.
if (defined $ENV{DH_NO_ACT} && $ENV{DH_NO_ACT} ne "") {
$dh{NO_ACT}=1;
}
# Get the name of the main binary package (first one listed in
# debian/control). Only if the main package was not set on the
# command line.
if (! exists $dh{MAINPACKAGE} || ! defined $dh{MAINPACKAGE}) {
my @allpackages=getpackages();
$dh{MAINPACKAGE}=$allpackages[0];
}
# Check if packages to build have been specified, if not, fall back to
# the default, building all relevant packages.
if (! defined $dh{DOPACKAGES} || ! @{$dh{DOPACKAGES}}) {
push @{$dh{DOPACKAGES}}, getpackages('both');
}
# Check to see if -P was specified. If so, we can only act on a single
# package.
if ($dh{TMPDIR} && $#{$dh{DOPACKAGES}} > 0) {
error("-P was specified, but multiple packages would be acted on (".join(",",@{$dh{DOPACKAGES}}).").");
}
# Figure out which package is the first one we were instructed to build.
# This package gets special treatement: files and directories specified on
# the command line may affect it.
$dh{FIRSTPACKAGE}=${$dh{DOPACKAGES}}[0];
# If no error handling function was specified, just propagate
# errors out.
if (! exists $dh{ERROR_HANDLER} || ! defined $dh{ERROR_HANDLER}) {
$dh{ERROR_HANDLER}='exit 1';
}
$dh{U_PARAMS} //= [];
if ($params{'inhibit_log'}) {
$write_log = 0;
} else {
# Only initialize if unset (i.e. avoid overriding an early call
# to inhibit_log()
$write_log //= 1;
}
}
# Ensure the log is written if requested but only if the command was
# successful.
sub END {
return if $? != 0 or not $write_log;
# If there is no 'debian/control', then we are not being run from
# a package directory and then the write_log will not do what we
# expect.
return if not -f 'debian/control';
if (compat(9, 1) || $ENV{DH_INTERNAL_OVERRIDE}) {
write_log(basename($0), @{$dh{DOPACKAGES}});
}
}
sub logfile {
my $package=shift;
my $ext=pkgext($package);
return "debian/${ext}debhelper.log"
}
sub load_log {
my ($package, $db)=@_;
my @log;
open(LOG, "<", logfile($package)) || return;
while (<LOG>) {
chomp;
my $command = $_;
push @log, $command;
$db->{$package}{$command}=1 if defined $db;
}
close LOG;
return @log;
}
sub write_log {
my $cmd=shift;
my @packages=@_;
return if $dh{NO_ACT};
foreach my $package (@packages) {
my $log = logfile($package);
open(LOG, ">>", $log) || error("failed to write to ${log}: $!");
print LOG $cmd."\n";
close LOG;
}
}
sub commit_override_log {
my @packages=@_;
return if $dh{NO_ACT};
foreach my $package (@packages) {
my @log = load_log($package);
my $log = logfile($package);
open(LOG, ">", $log) || error("failed to write to ${log}: $!");
print LOG $_."\n" foreach @log;
close LOG;
}
}
sub inhibit_log {
$write_log=0;
}
# Pass it an array containing the arguments of a shell command like would
# be run by exec(). It turns that into a line like you might enter at the
# shell, escaping metacharacters and quoting arguments that contain spaces.
sub escape_shell {
my @args=@_;
my @ret;
foreach my $word (@args) {
if ($word=~/\s/) {
# Escape only a few things since it will be quoted.
# Note we use double quotes because you cannot
# escape ' in single quotes, while " can be escaped
# in double.
# This does make -V"foo bar" turn into "-Vfoo bar",
# but that will be parsed identically by the shell
# anyway..
$word=~s/([\n`\$"\\])/\\$1/g;
push @ret, "\"$word\"";
}
else {
# This list is from _Unix in a Nutshell_. (except '#')
$word=~s/([\s!"\$()*+#;<>?@\[\]\\`|~])/\\$1/g;
push @ret,$word;
}
}
return join(' ', @ret);
}
# Run a command, and display the command to stdout if verbose mode is on.
# Throws error if command exits nonzero.
#
# All commands that modify files in $TMP should be run via this
# function.
#
# Note that this cannot handle complex commands, especially anything
# involving redirection. Use complex_doit instead.
sub doit {
doit_noerror(@_) || error_exitcode(_format_cmdline(@_));
}
sub doit_noerror {
verbose_print(_format_cmdline(@_)) if $dh{VERBOSE};
goto \&_doit;
}
sub print_and_doit {
print_and_doit_noerror(@_) || error_exitcode(_format_cmdline(@_));
}
sub print_and_doit_noerror {
nonquiet_print(_format_cmdline(@_));
goto \&_doit;
}
sub _doit {
my (@cmd) = @_;
my $options = ref($cmd[0]) ? shift(@cmd) : undef;
# In compat <= 11, we warn, in compat 12 we assume people know what they are doing.
if (not defined($options) and @cmd == 1 and compat(12) and $cmd[0] =~ m/[\s<&>|;]/) {
deprecated_functionality('doit() + doit_*() calls will no longer spawn a shell in compat 12 for single string arguments (please use complex_doit instead)',
12);
return 1 if $dh{NO_ACT};
return system(@cmd) == 0;
}
return 1 if $dh{NO_ACT};
my $pid = fork() // error("fork(): $!");
if (not $pid) {
if (defined($options)) {
if (defined(my $dir = $options->{chdir})) {
if ($dir ne '.') {
chdir($dir) or error("chdir(\"${dir}\") failed: $!");
}
}
open(STDIN, '<', '/dev/null') or error("redirect STDIN failed: $!");
if (defined(my $output = $options->{stdout})) {
open(STDOUT, '>', $output) or error("redirect STDOUT failed: $!");
}
if (defined(my $update_env = $options->{update_env})) {
while (my ($k, $v) = each(%{$update_env})) {
if (defined($v)) {
$ENV{$k} = $v;
} else {
delete($ENV{$k});
}
}
}
}
# Force execvp call to avoid shell. Apparently, even exec can
# involve a shell if you don't do this.
exec { $cmd[0] } @cmd;
}
return waitpid($pid, 0) == $pid && $? == 0;
}
sub _format_cmdline {
my (@cmd) = @_;
my $options = ref($cmd[0]) ? shift(@cmd) : {};
my $cmd_line = escape_shell(@cmd);
if (defined(my $update_env = $options->{update_env})) {
my $need_env = 0;
my @params;
for my $key (sort(keys(%{$update_env}))) {
my $value = $update_env->{$key};
if (defined($value)) {
my $quoted_key = escape_shell($key);
push(@params, join('=', $quoted_key, escape_shell($value)));
# shell does not like: "FU BAR"=1 cmd
# if the ENV key has weird symbols, the best bet is to use env
$need_env = 1 if $quoted_key ne $key;
} else {
$need_env = 1;
push(@params, escape_shell("--unset=${key}"));
}
}
unshift(@params, 'env', '--') if $need_env;
$cmd_line = join(' ', @params, $cmd_line);
}
if (defined(my $dir = $options->{chdir})) {
$cmd_line = join(' ', 'cd', escape_shell($dir), '&&', $cmd_line) if $dir ne '.';
}
if (defined(my $output = $options->{stdout})) {
$cmd_line .= ' > ' . escape_shell($output);
}
return $cmd_line;
}
sub qx_cmd {
my (@cmd) = @_;
my ($output, @output);
open(my $fd, '-|', @cmd) or error('fork+exec (' . escape_shell(@cmd) . "): $!");
if (wantarray) {
@output = <$fd>;
} else {
local $/ = undef;
$output = <$fd>;
}
if (not close($fd)) {
error("close pipe failed: $!") if $!;
error_exitcode(escape_shell(@cmd));
}
return @output if wantarray;
return $output;
}
# Run a command and display the command to stdout if verbose mode is on.
# Use doit() if you can, instead of this function, because this function
# forks a shell. However, this function can handle more complicated stuff
# like redirection.
sub complex_doit {
verbose_print(join(" ",@_));
if (! $dh{NO_ACT}) {
# The join makes system get a scalar so it forks off a shell.
system(join(" ", @_)) == 0 || error_exitcode(join(" ", @_))
}
}
sub error_exitcode {
my $command=shift;
if ($? == -1) {
error("$command failed to execute: $!");
}
elsif ($? & 127) {
error("$command died with signal ".($? & 127));
}
elsif ($?) {
error("$command returned exit code ".($? >> 8));
}
else {
warning("This tool claimed that $command have failed, but it");
warning("appears to have returned 0.");
error("Probably a bug in this tool is hiding the actual problem.");
}
}
# Some shortcut functions for installing files and dirs to always
# have the same owner and mode
# install_file - installs a non-executable
# install_prog - installs an executable
# install_lib - installs a shared library (some systems may need x-bit, others don't)
# install_dir - installs a directory
{
my $_loaded = 0;
sub install_file {
unshift(@_, 0644);
goto \&_install_file_to_path;
}
sub install_prog {
unshift(@_, 0755);
goto \&_install_file_to_path;
}
sub install_lib {
unshift(@_, 0644);
goto \&_install_file_to_path;
}
sub _install_file_to_path {
my ($mode, $source, $dest) = @_;
if (not $_loaded) {
$_loaded++;
require File::Copy;
}
verbose_print(sprintf('install -p -m%04o %s', $mode, escape_shell($source, $dest)))
if $dh{VERBOSE};
return 1 if $dh{NO_ACT};
# "install -p -mXXXX foo bar" silently discards broken
# symlinks to install the file in place. File::Copy does not,
# so emulate it manually. (#868204)
if ( -l $dest and not -e $dest and not unlink($dest) and $! != ENOENT) {
error("unlink $dest failed: $!");
}
File::Copy::copy($source, $dest) or error("copy($source, $dest): $!");
chmod($mode, $dest) or error("chmod($mode, $dest): $!");
my (@stat) = stat($source);
error("stat($source): $!") if not @stat;
utime($stat[8], $stat[9], $dest)
or error(sprintf("utime(%d, %d, %s): $!", $stat[8] , $stat[9], $dest));
return 1;
}
}
{
my $_loaded = 0;
sub install_dir {
my @to_create = grep { not -d $_ } @_;
return if not @to_create;
if (not $_loaded) {
$_loaded++;
require File::Path;
}
verbose_print(sprintf('install -d %s', escape_shell(@to_create)))
if $dh{VERBOSE};
return 1 if $dh{NO_ACT};
eval {
File::Path::make_path(@to_create, {
# install -d uses 0755 (no umask), make_path uses 0777 (& umask) by default.
# Since we claim to run install -d, then ensure the mode is correct.
'chmod' => 0755,
});
};
if (my $err = "$@") {
$err =~ s/\s+at\s+\S+\s+line\s+\d+\.?\n//;
error($err);
}
}
}
sub rename_path {
my ($source, $dest) = @_;
if ($dh{VERBOSE}) {
my $files = escape_shell($source, $dest);
verbose_print("mv $files");
}
return 1 if $dh{NO_ACT};
if (not rename($source, $dest)) {
my $ok = 0;
if ($! == EXDEV) {
# Replay with a fork+exec to handle crossing two mount
# points (See #897569)
$ok = _doit('mv', $source, $dest);
}
if (not $ok) {
my $files = escape_shell($source, $dest);
error("mv $files: $!");
}
}
return 1;
}
sub reset_perm_and_owner {
my ($mode, @paths) = @_;
my $_mode;
my $use_root = should_use_root();
# Dark goat blood to tell 0755 from "0755"
if (length( do { no warnings "numeric"; $mode & "" } ) ) {
# 0755, leave it alone.
$_mode = $mode;
} else {
# "0755" -> convert to 0755
$_mode = oct($mode);
}
if ($dh{VERBOSE}) {
verbose_print(sprintf('chmod %#o -- %s', $_mode, escape_shell(@paths)));
verbose_print(sprintf('chown 0:0 -- %s', escape_shell(@paths))) if $use_root;
}
return if $dh{NO_ACT};
for my $path (@paths) {
chmod($_mode, $path) or error(sprintf('chmod(%#o, %s): %s', $mode, $path, $!));
if ($use_root) {
chown(0, 0, $path) or error("chown(0, 0, $path): $!");
}
}
}
# Run a command that may have a huge number of arguments, like xargs does.
# Pass in a reference to an array containing the arguments, and then other
# parameters that are the command and any parameters that should be passed to
# it each time.
sub xargs {
my ($args, @static_args) = @_;
# The kernel can accept command lines up to 20k worth of characters.
my $command_max=20000; # LINUX SPECIFIC!!
# (And obsolete; it's bigger now.)
# I could use POSIX::ARG_MAX, but that would be slow.
# Figure out length of static portion of command.
my $static_length=0;
my $subst_index = -1;
for my $i (0..$#static_args) {
my $arg = $static_args[$i];
if ($arg eq XARGS_INSERT_PARAMS_HERE) {
error("Only one insertion place supported in xargs, got command: @static_args") if $subst_index > -1;
$subst_index = $i;
next;
}
$static_length+=length($arg)+1;
}
my @collect=();
my $length=$static_length;
foreach (@$args) {
if (length($_) + 1 + $static_length > $command_max) {
error("This command is greater than the maximum command size allowed by the kernel, and cannot be split up further. What on earth are you doing? \"@_ $_\"");
}
$length+=length($_) + 1;
if ($length < $command_max) {
push @collect, $_;
}
else {
if ($#collect > -1) {
if ($subst_index < 0) {
doit(@static_args, @collect);
} else {
my @cmd = @static_args;
splice(@cmd, $subst_index, 1, @collect);
doit(@cmd);
}
}
@collect=($_);
$length=$static_length + length($_) + 1;
}
}
if ($#collect > -1) {
if ($subst_index < 0) {
doit(@static_args, @collect);
} else {
my @cmd = @static_args;
splice(@cmd, $subst_index, 1, @collect);
doit(@cmd);
}
}
}
# Print something if the verbose flag is on.
sub verbose_print {
my $message=shift;
if ($dh{VERBOSE}) {
print "\t$message\n";
}
}
# Print something unless the quiet flag is on
sub nonquiet_print {
my $message=shift;
if (!$dh{QUIET}) {
print "\t$message\n";
}
}
{
my $_use_color;
sub _color {
my ($msg, $color) = @_;
if (not defined($_use_color)) {
# This part is basically Dpkg::ErrorHandling::setup_color over again
# with some tweaks.
# (but the module uses Dpkg + Dpkg::Gettext, so it is very expensive
# to load)
my $mode = $ENV{'DH_COLORS'} // $ENV{'DPKG_COLORS'};
# Support NO_COLOR (https://no-color.org/)
$mode //= exists($ENV{'NO_COLOR'}) ? 'never' : 'auto';
if ($mode eq 'auto') {
$_use_color = 1 if -t *STDOUT or -t *STDERR;
} elsif ($mode eq 'always') {
$_use_color = 1;
} else {
$_use_color = 0;
}
eval {
require Term::ANSIColor if $_use_color;
};
if ($@) {
# In case of errors, skip colors.
$_use_color = 0;
}
}
if ($_use_color) {
local $ENV{'NO_COLOR'} = undef;
$msg = Term::ANSIColor::colored($msg, $color);
}
return $msg;
}
# Output an error message and die (can be caught).
sub error {
my ($message) = @_;
# ensure the error code is well defined.
$! = 255;
die(_color(basename($0), 'bold') . ': ' . _color('error', 'bold red') . ": $message\n");
}
# Output a warning.
sub warning {
my ($message) = @_;
$message //= '';
print STDERR _color(basename($0), 'bold') . ': ' . _color('warning', 'bold yellow') . ": $message\n";
}
}
# Returns the basename of the argument passed to it.
sub basename {
my $fn=shift;
$fn=~s/\/$//g; # ignore trailing slashes
$fn=~s:^.*/(.*?)$:$1:;
return $fn;
}
# Returns the directory name of the argument passed to it.
sub dirname {
my $fn=shift;
$fn=~s/\/$//g; # ignore trailing slashes
$fn=~s:^(.*)/.*?$:$1:;
return $fn;
}
# Pass in a number, will return true iff the current compatibility level
# is less than or equal to that number.
my $compat_from_bd;
{
my $warned_compat = $ENV{DH_INTERNAL_TESTSUITE_SILENT_WARNINGS} ? 1 : 0;
my $c;
# Used mainly for testing
sub resetcompat {
undef $c;
undef $compat_from_bd;
}
sub compat {
my $num=shift;
my $nowarn=shift;
getpackages() if not defined($compat_from_bd);
if (! defined $c) {
$c=1;
if (-e 'debian/compat') {
open(my $compat_in, '<', "debian/compat") || error "debian/compat: $!";
my $l=<$compat_in>;
close($compat_in);
if (! defined $l || ! length $l) {
error("debian/compat must contain a positive number (found an empty first line)");
}
else {
chomp $l;
my $new_compat = $l;
$new_compat =~ s/^\s*+//;
$new_compat =~ s/\s*+$//;
if ($new_compat !~ m/^\d+$/) {
error("debian/compat must contain a positive number (found: \"${new_compat}\")");
}
if (defined($compat_from_bd) and $compat_from_bd != -1) {
warning("Please specify the debhelper compat level exactly once.");
warning(" * debian/compat requests compat ${new_compat}.");
warning(" * debian/control requests compat ${compat_from_bd} via \"debhelper-compat (= ${compat_from_bd})\"");
warning();
warning("Hint: If you just added a build-dependency on debhelper-compat, then please remember to remove debian/compat");
warning();
error("debhelper compat level specified both in debian/compat and via build-dependency on debhelper-compat");
}
$c = $new_compat;
}
} elsif ($compat_from_bd != -1) {
$c = $compat_from_bd;
} elsif (not $nowarn) {
error("Please specify the compatibility level in debian/compat");
}
if (defined $ENV{DH_COMPAT}) {
$c=$ENV{DH_COMPAT};
}
}
if (not $nowarn) {
if ($c < MIN_COMPAT_LEVEL) {
error("Compatibility levels before ${\MIN_COMPAT_LEVEL} are no longer supported (level $c requested)");
}
if ($c < LOWEST_NON_DEPRECATED_COMPAT_LEVEL && ! $warned_compat) {
warning("Compatibility levels before ${\LOWEST_NON_DEPRECATED_COMPAT_LEVEL} are deprecated (level $c in use)");
$warned_compat=1;
}
if ($c > MAX_COMPAT_LEVEL) {
error("Sorry, but ${\MAX_COMPAT_LEVEL} is the highest compatibility level supported by this debhelper.");
}
}
return ($c <= $num);
}
}
# Pass it a name of a binary package, it returns the name of the tmp dir to
# use, for that package.
sub tmpdir {
my $package=shift;
if ($dh{TMPDIR}) {
return $dh{TMPDIR};
}
else {
return "debian/$package";
}
}
# Pass it a name of a binary package, it returns the name of the staging dir to
# use, for that package. (Usually debian/tmp)
sub default_sourcedir {
my ($package) = @_;
return 'debian/tmp';
}
# Pass this the name of a binary package, and the name of the file wanted
# for the package, and it will return the actual existing filename to use.
#
# It tries several filenames:
# * debian/package.filename.hostarch
# * debian/package.filename.hostos
# * debian/package.filename
# * debian/filename (if the package is the main package)
# If --name was specified then the files
# must have the name after the package name:
# * debian/package.name.filename.hostarch
# * debian/package.name.filename.hostos
# * debian/package.name.filename
# * debian/name.filename (if the package is the main package)
{
my %_check_expensive;
sub pkgfile {
my ($package, $filename) = @_;
my (@try, $check_expensive);
if (not exists($_check_expensive{$filename})) {
my @f = grep {
!/\.debhelper$/
} bsd_glob("debian/*.$filename.*", GLOB_CSH & ~(GLOB_NOMAGIC|GLOB_TILDE));
if (not @f) {
$check_expensive = 0;
} else {
$check_expensive = 1;
}
$_check_expensive{$filename} = $check_expensive;
} else {
$check_expensive = $_check_expensive{$filename};
}
# Rewrite $filename after the check_expensive globbing above
# as $dh{NAME} is used as a prefix (so the glob above will
# cover it).
#
# In practise, it should not matter as NAME is ether set
# globally or not. But if someone is being "clever" then the
# cache is reusable and for the general/normal case, it has no
# adverse effects.
if (defined $dh{NAME}) {
$filename="$dh{NAME}.$filename";
}
if (ref($package) eq 'ARRAY') {
# !!NOT A PART OF THE PUBLIC API!!
# Bulk test used by dh to speed up the can_skip check. It
# is NOT useful for finding the most precise pkgfile.
push(@try, "debian/$filename");
for my $pkg (@{$package}) {
push(@try, "debian/${pkg}.${filename}");
if ($check_expensive) {
my $cross_type = uc(package_cross_type($pkg));
push(@try,
"debian/${pkg}.${filename}.".dpkg_architecture_value("DEB_${cross_type}_ARCH"),
"debian/${pkg}.${filename}.".dpkg_architecture_value("DEB_${cross_type}_ARCH_OS"),
);
}
}
} else {
# Avoid checking for hostarch+hostos unless we have reason
# to believe that they exist.
if ($check_expensive) {
my $cross_type = uc(package_cross_type($package));
push(@try,
"debian/${package}.${filename}.".dpkg_architecture_value("DEB_${cross_type}_ARCH"),
"debian/${package}.${filename}.".dpkg_architecture_value("DEB_${cross_type}_ARCH_OS"),
);
}
push(@try, "debian/$package.$filename");
if ($package eq $dh{MAINPACKAGE}) {
push @try, "debian/$filename";
}
}
foreach my $file (@try) {
return $file if -f $file;
}
return "";
}
# Used by dh to ditch some caches that makes assumptions about
# dh_-tools can do, which does not hold for override targets.
sub dh_clear_unsafe_cache {
%_check_expensive = ();
}
}
# Pass it a name of a binary package, it returns the name to prefix to files
# in debian/ for this package.
sub pkgext {
my ($package) = @_;
return "$package.";
}
# Pass it the name of a binary package, it returns the name to install
# files by in eg, etc. Normally this is the same, but --name can override
# it.
sub pkgfilename {
my $package=shift;
if (defined $dh{NAME}) {
return $dh{NAME};
}
return $package;
}
# Returns 1 if the package is a native debian package, null otherwise.
# As a side effect, sets $dh{VERSION} to the version of this package.
{
# Caches return code so it only needs to run dpkg-parsechangelog once.
my (%isnative_cache, %pkg_version);
sub isnative {
my ($package) = @_;
my $cache_key = $package;
if (exists($isnative_cache{$cache_key})) {
$dh{VERSION} = $pkg_version{$cache_key};
return $isnative_cache{$cache_key};
}
# Make sure we look at the correct changelog.
my $isnative_changelog = pkgfile($package,"changelog");
if (! $isnative_changelog) {
$isnative_changelog = "debian/changelog";
$cache_key = '_source';
# check if we looked up the default changelog
if (exists($isnative_cache{$cache_key})) {
$dh{VERSION} = $pkg_version{$cache_key};
return $isnative_cache{$cache_key};
}
}
if (not %isnative_cache) {
require Dpkg::Changelog::Parse;
}
my $res = Dpkg::Changelog::Parse::changelog_parse(
file => $isnative_changelog,
compression => 0,
);
if (not defined($res)) {
error("No changelog entries for $package!? (changelog file: ${isnative_changelog})");
}
my $version = $res->{'Version'};
# Do we have a valid version?
if (not defined($version) or not $version->is_valid) {
error("changelog parse failure; invalid or missing version");
}
# Get and cache the package version.
$dh{VERSION} = $pkg_version{$cache_key} = $version->as_string;
# Is this a native Debian package?
if (index($dh{VERSION}, '-') > -1) {
return $isnative_cache{$cache_key} = 0;
}
else {
return $isnative_cache{$cache_key} = 1;
}
}
}
sub _tool_version {
return $DH_TOOL_VERSION if defined($DH_TOOL_VERSION);
if (defined($main::VERSION)) {
$DH_TOOL_VERSION = $main::VERSION;
}
if (defined($DH_TOOL_VERSION) and $DH_TOOL_VERSION eq DH_BUILTIN_VERSION) {
my $version = "UNRELEASED-${\MAX_COMPAT_LEVEL}";
eval {
require Debian::Debhelper::Dh_Version;
$version = $Debian::Debhelper::Dh_Version::version;
};
$DH_TOOL_VERSION = $version;
} else {
$DH_TOOL_VERSION //= 'UNDECLARED';
}
return $DH_TOOL_VERSION;
}
# Automatically add a shell script snippet to a debian script.
# Only works if the script has #DEBHELPER# in it.
#
# Parameters:
# 1: package
# 2: script to add to
# 3: filename of snippet
# 4: either text: shell-quoted sed to run on the snippet. Ie, 's/#PACKAGE#/$PACKAGE/'
# or a sub to run on each line of the snippet. Ie sub { s/#PACKAGE#/$PACKAGE/ }
# or a hashref with keys being variables and values being their replacement. Ie. { PACKAGE => $PACKAGE }
# 5: Internal usage only
sub autoscript {
my ($package, $script, $filename, $sed, $extra_options) = @_;
my $tool_version = _tool_version();
# This is the file we will modify.
my $outfile="debian/".pkgext($package)."$script.debhelper";
if ($extra_options && exists($extra_options->{'snippet-order'})) {
my $order = $extra_options->{'snippet-order'};
error("Internal error - snippet order set to unknown value: \"${order}\"")
if $order ne 'service';
$outfile = generated_file($package, "${script}.${order}");
}
# Figure out what shell script snippet to use.
my $infile;
if (defined($ENV{DH_AUTOSCRIPTDIR}) &&
-e "$ENV{DH_AUTOSCRIPTDIR}/$filename") {
$infile="$ENV{DH_AUTOSCRIPTDIR}/$filename";
}
else {
if (-e "$prefix/share/debhelper/autoscripts/$filename") {
$infile="$prefix/share/debhelper/autoscripts/$filename";
}
else {
error("$prefix/share/debhelper/autoscripts/$filename does not exist");
}
}
if (-e $outfile && ($script eq 'postrm' || $script eq 'prerm')
&& !compat(5)) {
# Add fragments to top so they run in reverse order when removing.
if (not defined($sed) or ref($sed)) {
verbose_print("[META] Prepend autosnippet \"$filename\" to $script [${outfile}.new]");
if (not $dh{NO_ACT}) {
open(my $out_fd, '>', "${outfile}.new") or error("open(${outfile}.new): $!");
print {$out_fd} '# Automatically added by ' . basename($0) . "/${tool_version}\n";
autoscript_sed($sed, $infile, undef, $out_fd);
print {$out_fd} "# End automatically added section\n";
open(my $in_fd, '<', $outfile) or error("open($outfile): $!");
while (my $line = <$in_fd>) {
print {$out_fd} $line;
}
close($in_fd);
close($out_fd) or error("close(${outfile}.new): $!");
}
} else {
complex_doit("echo \"# Automatically added by ".basename($0)."/${tool_version}\"> $outfile.new");
autoscript_sed($sed, $infile, "$outfile.new");
complex_doit("echo '# End automatically added section' >> $outfile.new");
complex_doit("cat $outfile >> $outfile.new");
}
rename_path("${outfile}.new", $outfile);
} elsif (not defined($sed) or ref($sed)) {
verbose_print("[META] Append autosnippet \"$filename\" to $script [${outfile}]");
if (not $dh{NO_ACT}) {
open(my $out_fd, '>>', $outfile) or error("open(${outfile}): $!");
print {$out_fd} '# Automatically added by ' . basename($0) . "/${tool_version}\n";
autoscript_sed($sed, $infile, undef, $out_fd);
print {$out_fd} "# End automatically added section\n";
close($out_fd) or error("close(${outfile}): $!");
}
} else {
complex_doit("echo \"# Automatically added by ".basename($0)."/${tool_version}\">> $outfile");
autoscript_sed($sed, $infile, $outfile);
complex_doit("echo '# End automatically added section' >> $outfile");
}
}
sub autoscript_sed {
my ($sed, $infile, $outfile, $out_fd) = @_;
if (not defined($sed) or ref($sed)) {
my $out = $out_fd;
open(my $in, '<', $infile) or error("open $infile failed: $!");
if (not defined($out_fd)) {
open($out, '>>', $outfile) or error("open($outfile): $!");
}
if (not defined($sed) or ref($sed) eq 'CODE') {
while (<$in>) { $sed->() if $sed; print {$out} $_; }
} else {
my $rstr = sprintf('#(%s)#', join('|', reverse(sort(keys(%$sed)))));
my $regex = qr/$rstr/;
while (my $line = <$in>) {
$line =~ s/$regex/$sed->{$1}/eg;
print {$out} $line;
}
}
if (not defined($out_fd)) {
close($out) or error("close $outfile failed: $!");
}
close($in) or error("close $infile failed: $!");
}
else {
error("Internal error - passed open handle for legacy method") if defined($out_fd);
complex_doit("sed \"$sed\" $infile >> $outfile");
}
}
# Adds a trigger to the package
{
my %VALID_TRIGGER_TYPES = map { $_ => 1 } qw(
interest interest-await interest-noawait
activate activate-await activate-noawait
);
sub autotrigger {
my ($package, $trigger_type, $trigger_target) = @_;
my ($triggers_file, $ifd, $tool_version);
if (not exists($VALID_TRIGGER_TYPES{$trigger_type})) {
require Carp;
Carp::confess("Invalid/unknown trigger ${trigger_type}");
}
return if $dh{NO_ACT};
$tool_version = _tool_version();
$triggers_file = generated_file($package, 'triggers');
if ( -f $triggers_file ) {
open($ifd, '<', $triggers_file)
or error("open $triggers_file failed $!");
} else {
open($ifd, '<', '/dev/null')
or error("open /dev/null failed $!");
}
open(my $ofd, '>', "${triggers_file}.new")
or error("open ${triggers_file}.new failed: $!");
while (my $line = <$ifd>) {
next if $line =~ m{\A \Q${trigger_type}\E \s+
\Q${trigger_target}\E (?:\s|\Z)
}x;
print {$ofd} $line;
}
print {$ofd} '# Triggers added by ' . basename($0) . "/${tool_version}\n";
print {$ofd} "${trigger_type} ${trigger_target}\n";
close($ofd) or error("closing ${triggers_file}.new failed: $!");
close($ifd);
rename_path("${triggers_file}.new", $triggers_file);
}
}
# Generated files are cleaned by dh_clean AND dh_prep
# - Package can be set to "_source" to generate a file relevant
# for the source package (the meson build does this atm.).
# Files for "_source" are only cleaned by dh_clean.
sub generated_file {
my ($package, $filename, $mkdirs) = @_;
my $dir = "debian/.debhelper/generated/${package}";
my $path = "${dir}/${filename}";
$mkdirs //= 1;
install_dir($dir) if $mkdirs;
return $path;
}
# Removes a whole substvar line.
sub delsubstvar {
my $package=shift;
my $substvar=shift;
my $ext=pkgext($package);
my $substvarfile="debian/${ext}substvars";
if (-e $substvarfile) {
complex_doit("grep -a -s -v '^${substvar}=' $substvarfile > $substvarfile.new || true");
rename_path("${substvarfile}.new", $substvarfile);
}
}
# Adds a dependency on some package to the specified
# substvar in a package's substvar's file.
sub addsubstvar {
my $package=shift;
my $substvar=shift;
my $deppackage=shift;
my $verinfo=shift;
my $remove=shift;
my $ext=pkgext($package);
my $substvarfile="debian/${ext}substvars";
my $str=$deppackage;
$str.=" ($verinfo)" if defined $verinfo && length $verinfo;
# Figure out what the line will look like, based on what's there
# now, and what we're to add or remove.
my $line="";
if (-e $substvarfile) {
my %items;
open(my $in, '<', $substvarfile) || error "read $substvarfile: $!";
while (<$in>) {
chomp;
if (/^\Q$substvar\E=(.*)/) {
%items = map { $_ => 1} split(", ", $1);
last;
}
}
close($in);
if (! $remove) {
$items{$str}=1;
}
else {
delete $items{$str};
}
$line=join(", ", sort keys %items);
}
elsif (! $remove) {
$line=$str;
}
if (length $line) {
complex_doit("(grep -a -s -v ${substvar} $substvarfile; echo ".escape_shell("${substvar}=$line").") > $substvarfile.new");
rename_path("$substvarfile.new", $substvarfile);
}
else {
delsubstvar($package,$substvar);
}
}
sub _glob_expand_error_default_msg {
my ($pattern, $dir_ref) = @_;
my $dir_list = join(', ', map { escape_shell($_) } @{$dir_ref});
return "Cannot find (any matches for) \"${pattern}\" (tried in $dir_list)";
}
sub glob_expand_error_handler_reject {
my $msg = _glob_expand_error_default_msg(@_);
error("$msg\n");
return;
}
sub glob_expand_error_handler_warn_and_discard {
my $msg = _glob_expand_error_default_msg(@_);
warning("$msg\n");
return;
}
# Emulates the "old" glob mechanism; not recommended for new code as
# it permits some globs expand to nothing with only a warning.
sub glob_expand_error_handler_reject_nomagic_warn_discard {
my ($pattern, $dir_ref) = @_;
for my $dir (@{$dir_ref}) {
my $full_pattern = "$dir/$pattern";
my @matches = bsd_glob($full_pattern, GLOB_CSH & ~(GLOB_TILDE));
if (@matches) {
goto \&glob_expand_error_handler_reject;
}
}
goto \&glob_expand_error_handler_warn_and_discard;
}
sub glob_expand_error_handler_silently_ignore {
return;
}
sub glob_expand {
my ($dir_ref, $error_handler, @patterns) = @_;
my @dirs = @{$dir_ref};
my @result;
for my $pattern (@patterns) {
my @m;
for my $dir (@dirs) {
my $full_pattern = "$dir/$pattern";
@m = bsd_glob($full_pattern, GLOB_CSH & ~(GLOB_NOMAGIC|GLOB_TILDE));
last if @m;
# Handle "foo{bar}" pattern (#888251)
if (-l $full_pattern or -e _) {
push(@m, $full_pattern);
last;
}
}
if (not @m) {
$error_handler //= \&glob_expand_error_handler_reject;
$error_handler->($pattern, $dir_ref);
}
push(@result, @m);
}
return @result;
}
my %BUILT_IN_SUBST = (
'Space' => ' ',
'Dollar' => '$',
'Newline' => "\n",
'Tab' => "\b",
);
sub _variable_substitution {
my ($text, $loc) = @_;
return $text if index($text, '$') < 0;
my $pos = -1;
my $subst_count = 0;
my $expansion_count = 0;
my $current_size = length($text);
my $expansion_size_limit = 3 * $current_size;
1 while ($text =~ s<
\$\{([A-Za-z0-9][-_:0-9A-Za-z]*)\} # Match ${something} and replace it
>[
my $match = $1;
my $new_pos = pos()//-1;
my $value;
if ($pos == $new_pos) {
# Safe-guard in case we ever implement recursive expansion
error("Error substituting in ${loc} (at position $pos); recursion limit while expanding \${${match}")
if (++$subst_count >= 20);
} else {
$subst_count = 0;
$pos = $new_pos;
if (++$expansion_count >= 50) {
error("Error substituting in ${loc}; substitution limit of ${expansion_count} reached");
}
}
if (exists($BUILT_IN_SUBST{$match})) {
$value = $BUILT_IN_SUBST{$match};
} elsif ($match =~ m/^DEB_(?:BUILD|HOST|TARGET)_/) {
$value = dpkg_architecture_value($match) //
error(qq{Cannot expand "\${${match}}\" in ${loc} as it is not a known dpkg-architecture value});
} elsif ($match =~ m/^env:(.+)/) {
my $env_var = $1;
$value = $ENV{$env_var} //
error(qq{Cannot expand "\${${match}}" in ${loc} as the ENV variable "${env_var}" is unset});
}
error("Cannot resolve variable \${$match} in ${loc}")
if not defined($value);
# We do not support recursive expansion.
$value =~ s/\$/\$\{\}/;
$current_size += length($value) - length($match) - 3;
if ($current_size > 4096 and $current_size > $expansion_size_limit) {
error("Refusing to expand \${${match}} in ${loc} - the original input seems to grow beyond reasonable'
. ' limits!");
}
$value;
]gex);
$text =~ s/\$\{\}/\$/g;
return $text;
}
# Reads in the specified file, one line at a time. splits on words,
# and returns an array of arrays of the contents.
# If a value is passed in as the second parameter, then glob
# expansion is done in the directory specified by the parameter ("." is
# frequently a good choice).
# In compat 13+, it will do variable expansion (after splitting the lines
# into words)
sub filedoublearray {
my ($file, $globdir, $error_handler) = @_;
# executable config files are a v9 thing.
my $x=! compat(8) && -x $file;
my $expand_patterns = compat(12) ? 0 : 1;
my $source;
if ($x) {
require Cwd;
my $cmd=Cwd::abs_path($file);
$ENV{"DH_CONFIG_ACT_ON_PACKAGES"} = join(",", @{$dh{"DOPACKAGES"}});
open(DH_FARRAY_IN, '-|', $cmd) || error("cannot run $file: $!");
delete $ENV{"DH_CONFIG_ACT_ON_PACKAGES"};
$source = "output of ./${file}";
}
else {
open (DH_FARRAY_IN, '<', $file) || error("cannot read $file: $!");
$source = $file;
}
my @ret;
while (<DH_FARRAY_IN>) {
chomp;
if ($x) {
if (m/^\s++$/) {
error("Executable config file $file produced a non-empty whitespace-only line");
}
} else {
s/^\s++//;
next if /^#/;
s/\s++$//;
}
# We always ignore/permit empty lines
next if $_ eq '';
my @line;
my $source_ref = "${source} (line $.)";
if (defined($globdir) && ! $x) {
if (ref($globdir)) {
my @patterns = split;
if ($expand_patterns) {
@patterns = map {_variable_substitution($_, $source_ref)} @patterns;
}
push(@line, glob_expand($globdir, $error_handler, @patterns));
} else {
# Legacy call - Silently discards globs that match nothing.
#
# The tricky bit is that the glob expansion is done
# as if we were in the specified directory, so the
# filenames that come out are relative to it.
foreach (map { glob "$globdir/$_" } split) {
s#^$globdir/##;
if ($expand_patterns) {
$_ = _variable_substitution($_, $source_ref);
}
push @line, $_;
}
}
}
else {
@line = split;
if ($expand_patterns) {
@line = map {_variable_substitution($_, $source_ref)} @line;
}
}
push @ret, [@line];
}
if (!close(DH_FARRAY_IN)) {
if ($x) {
my ($err, $proc_err) = ($!, $?);
error("Error closing fd/process for $file: $err") if $err;
# The interpreter did not like the file for some reason.
# Lets check if the maintainer intended it to be
# executable.
if (not is_so_or_exec_elf_file($file) and not _has_shbang_line($file)) {
warning("$file is marked executable but does not appear to an executable config.");
warning();
warning("If $file is intended to be an executable config file, please ensure it can");
warning("be run as a stand-alone script/program (e.g. \"./${file}\")");
warning("Otherwise, please remove the executable bit from the file (e.g. chmod -x \"${file}\")");
warning();
warning('Please see "Executable debhelper config files" in debhelper(7) for more information.');
warning();
}
$? = $proc_err;
error_exitcode("$file (executable config)");
} else {
error("problem reading $file: $!");
}
}
return @ret;
}
# Reads in the specified file, one word at a time, and returns an array of
# the result. Can do globbing as does filedoublearray.
sub filearray {
return map { @$_ } filedoublearray(@_);
}
# Passed a filename, returns true if -X says that file should be excluded.
sub excludefile {
my $filename = shift;
foreach my $f (@{$dh{EXCLUDE}}) {
return 1 if $filename =~ /\Q$f\E/;
}
return 0;
}
{
my %dpkg_arch_output;
sub dpkg_architecture_value {
my $var = shift;
if (exists($ENV{$var})) {
my $value = $ENV{$var};
return $value if $value ne q{};
warning("ENV[$var] is set to the empty string. It has been ignored to avoid bugs like #862842");
delete($ENV{$var});
}
if (! exists($dpkg_arch_output{$var})) {
# Return here if we already consulted dpkg-architecture
# (saves a fork+exec on unknown variables)
return if %dpkg_arch_output;
open(my $fd, '-|', 'dpkg-architecture')
or error("dpkg-architecture failed");
while (my $line = <$fd>) {
chomp($line);
my ($k, $v) = split(/=/, $line, 2);
$dpkg_arch_output{$k} = $v;
}
close($fd);
}
return $dpkg_arch_output{$var};
}
}
# Confusing name for hostarch
sub buildarch {
deprecated_functionality('buildarch() is deprecated and replaced by hostarch()', 12);
goto \&hostarch;
}
# Returns the architecture that will run binaries produced (DEB_HOST_ARCH)
sub hostarch {
dpkg_architecture_value('DEB_HOST_ARCH');
}
# Returns a truth value if this seems to be a cross-compile
sub is_cross_compiling {
return dpkg_architecture_value("DEB_BUILD_GNU_TYPE")
ne dpkg_architecture_value("DEB_HOST_GNU_TYPE");
}
# Passed an arch and a list of arches to match against, returns true if matched
{
my %knownsame;
sub samearch {
my $arch=shift;
my @archlist=split(/\s+/,shift);
foreach my $a (@archlist) {
if (exists $knownsame{$arch}{$a}) {
return 1 if $knownsame{$arch}{$a};
next;
}
require Dpkg::Arch;
if (Dpkg::Arch::debarch_is($arch, $a)) {
return $knownsame{$arch}{$a}=1;
}
else {
$knownsame{$arch}{$a}=0;
}
}
return 0;
}
}
# Returns a list of packages in the control file.
# Pass "arch" or "indep" to specify arch-dependent (that will be built
# for the system's arch) or independent. If nothing is specified,
# returns all packages. Also, "both" returns the union of "arch" and "indep"
# packages.
#
# As a side effect, populates %package_arches and %package_types
# with the types of all packages (not only those returned).
my (%package_types, %package_arches, %package_multiarches, %packages_by_type,
%package_sections, $sourcepackage, %package_cross_type, %dh_bd_sequences);
# Resets the arrays; used mostly for testing
sub resetpackages {
undef $sourcepackage;
%package_types = %package_arches = %package_multiarches =
%packages_by_type = %package_sections = %package_cross_type = ();
%dh_bd_sequences = ();
}
# Returns source package name
sub sourcepackage {
getpackages() if not defined($sourcepackage);
return $sourcepackage;
}
sub getpackages {
my ($type) = @_;
error("getpackages: First argument must be one of \"arch\", \"indep\", or \"both\"")
if defined($type) and $type ne 'both' and $type ne 'indep' and $type ne 'arch';
$type //= 'all-listed-in-control-file';
if (not %packages_by_type) {
_parse_debian_control();
}
return @{$packages_by_type{$type}};
}
sub _parse_debian_control {
my $package="";
my $arch="";
my $section="";
my $valid_pkg_re = qr{^${PKGNAME_REGEX}$}o;
my ($package_type, $multiarch, %seen, @profiles, $source_section,
$included_in_build_profile, $cross_type, $cross_target_arch,
%bd_fields, $bd_field_value, %seen_fields, $fd);
if (exists $ENV{'DEB_BUILD_PROFILES'}) {
@profiles=split /\s+/, $ENV{'DEB_BUILD_PROFILES'};
}
if (not open($fd, '<', 'debian/control')) {
error("\"debian/control\" not found. Are you sure you are in the correct directory?")
if $! == ENOENT;
error("cannot read debian/control: $!\n");
};
$packages_by_type{$_} = [] for qw(both indep arch all-listed-in-control-file);
while (<$fd>) {
chomp;
s/\s+$//;
next if m/^\s*+\#/;
if (/^\s/) {
if (not %seen_fields) {
error("Continuation line seen before first stanza in debian/control (line $.)");
}
# Continuation line
push(@{$bd_field_value}, $_) if $bd_field_value;
} elsif (not $_ and not %seen_fields) {
# Ignore empty lines before first stanza
next;
} elsif ($_) {
my ($field_name, $value);
if (m/^($DEB822_FIELD_REGEX):\s*(.*)/o) {
($field_name, $value) = (lc($1), $2);
if (exists($seen_fields{$field_name})) {
my $first_time = $seen_fields{$field_name};
error("${field_name}-field appears twice in the same stanza of debian/control. " .
"First time on line $first_time, second time: $.");
}
$seen_fields{$field_name} = $.;
$bd_field_value = undef;
} else {
# Invalid file
error("Parse error in debian/control, line $., read: $_");
}
if ($field_name eq 'source') {
$sourcepackage = $value;
if ($sourcepackage !~ $valid_pkg_re) {
error('Source-field must be a valid package name, ' .
"got: \"${sourcepackage}\", should match \"${valid_pkg_re}\"");
}
next;
} elsif ($field_name eq 'section') {
$source_section = $value;
next;
} elsif ($field_name =~ /^(?:build-depends(?:-arch|-indep)?)$/) {
$bd_field_value = [$value];
$bd_fields{$field_name} = $bd_field_value;
}
}
last if not $_ or eof;
}
error("could not find Source: line in control file.") if not defined($sourcepackage);
if (%bd_fields) {
my ($dh_compat_bd, $final_level);
my %field2addon_type = (
'build-depends' => 'both',
'build-depends-arch' => 'arch',
'build-depends-indep' => 'indep',
);
for my $field (sort(keys(%bd_fields))) {
my $value = join(' ', @{$bd_fields{$field}});
$value =~ s/^\s*//;
$value =~ s/\s*(?:,\s*)?$//;
for my $dep (split(/\s*,\s*/, $value)) {
if ($dep =~ m/^debhelper-compat\s*[(]\s*=\s*(${PKGVERSION_REGEX})\s*[)]$/) {
my $version = $1;
if ($version =~m/^(\d+)\D.*$/) {
my $guessed_compat = $1;
warning("Please use the compat level as the exact version rather than the full version.");
warning(" Perhaps you meant: debhelper-compat (= ${guessed_compat})");
if ($field ne 'build-depends') {
warning(" * Also, please move the declaration to Build-Depends (it was found in ${field})");
}
error("Invalid compat level ${version}, derived from relation: ${dep}");
}
$final_level = $version;
error("Duplicate debhelper-compat build-dependency: ${dh_compat_bd} vs. ${dep}") if $dh_compat_bd;
error("The debhelper-compat build-dependency must be in the Build-Depends field (not $field)")
if $field ne 'build-depends';
$dh_compat_bd = $dep;
} elsif ($dep =~ m/^debhelper-compat\s*(?:\S.*)?$/) {
my $clevel = "${\MAX_COMPAT_LEVEL}";
eval {
require Debian::Debhelper::Dh_Version;
$clevel = $Debian::Debhelper::Dh_Version::version;
};
$clevel =~ s/^\d+\K\D.*$//;
warning("Found invalid debhelper-compat relation: ${dep}");
warning(" * Please format the relation as (example): debhelper-compat (= ${clevel})");
warning(" * Note that alternatives, architecture restrictions, build-profiles etc. are not supported.");
if ($field ne 'build-depends') {
warning(" * Also, please move the declaration to Build-Depends (it was found in ${field})");
}
warning(" * If this is not possible, then please remove the debhelper-compat relation and insert the");
warning(" compat level into the file debian/compat. (E.g. \"echo ${clevel} > debian/compat\")");
error("Could not parse desired debhelper compat level from relation: $dep");
}
# Build-Depends on dh-sequence-<foo> OR dh-sequence-<foo> (<op> <version>)
if ($PARSE_DH_SEQUENCE_INFO and $dep =~ m/^dh-sequence-(${PKGNAME_REGEX})\s*(?:[(]\s*(?:[<>]?=|<<|>>)\s*(?:${PKGVERSION_REGEX})\s*[)])?(\s*[^\|]+[]>]\s*)?$/) {
my $sequence = $1;
my $has_profile_or_arch_restriction = $2 ? 1 : 0;
my $addon_type = $field2addon_type{$field};
if (not defined($field)) {
warning("Cannot map ${field} to an add-on type (like \"both\", \"indep\" or \"arch\")");
error("Internal error: Cannot satisfy dh sequence add-on request for sequence ${sequence} via ${field}.");
}
if (defined($dh_bd_sequences{$sequence})) {
error("Saw $dep multiple times (last time in $field). However dh only support that build-"
. 'dependency at most once across all Build-Depends(-Arch|-Indep) fields');
}
if ($has_profile_or_arch_restriction) {
require Dpkg::Deps;
my $dpkg_dep = Dpkg::Deps::deps_parse($dep, build_profiles => \@profiles, build_dep => 1,
reduce_restrictions => 1);
# If dpkg reduces it to nothing, then it was not relevant for us after all
next if not $dpkg_dep;
}
$dh_bd_sequences{$sequence} = $addon_type;
}
}
}
$compat_from_bd = $final_level // -1;
} else {
$compat_from_bd = -1;
}
%seen_fields = ();
while (<$fd>) {
chomp;
s/\s+$//;
if (m/^\#/) {
# Skip unless EOF for the special case where the last line
# is a comment line directly after the last stanza. In
# that case we need to "commit" the last stanza as well or
# we end up omitting the last package.
next if not eof;
$_ = '';
}
if (/^\s/) {
# Continuation line
if (not %seen_fields) {
error("Continuation line seen outside stanza in debian/control (line $.)");
}
} elsif (not $_ and not %seen_fields) {
# Ignore empty lines before first stanza
next;
} elsif ($_) {
my ($field_name, $value);
if (m/^($DEB822_FIELD_REGEX):\s*(.*)/o) {
($field_name, $value) = (lc($1), $2);
if (exists($seen_fields{$field_name})) {
my $first_time = $seen_fields{$field_name};
error("${field_name}-field appears twice in the same stanza of debian/control. " .
"First time on line $first_time, second time: $.");
}
$seen_fields{$field_name} = $.;
$bd_field_value = undef;
} else {
# Invalid file
error("Parse error in debian/control, line $., read: $_");
}
if ($field_name eq 'package') {
$package = $value;
# Detect duplicate package names in the same control file.
if (! $seen{$package}) {
$seen{$package}=1;
} else {
error("debian/control has a duplicate entry for $package");
}
if ($package !~ $valid_pkg_re) {
error('Package-field must be a valid package name, ' .
"got: \"${package}\", should match \"${valid_pkg_re}\"");
}
$included_in_build_profile=1;
} elsif ($field_name eq 'section') {
$section = $value;
} elsif ($field_name eq 'architecture') {
$arch = $value;
} elsif ($field_name =~ m/^(?:x[bc]*-)?package-type$/) {
if (defined($package_type)) {
my $help = "(issue seen prior \"Package\"-field)";
$help = "for package ${package}" if $package;
error("Multiple definitions of (X-)Package-Type in line $. ${help}");
}
$package_type = $value;
} elsif ($field_name eq 'multi-arch') {
$multiarch = $value;
} elsif ($field_name eq 'x-dh-build-for-type') {
$cross_type = $value;
if ($cross_type ne 'host' and $cross_type ne 'target') {
error("Unknown value of X-DH-Build-For-Type \"$cross_type\" at debian/control:$.");
}
} elsif ($field_name eq 'build-profiles') {
# rely on libdpkg-perl providing the parsing functions
# because if we work on a package with a Build-Profiles
# field, then a high enough version of dpkg-dev is needed
# anyways
my $build_profiles = $value;
eval {
require Dpkg::BuildProfiles;
my @restrictions=Dpkg::BuildProfiles::parse_build_profiles($build_profiles);
if (@restrictions) {
$included_in_build_profile = Dpkg::BuildProfiles::evaluate_restriction_formula(
\@restrictions,
\@profiles);
}
};
if ($@) {
error("The control file has a Build-Profiles field. Requires libdpkg-perl >= 1.17.14");
}
}
}
if (!$_ or eof) { # end of stanza.
if ($package) {
$package_types{$package}=$package_type // 'deb';
$package_arches{$package}=$arch;
$package_multiarches{$package} = $multiarch;
$package_sections{$package} = $section || $source_section;
$cross_type //= 'host';
$package_cross_type{$package} = $cross_type;
push(@{$packages_by_type{'all-listed-in-control-file'}}, $package);
if ($included_in_build_profile) {
if ($arch eq 'all') {
push(@{$packages_by_type{'indep'}}, $package);
push(@{$packages_by_type{'both'}}, $package);
} else {
my $included = 0;
$included = 1 if $arch eq 'any';
if (not $included) {
my $desired_arch = hostarch();
if ($cross_type eq 'target') {
$cross_target_arch //= dpkg_architecture_value('DEB_TARGET_ARCH');
$desired_arch = $cross_target_arch;
}
$included = 1 if samearch($desired_arch, $arch);
}
if ($included) {
push(@{$packages_by_type{'arch'}}, $package);
push(@{$packages_by_type{'both'}}, $package);
}
}
}
}
$package='';
$package_type=undef;
$cross_type = undef;
$arch='';
$section='';
%seen_fields = ();
}
}
close($fd);
}
# Return true if we should use root.
# - Takes an optional keyword; if passed, this will return true if the keyword is listed in R^3 (Rules-Requires-Root)
# - If the optional keyword is omitted or not present in R^3 and R^3 is not 'binary-targets', then returns false
# - Returns true otherwise (i.e. keyword is in R^3 or R^3 is 'binary-targets')
{
my %rrr;
sub should_use_root {
my ($keyword) = @_;
my $rrr_env = $ENV{'DEB_RULES_REQUIRES_ROOT'} // 'binary-targets';
$rrr_env =~ s/^\s++//;
$rrr_env =~ s/\s++$//;
return 0 if $rrr_env eq 'no';
return 1 if $rrr_env eq 'binary-targets';
return 0 if not defined($keyword);
%rrr = map { $_ => 1 } split(' ', $rrr_env) if not %rrr;
return 1 if exists($rrr{$keyword});
return 0;
}
}
# Returns the "gain root command" as a list suitable for passing as a part of the command to "doit()"
sub gain_root_cmd {
my $raw_cmd = $ENV{DEB_GAIN_ROOT_CMD};
return if not defined($raw_cmd) or $raw_cmd =~ m/^\s*+$/;
return split(' ', $raw_cmd);
}
sub root_requirements {
my $rrr_env = $ENV{'DEB_RULES_REQUIRES_ROOT'} // 'binary-targets';
$rrr_env =~ s/^\s++//;
$rrr_env =~ s/\s++$//;
return 'none' if $rrr_env eq 'no';
return 'legacy-root' if $rrr_env eq 'binary-targets';
return 'targeted-promotion';
}
# Returns the arch a package will build for.
#
# Deprecated: please switch to the more descriptive
# package_binary_arch function instead.
sub package_arch {
my $package=shift;
return package_binary_arch($package);
}
# Returns the architecture going into the resulting .deb, i.e. the
# host architecture or "all".
sub package_binary_arch {
my $package=shift;
if (! exists $package_arches{$package}) {
warning "package $package is not in control info";
return hostarch();
}
return 'all' if $package_arches{$package} eq 'all';
return dpkg_architecture_value('DEB_TARGET_ARCH') if package_cross_type($package) eq 'target';
return hostarch();
}
# Returns the Architecture: value which the package declared.
sub package_declared_arch {
my $package=shift;
if (! exists $package_arches{$package}) {
warning "package $package is not in control info";
return hostarch();
}
return $package_arches{$package};
}
# Returns whether the package specified Architecture: all
sub package_is_arch_all {
my $package=shift;
if (! exists $package_arches{$package}) {
warning "package $package is not in control info";
return hostarch();
}
return $package_arches{$package} eq 'all';
}
# Returns the multiarch value of a package.
sub package_multiarch {
my $package=shift;
# Test the architecture field instead, as it is common for a
# package to not have a multi-arch value.
if (! exists $package_arches{$package}) {
warning "package $package is not in control info";
# The only sane default
return 'no';
}
return $package_multiarches{$package} // 'no';
}
# Returns the (raw) section value of a package (possibly including component).
sub package_section {
my ($package) = @_;
# Test the architecture field instead, as it is common for a
# package to not have a multi-arch value.
if (! exists $package_sections{$package}) {
warning "package $package is not in control info";
return 'unknown';
}
return $package_sections{$package} // 'unknown';
}
sub package_cross_type {
my ($package) = @_;
# Test the architecture field instead, as it is common for a
# package to not have a multi-arch value.
if (! exists $package_cross_type{$package}) {
warning "package $package is not in control info";
return 'host';
}
return $package_cross_type{$package} // 'host';
}
# Return true if a given package is really a udeb.
sub is_udeb {
my $package=shift;
if (! exists $package_types{$package}) {
warning "package $package is not in control info";
return 0;
}
return $package_types{$package} eq 'udeb';
}
{
my %packages_to_process;
sub process_pkg {
my ($package) = @_;
if (not %packages_to_process) {
%packages_to_process = map { $_ => 1 } @{$dh{DOPACKAGES}};
}
return $packages_to_process{$package} // 0;
}
}
# Only useful for dh(1)
sub bd_dh_sequences {
# Use $sourcepackage as check because %dh_bd_sequence can be empty
# after running getpackages().
getpackages() if not defined($sourcepackage);
return \%dh_bd_sequences;
}
sub _concat_slurp_script_files {
my (@files) = @_;
my $res = '';
for my $file (@files) {
open(my $fd, '<', $file) or error("open($file) failed: $!");
my $f = join('', <$fd>);
close($fd);
$res .= $f;
}
return $res;
}
sub _substitution_generator {
my ($input) = @_;
my $cache = {};
return sub {
my ($orig_key) = @_;
return $cache->{$orig_key} if exists($cache->{$orig_key});
my $value = exists($input->{$orig_key}) ? $input->{$orig_key} : undef;
if (not defined($value)) {
if ($orig_key =~ m/^DEB_(?:BUILD|HOST|TARGET)_/) {
$value = dpkg_architecture_value($orig_key);
} elsif ($orig_key =~ m{^ENV[.](\S+)$}) {
$value = $ENV{$1} // '';
}
} elsif (ref($value) eq 'CODE') {
$value = $value->($orig_key);
} elsif ($value =~ s/^@//) {
$value = _concat_slurp_script_files($value);
}
$cache->{$orig_key} = $value;
return $value;
};
}
# Handles #DEBHELPER# substitution in a script; also can generate a new
# script from scratch if none exists but there is a .debhelper file for it.
sub debhelper_script_subst {
my ($package, $script, $extra_vars) = @_;
my $tmp=tmpdir($package);
my $ext=pkgext($package);
my $file=pkgfile($package,$script);
my %variables = defined($extra_vars) ? %{$extra_vars} : ();
my $service_script = generated_file($package, "${script}.service", 0);
my @generated_scripts = ("debian/$ext$script.debhelper", $service_script);
my $subst;
@generated_scripts = grep { -f } @generated_scripts;
if ($script eq 'prerm' or $script eq 'postrm') {
@generated_scripts = reverse(@generated_scripts);
}
if (not exists($variables{'DEBHELPER'})) {
$variables{'DEBHELPER'} = sub {
return _concat_slurp_script_files(@generated_scripts);
};
}
$subst = _substitution_generator(\%variables);
if ($file ne '') {
if ($dh{VERBOSE}) {
verbose_print('cp -f ' . escape_shell($file) . " $tmp/DEBIAN/$script");
verbose_print("[META] Replace #TOKEN#s in \"$tmp/DEBIAN/$script\"");
}
if (not $dh{NO_ACT}) {
my $regex = qr{#(${MAINTSCRIPT_TOKEN_REGEX})#}o;
open(my $out_fd, '>', "$tmp/DEBIAN/$script") or error("open($tmp/DEBIAN/$script) failed: $!");
open(my $in_fd, '<', $file) or error("open($file) failed: $!");
while (my $line = <$in_fd>) {
$line =~ s{$regex}{$subst->($1) // "#${1}#"}ge;
print {$out_fd} $line;
}
close($in_fd);
close($out_fd) or error("close($tmp/DEBIAN/$script) failed: $!");
}
reset_perm_and_owner('0755', "$tmp/DEBIAN/$script");
}
elsif (@generated_scripts) {
if ($dh{VERBOSE}) {
verbose_print(q{printf '#!/bin/sh\nset -e\n' > } . "$tmp/DEBIAN/$script");
verbose_print("cat @generated_scripts >> $tmp/DEBIAN/$script");
}
if (not $dh{NO_ACT}) {
open(my $out_fd, '>', "$tmp/DEBIAN/$script") or error("open($tmp/DEBIAN/$script): $!");
print {$out_fd} "#!/bin/sh\n";
print {$out_fd} "set -e\n";
for my $generated_script (@generated_scripts) {
open(my $in_fd, '<', $generated_script)
or error("open($generated_script) failed: $!");
while (my $line = <$in_fd>) {
print {$out_fd} $line;
}
close($in_fd);
}
close($out_fd) or error("close($tmp/DEBIAN/$script) failed: $!");
}
reset_perm_and_owner('0755', "$tmp/DEBIAN/$script");
}
}
sub rm_files {
my @files = @_;
verbose_print('rm -f ' . escape_shell(@files))
if $dh{VERBOSE};
return 1 if $dh{NO_ACT};
for my $file (@files) {
if (not unlink($file) and $! != ENOENT) {
error("unlink $file failed: $!");
}
}
return 1;
}
sub make_symlink_raw_target {
my ($src, $dest) = @_;
verbose_print('ln -s ' . escape_shell($src, $dest))
if $dh{VERBOSE};
return 1 if $dh{NO_ACT};
if (not symlink($src, $dest)) {
error("symlink($src, $dest) failed: $!");
}
return 1;
}
# make_symlink($dest, $src[, $tmp]) creates a symlink from $dest -> $src.
# if $tmp is given, $dest will be created within it.
# Usually $tmp should be the value of tmpdir($package);
sub make_symlink{
my $dest = shift;
my $src = _expand_path(shift);
my $tmp = shift;
$tmp = '' if not defined($tmp);
if ($dest =~ m{(?:^|/)*[.]{2}(?:/|$)}) {
error("Invalid destination/link name (contains \"..\"-segments): $dest");
}
$src =~ s{^(?:[.]/+)++}{};
$dest =~ s{^(?:[.]/+)++}{};
$src=~s:^/++::;
$dest=~s:^/++::;
if ($src eq $dest) {
warning("skipping link from $src to self");
return;
}
# Policy says that if the link is all within one toplevel
# directory, it should be relative. If it's between
# top level directories, leave it absolute.
my @src_dirs = grep { $_ ne '.' } split(m:/+:,$src);
my @dest_dirs = grep { $_ ne '.' } split(m:/+:,$dest);
if (@src_dirs > 0 && $src_dirs[0] eq $dest_dirs[0]) {
# Figure out how much of a path $src and $dest
# share in common.
my $x;
for ($x=0; $x < @src_dirs && $src_dirs[$x] eq $dest_dirs[$x]; $x++) {}
# Build up the new src.
$src="";
for (1..$#dest_dirs - $x) {
$src.="../";
}
for ($x .. $#src_dirs) {
$src.=$src_dirs[$_]."/";
}
if ($x > $#src_dirs && ! length $src) {
$src="."; # special case
}
$src=~s:/$::;
}
else {
# Make sure it's properly absolute.
$src="/$src";
}
my $full_dest = "$tmp/$dest";
if ( -l $full_dest ) {
# All ok - we can always replace a link, and target directory must exists
} elsif (-d _) {
# We cannot replace a directory though
error("link destination $full_dest is a directory");
} else {
# Make sure the directory the link will be in exists.
my $basedir=dirname($full_dest);
install_dir($basedir);
}
rm_files($full_dest);
make_symlink_raw_target($src, $full_dest);
}
# _expand_path expands all path "." and ".." components, but doesn't
# resolve symbolic links.
sub _expand_path {
my $start = @_ ? shift : '.';
my @pathname = split(m:/+:,$start);
my @respath;
for my $entry (@pathname) {
if ($entry eq '.' || $entry eq '') {
# Do nothing
}
elsif ($entry eq '..') {
if ($#respath == -1) {
# Do nothing
}
else {
pop @respath;
}
}
else {
push @respath, $entry;
}
}
my $result;
for my $entry (@respath) {
$result .= '/' . $entry;
}
if (! defined $result) {
$result="/"; # special case
}
return $result;
}
# Checks if make's jobserver is enabled via MAKEFLAGS, but
# the FD used to communicate with it is actually not available.
sub is_make_jobserver_unavailable {
if (exists $ENV{MAKEFLAGS} &&
$ENV{MAKEFLAGS} =~ /(?:^|\s)--jobserver-(?:fds|auth)=(\d+)/) {
if (!open(my $in, "<&$1")) {
return 1; # unavailable
}
else {
close $in;
return 0; # available
}
}
return; # no jobserver specified
}
# Cleans out jobserver options from MAKEFLAGS.
sub clean_jobserver_makeflags {
if (exists $ENV{MAKEFLAGS}) {
if ($ENV{MAKEFLAGS} =~ /(?:^|\s)--jobserver-(?:fds|auth)=\d+/) {
$ENV{MAKEFLAGS} =~ s/(?:^|\s)--jobserver-(?:fds|auth)=\S+//g;
$ENV{MAKEFLAGS} =~ s/(?:^|\s)-j\b//g;
}
delete $ENV{MAKEFLAGS} if $ENV{MAKEFLAGS} =~ /^\s*$/;
}
}
# If cross-compiling, returns appropriate cross version of command.
sub cross_command {
my ($package, $command) = @_;
if (package_cross_type($package) eq 'target') {
if (dpkg_architecture_value("DEB_HOST_GNU_TYPE") ne dpkg_architecture_value("DEB_TARGET_GNU_TYPE")) {
return dpkg_architecture_value("DEB_TARGET_GNU_TYPE") . "-$command";
}
}
if (is_cross_compiling()) {
return dpkg_architecture_value("DEB_HOST_GNU_TYPE")."-$command";
}
else {
return $command;
}
}
# Returns the SOURCE_DATE_EPOCH ENV variable if set OR computes it
# from the latest changelog entry, sets the SOURCE_DATE_EPOCH ENV
# variable and returns the computed value.
sub get_source_date_epoch {
return $ENV{SOURCE_DATE_EPOCH} if exists($ENV{SOURCE_DATE_EPOCH});
eval { require Dpkg::Changelog::Debian };
if ($@) {
warning "unable to set SOURCE_DATE_EPOCH: $@";
return;
}
eval { require Time::Piece };
if ($@) {
warning "unable to set SOURCE_DATE_EPOCH: $@";
return;
}
my $changelog = Dpkg::Changelog::Debian->new(range => {"count" => 1});
$changelog->load("debian/changelog");
my $tt = @{$changelog}[0]->get_timestamp();
$tt =~ s/\s*\([^\)]+\)\s*$//; # Remove the optional timezone codename
my $timestamp = Time::Piece->strptime($tt, "%a, %d %b %Y %T %z");
return $ENV{SOURCE_DATE_EPOCH} = $timestamp->epoch();
}
# Setup the build ENV by setting dpkg-buildflags (via set_buildflags()) plus
# cleaning up HOME (etc) in compat 13+
sub setup_buildenv {
set_buildflags();
if (not compat(12)) {
setup_home_and_xdg_dirs();
}
}
sub setup_home_and_xdg_dirs {
my $home_dir = generated_file('_source', 'home', 0);
my $xdg_rundir = generated_file('_source', 'xdg-runtime-dir', 0);
my $creating_rundir = -d $xdg_rundir ? 0 : 1;
my @paths = (
$home_dir,
$xdg_rundir,
);
my @clear_env = qw(
XDG_CACHE_HOME
XDG_CONFIG_DIRS
XDG_CONFIG_HOME
XDG_DATA_HOME
XDG_DATA_DIRS
);
install_dir(@paths);
if ($creating_rundir) {
chmod(0700, $xdg_rundir) == 1 or warning("chmod(0700, \"$xdg_rundir\") failed: $! (ignoring)");
}
for my $envname (@clear_env) {
delete($ENV{$envname});
}
$ENV{'HOME'} = $home_dir;
$ENV{'XDG_RUNTIME_DIR'} = $xdg_rundir;
return;
}
# Sets environment variables from dpkg-buildflags. Avoids changing
# any existing environment variables.
sub set_buildflags {
return if $ENV{DH_INTERNAL_BUILDFLAGS};
$ENV{DH_INTERNAL_BUILDFLAGS}=1;
# For the side effect of computing the SOURCE_DATE_EPOCH variable.
get_source_date_epoch();
return if compat(8);
# Export PERL_USE_UNSAFE_INC as a transitional step to allow us
# to remove . from @INC by default without breaking packages which
# rely on this [CVE-2016-1238]
$ENV{PERL_USE_UNSAFE_INC} = 1 if compat(10);
eval { require Dpkg::BuildFlags };
if ($@) {
warning "unable to load build flags: $@";
return;
}
my $buildflags = Dpkg::BuildFlags->new();
$buildflags->load_config();
foreach my $flag ($buildflags->list()) {
next unless $flag =~ /^[A-Z]/; # Skip flags starting with lowercase
if (! exists $ENV{$flag}) {
$ENV{$flag} = $buildflags->get($flag);
}
}
}
# Gets a DEB_BUILD_OPTIONS option, if set.
sub get_buildoption {
my $wanted=shift;
return undef unless exists $ENV{DEB_BUILD_OPTIONS};
foreach my $opt (split(/\s+/, $ENV{DEB_BUILD_OPTIONS})) {
# currently parallel= is the only one with a parameter
if ($opt =~ /^parallel=(-?\d+)$/ && $wanted eq 'parallel') {
return $1;
}
elsif ($opt eq $wanted) {
return 1;
}
}
return undef;
}
# Returns true if DEB_BUILD_PROFILES lists the given profile.
sub is_build_profile_active {
my ($wanted) = @_;
return 0 if not exists($ENV{DEB_BUILD_PROFILES});
for my $prof (split(m/\s+/, $ENV{DEB_BUILD_PROFILES})) {
return 1 if $prof eq $wanted;
}
return 0;
}
# install a dh config file (e.g. debian/<pkg>.lintian-overrides) into
# the package. Under compat 9+ it may execute the file and use its
# output instead.
#
# install_dh_config_file(SOURCE, TARGET[, MODE])
sub install_dh_config_file {
my ($source, $target, $mode) = @_;
$mode = 0644 if not defined($mode);
if (!compat(8) and -x $source) {
my @sstat = stat(_) || error("cannot stat $source: $!");
open(my $tfd, '>', $target) || error("cannot open $target: $!");
chmod($mode, $tfd) || error("cannot chmod $target: $!");
open(my $sfd, '-|', $source) || error("cannot run $source: $!");
while (my $line = <$sfd>) {
print ${tfd} $line;
}
if (!close($sfd)) {
error("cannot close handle from $source: $!") if $!;
error_exitcode($source);
}
close($tfd) || error("cannot close $target: $!");
# Set the mtime (and atime) to ensure reproducibility.
utime($sstat[9], $sstat[9], $target);
} else {
_install_file_to_path($mode, $source, $target);
}
return 1;
}
sub restore_file_on_clean {
my ($file) = @_;
my $bucket_index = 'debian/.debhelper/bucket/index';
my $bucket_dir = 'debian/.debhelper/bucket/files';
my $checksum;
install_dir($bucket_dir);
if ($file =~ m{^/}) {
error("restore_file_on_clean requires a path relative to the package dir");
}
$file =~ s{^\./}{}g;
$file =~ s{//++}{}g;
if ($file =~ m{^\.} or $file =~ m{/CVS/} or $file =~ m{/\.svn/}) {
# We do not want to smash a Vcs repository by accident.
warning("Attempt to store $file, which looks like a VCS file or");
warning("a hidden package file (like quilt's \".pc\" directory)");
error("This tool probably contains a bug.");
}
if (-l $file or not -f _) {
error("Cannot store $file: Can only store regular files (no symlinks, etc.)");
}
require Digest::SHA;
$checksum = Digest::SHA->new('256')->addfile($file, 'b')->hexdigest;
if (not $dh{NO_ACT}) {
my ($in_index);
open(my $fd, '+>>', $bucket_index)
or error("open($bucket_index, a+) failed: $!");
seek($fd, 0, 0);
while (my $line = <$fd>) {
my ($cs, $stored_file);
chomp($line);
($cs, $stored_file) = split(m/ /, $line, 2);
next if ($stored_file ne $file);
$in_index = 1;
}
if (not $in_index) {
# Copy and then rename so we always have the full copy of
# the file in the correct place (if any at all).
doit('cp', '-an', '--reflink=auto', $file, "${bucket_dir}/${checksum}.tmp");
rename_path("${bucket_dir}/${checksum}.tmp", "${bucket_dir}/${checksum}");
print {$fd} "${checksum} ${file}\n";
}
close($fd) or error("close($bucket_index) failed: $!");
}
return 1;
}
sub restore_all_files {
my $bucket_index = 'debian/.debhelper/bucket/index';
my $bucket_dir = 'debian/.debhelper/bucket/files';
return if not -f $bucket_index;
open(my $fd, '<', $bucket_index)
or error("open($bucket_index) failed: $!");
while (my $line = <$fd>) {
my ($cs, $stored_file, $bucket_file);
chomp($line);
($cs, $stored_file) = split(m/ /, $line, 2);
$bucket_file = "${bucket_dir}/${cs}";
# Restore by copy and then rename. This ensures that:
# 1) If dh_clean is interrupted, we can always do a full restore again
# (otherwise, we would be missing some of the files and have to handle
# that with scary warnings)
# 2) The file is always fully restored or in its "pre-restore" state.
doit('cp', '-an', '--reflink=auto', $bucket_file, "${bucket_file}.tmp");
rename_path("${bucket_file}.tmp", $stored_file);
}
close($fd);
return;
}
sub open_gz {
my ($file) = @_;
my $fd;
eval {
require PerlIO::gzip;
};
if ($@) {
open($fd, '-|', 'gzip', '-dc', $file)
or error("gzip -dc $file failed: $!");
} else {
# Pass ":unix" as well due to https://rt.cpan.org/Public/Bug/Display.html?id=114557
# Alternatively, we could ensure we always use "POSIX::_exit". Unfortunately,
# loading POSIX is insanely slow.
open($fd, '<:unix:gzip', $file)
or error("open $file [<:unix:gzip] failed: $!");
}
return $fd;
}
sub deprecated_functionality {
my ($warning_msg, $compat_removal, $removal_msg) = @_;
if (defined($compat_removal) and not compat($compat_removal - 1)) {
my $msg = $removal_msg // $warning_msg;
warning($msg);
error("This feature was removed in compat ${compat_removal}.");
} else {
warning($warning_msg);
warning("This feature will be removed in compat ${compat_removal}.")
if defined($compat_removal);
}
return 1;
}
sub log_installed_files {
my ($package, @patterns) = @_;
return if $dh{NO_ACT};
my $log = generated_file($package, 'installed-by-' . basename($0));
open(my $fh, '>>', $log) or error("open $log: $!");
for my $src (@patterns) {
print $fh "$src\n";
}
close($fh) or error("close $log: $!");
return 1;
}
use constant {
# The ELF header is at least 0x32 bytes (32bit); any filer shorter than that is not an ELF file
ELF_MIN_LENGTH => 0x32,
ELF_MAGIC => "\x7FELF",
ELF_ENDIAN_LE => 0x01,
ELF_ENDIAN_BE => 0x02,
ELF_TYPE_EXECUTABLE => 0x0002,
ELF_TYPE_SHARED_OBJECT => 0x0003,
};
sub is_so_or_exec_elf_file {
my ($file) = @_;
open(my $fd, '<:raw', $file) or error("open $file: $!");
my $buflen = 0;
my ($buf, $endian);
while ($buflen < ELF_MIN_LENGTH) {
my $r = read($fd, $buf, ELF_MIN_LENGTH - $buflen, $buflen) // error("read ($file): $!");
last if $r == 0; # EOF
$buflen += $r
}
close($fd);
return 0 if $buflen < ELF_MIN_LENGTH;
return 0 if substr($buf, 0x00, 4) ne ELF_MAGIC;
$endian = unpack('c', substr($buf, 0x05, 1));
my ($long_format, $short_format);
if ($endian == ELF_ENDIAN_BE) {
$long_format = 'N';
$short_format = 'n';
} elsif ($endian == ELF_ENDIAN_LE) {
$long_format = 'V';
$short_format = 'v';
} else {
return 0;
}
my $elf_version = substr($buf, 0x14, 4);
my $elf_type = substr($buf, 0x10, 2);
return 0 if unpack($long_format, $elf_version) != 0x00000001;
my $elf_type_unpacked = unpack($short_format, $elf_type);
return 0 if $elf_type_unpacked != ELF_TYPE_EXECUTABLE and $elf_type_unpacked != ELF_TYPE_SHARED_OBJECT;
return 1;
}
sub _has_shbang_line {
my ($file) = @_;
open(my $fd, '<', $file) or error("open $file: $!");
my $line = <$fd>;
close($fd);
return 1 if (defined($line) and substr($line, 0, 2) eq '#!');
return 0;
}
# Returns true iff the given argument is an empty directory.
# Corner-cases:
# - false if not a directory
sub is_empty_dir {
my ($dir) = @_;
return 0 if not -d $dir;
my $ret = 1;
opendir(my $dir_fd, $dir) or error("opendir($dir) failed: $!");
while (defined(my $entry = readdir($dir_fd))) {
next if $entry eq '.' or $entry eq '..';
$ret = 0;
last;
}
closedir($dir_fd);
return $ret;
}
sub on_pkgs_in_parallel(&) {
unshift(@_, $dh{DOPACKAGES});
goto \&on_items_in_parallel;
}
# Given a list of files, find all hardlinked files and return:
# 1: a list of unique files (all files in the list are not hardlinked with any other file in that list)
# 2: a map where the keys are names of hardlinks and the value points to the name selected as the file put in the
# list of unique files.
#
# This is can be used to relink hard links after modifying one of them.
sub find_hardlinks {
my (@all_files) = @_;
my (%seen, %hardlinks, @unique_files);
for my $file (@all_files) {
my ($dev, $inode, undef, $nlink)=stat($file);
if (defined $nlink && $nlink > 1) {
if (! $seen{"$inode.$dev"}) {
$seen{"$inode.$dev"}=$file;
push(@unique_files, $file);
} else {
# This is a hardlink.
$hardlinks{$file}=$seen{"$inode.$dev"};
}
} else {
push(@unique_files, $file);
}
}
return (\@unique_files, \%hardlinks);
}
sub on_items_in_parallel {
my ($pkgs_ref, $code) = @_;
my @pkgs = @{$pkgs_ref};
my %pids;
my $parallel = $MAX_PROCS;
my $count_per_proc = int( (scalar(@pkgs) + $parallel - 1)/ $parallel);
my $exit = 0;
if ($count_per_proc < 1) {
$count_per_proc = 1;
if (@pkgs > 3) {
# Forking has a considerable overhead, so bulk the number
# a bit. We do not do this unconditionally, because we
# want parallel issues (if any) to appear already with 2
# packages and two procs (because people are lazy when
# testing).
#
# Same reason for also unconditionally forking with 1 pkg
# in 1 proc.
$count_per_proc = 2;
}
}
# Assertion, $count_per_proc * $parallel >= scalar(@pkgs)
while (@pkgs) {
my @batch = splice(@pkgs, 0, $count_per_proc);
my $pid = fork() // error("fork: $!");
if (not $pid) {
# Child processes should not write to the log file
inhibit_log();
eval {
$code->(@batch);
};
if (my $err = $@) {
$err =~ s/\n$//;
print STDERR "$err\n";
exit(2);
}
exit(0);
}
$pids{$pid} = 1;
}
while (%pids) {
my $pid = wait;
error("wait() failed: $!") if $pid == -1;
delete($pids{$pid});
if ($? != 0) {
$exit = 1;
}
}
if ($exit) {
error("Aborting due to earlier error");
}
return;
}
*on_selected_pkgs_in_parallel = \&on_items_in_parallel;
sub compute_doc_main_package {
my ($doc_package) = @_;
# if explicitly set, then choose that.
return $dh{DOC_MAIN_PACKAGE} if $dh{DOC_MAIN_PACKAGE};
# In compat 10 (and earlier), there is no auto-detection
return $doc_package if compat(10);
my $target_package = $doc_package;
# If it is not a -doc package, then docs should be installed
# under its own package name.
return $doc_package if $target_package !~ s/-doc$//;
# FOO-doc hosts the docs for FOO; seems reasonable
return $target_package if exists($package_types{$target_package});
if ($doc_package =~ m/^lib./) {
# Special case, "libFOO-doc" can host docs for "libFOO-dev"
my $lib_dev = "${target_package}-dev";
return $lib_dev if exists($package_types{$lib_dev});
# Technically, we could go look for a libFOO<something>-dev,
# but atm. it is presumed to be that much of a corner case
# that it warrents an override.
}
# We do not know; make that clear to the caller
return;
}
sub dbgsym_tmpdir {
my ($package) = @_;
return "debian/.debhelper/${package}/dbgsym-root";
}
sub perl_cross_incdir {
return if !is_cross_compiling();
# native builds don't currently need this so only load it on demand
require Config; Config->import();
my $triplet = dpkg_architecture_value("DEB_HOST_MULTIARCH");
my $perl_version = $Config::Config{version};
my $incdir = "/usr/lib/$triplet/perl/cross-config-${perl_version}";
return undef if !-e "$incdir/Config.pm";
return $incdir;
}
{
my %known_packages;
sub is_known_package {
my ($package) = @_;
%known_packages = map { $_ => 1 } getpackages() if not %known_packages;
return 1 if exists($known_packages{$package});
return 0
}
sub assert_opt_is_known_package {
my ($package, $method) = @_;
if (not is_known_package($package)) {
error("Requested unknown package $package via $method, expected one of: " . join(' ', getpackages()));
}
return 1;
}
}
{
my $_disable_file_seccomp;
sub _internal_optional_file_args {
if (not defined($_disable_file_seccomp)) {
my $consider_disabling_seccomp = 0;
if ($ENV{'FAKEROOTKEY'} or ($ENV{'LD_PRELOAD'}//'') =~ m/fakeroot/) {
$consider_disabling_seccomp = 1;
}
if ($consider_disabling_seccomp) {
my $has_no_sandbox = (qx_cmd('file', '--help') // '') =~ m/--no-sandbox/;
$consider_disabling_seccomp = 0 if not $has_no_sandbox;
}
$_disable_file_seccomp = $consider_disabling_seccomp;
}
return ('--no-sandbox') if $_disable_file_seccomp;
return;
}
}
1
AnonSec - 2021 | Recode By D7net