diff options
Diffstat (limited to 'lib/Debian/Debhelper/Dh_Lib.pm')
| -rw-r--r-- | lib/Debian/Debhelper/Dh_Lib.pm | 3111 |
1 files changed, 3111 insertions, 0 deletions
diff --git a/lib/Debian/Debhelper/Dh_Lib.pm b/lib/Debian/Debhelper/Dh_Lib.pm new file mode 100644 index 0000000..7cf59e0 --- /dev/null +++ b/lib/Debian/Debhelper/Dh_Lib.pm @@ -0,0 +1,3111 @@ +#!/usr/bin/perl +# +# Library functions for debhelper programs, perl version. +# +# Joey Hess, GPL copyright 1997-2008. + +package Debian::Debhelper::Dh_Lib; + +use v5.24; +use warnings; +use utf8; + +# Disable unicode_strings for now until a better solution for +# Debian#971362 comes around. +no feature 'unicode_strings'; + + +use constant { + # Lowest compat level supported + 'MIN_COMPAT_LEVEL' => 7, + # Lowest compat level that does *not* cause deprecation + # warnings + 'LOWEST_NON_DEPRECATED_COMPAT_LEVEL' => 10, + # Lowest compat level to generate "debhelper-compat (= X)" + # relations for. + 'LOWEST_VIRTUAL_DEBHELPER_COMPAT_LEVEL' => 9, + # Highest compat level permitted + 'MAX_COMPAT_LEVEL' => 15, + # 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', +}; + + +# The Makefile changes this if debhelper is installed in a PREFIX. +my $prefix="/usr"; +# The Makefile changes this during install to match the actual version. +use constant HIGHEST_STABLE_COMPAT_LEVEL => undef; + +# Locations we search for data files by default +my @DATA_INC_PATH = ( + "${prefix}/share/debhelper", +); +# Enable the use of DH_DATAFILES for testing purposes. +unshift(@DATA_INC_PATH, split(':', $ENV{'DH_DATAFILES'})) if exists($ENV{'DH_DATAFILES'}); + +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' => DEFAULT_PACKAGE_TYPE, + # Lowest compat level supported that is not scheduled for removal. + # - Set to MIN_COMPAT_LEVEL when there are no pending compat removals. + 'MIN_COMPAT_LEVEL_NOT_SCHEDULED_FOR_REMOVAL' => MIN_COMPAT_LEVEL, +}; + + +# Internal constants used to define limits in variable expansions. +use constant { + # How many expansions are permitted in total. + _VAR_SUBST_EXPANSION_COUNT_LIMIT => 50, + # When recursion is enabled, how many times will we expand a pattern + # on the same position in the string. + _VAR_SUBST_SAME_POSITION_RECURSION_LIMIT => 20, + # Expansions are always allowed to grow up to this length regardless + # of original input size (provided it does not trip another limit) + _VAR_SUBST_EXPANSION_MIN_SUPPORTED_SIZE_LIMIT => 4096, + # Factor input is allowed to grow before it triggers an error + # (_VAR_SUBST_EXPANSION_MIN_SUPPORTED_SIZE_LIMIT overrules this for a + # given input if the max size limit computed with this factor is less + # than _VAR_SUBST_EXPANSION_MIN_SUPPORTED_SIZE_LIMIT) + _VAR_SUBST_EXPANSION_DYNAMIC_EXPANSION_FACTOR_LIMIT => 3, +}; + + +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 + package_type + process_pkg + compute_doc_main_package + isnative + is_udeb +), + # File/path related actions +qw( + basename + dirname + mkdirs + 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 + get_non_binnmu_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 + debhelper_script_per_package_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 +)); + +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; +our $TOOL_NAME = basename($0); + +# 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($TOOL_NAME, @{$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 _post_fork_setup_and_exec { + my ($close_stdin, $options, @cmd) = @_; + if (defined($options)) { + if (defined(my $dir = $options->{chdir})) { + if ($dir ne '.') { + chdir($dir) or error("chdir(\"${dir}\") failed: $!"); + } + } + if ($close_stdin) { + 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 or error('exec (for cmd: ' . escape_shell(@cmd) . ") failed: $!"); +} + +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) { + _post_fork_setup_and_exec(1, $options, @cmd) // error("Assertion error: sub should not return!"); + } + 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 $options = ref($cmd[0]) ? shift(@cmd) : undef; + my ($output, @output); + my $pid = open(my $fd, '-|') // error('fork (for cmd: ' . escape_shell(@cmd) . ") failed: $!"); + if ($pid == 0) { + _post_fork_setup_and_exec(0, $options, @cmd) // error("Assertion error: sub should not return!"); + } + 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; + } +} + + +sub _mkdirs { + my ($log, @dirs) = @_; + return if not @dirs; + if ($log && $dh{VERBOSE}) { + verbose_print(sprintf('install -m0755 -d %s', escape_shell(@dirs))); + } + return 1 if $dh{NO_ACT}; + state $_loaded; + if (not $_loaded) { + $_loaded++; + require File::Path; + } + my %opts = ( + # 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, + ); + eval { + File::Path::make_path(@dirs, \%opts); + }; + if (my $err = "$@") { + $err =~ s/\s+at\s+\S+\s+line\s+\d+\.?\n//; + error($err); + } + return; +} + +sub mkdirs { + my @to_create = grep { not -d $_ } @_; + return _mkdirs(0, @to_create); +} + +sub install_dir { + my @dirs = @_; + return _mkdirs(1, @dirs); +} + +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}) { + if (defined($message)) { + print "\t$message\n"; + } else { + print "\n"; + } + } +} + +sub _color { + my ($msg, $color) = @_; + state $_use_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($TOOL_NAME, 'bold') . ': ' . _color('error', 'bold red') . ": $message\n"); +} + +# Output a warning. +sub warning { + my ($message) = @_; + $message //= ''; + + print STDERR _color($TOOL_NAME, '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 $check_pending_removals = get_buildoption('dherroron', '') eq 'obsolete-compat-levels' ? 1 : 0; + my $warned_compat = $ENV{DH_INTERNAL_TESTSUITE_SILENT_WARNINGS} ? 1 : 0; + my $declared_compat; + my $delared_compat_source; + my $c; + + # Used mainly for testing + sub resetcompat { + undef $c; + undef $compat_from_bd; + } + + sub _load_compat_info { + my ($nowarn) = @_; + + getpackages() if not defined($compat_from_bd); + + $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; + } + $delared_compat_source = 'debian/compat'; + } elsif ($compat_from_bd != -1) { + $c = $compat_from_bd; + $delared_compat_source = "Build-Depends: debhelper-compat (= $c)"; + } elsif (not $nowarn) { + error("Please specify the compatibility level in debian/compat or via Build-Depends: debhelper-compat (= X)"); + } + + $declared_compat = int($c); + + if (defined $ENV{DH_COMPAT}) { + my $override = $ENV{DH_COMPAT}; + error("The environment variable DH_COMPAT must be a positive integer") + if $override ne q{} and $override !~ m/^\d+$/; + $c=int($ENV{DH_COMPAT}) if $override ne q{}; + } + } + + sub get_compat_info { + if (not $c) { + _load_compat_info(1); + } + return ($c, $declared_compat, $delared_compat_source); + } + + sub compat { + my ($num, $nowarn) = @_; + + if (not $c) { + _load_compat_info($nowarn); + } + + if (not $nowarn) { + if ($c < MIN_COMPAT_LEVEL) { + error("Compatibility levels before ${\MIN_COMPAT_LEVEL} are no longer supported (level $c requested)"); + } + + if ($check_pending_removals and $c < MIN_COMPAT_LEVEL_NOT_SCHEDULED_FOR_REMOVAL) { + my $v = MIN_COMPAT_LEVEL_NOT_SCHEDULED_FOR_REMOVAL; + error("Compatibility levels before ${v} are scheduled for removal and DH_COMPAT_ERROR_ON_PENDING_REMOVAL was set (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. +sub isnative { + my ($package) = @_; + my $cache_key = $package; + + state (%isnative_cache, %pkg_version); + + 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 { + for my $dir (@DATA_INC_PATH) { + my $path = "${dir}/autoscripts/${filename}"; + if (-e $path) { + $infile = $path; + last; + } + } + if (not defined($infile)) { + my @dirs = map { "$_/autoscripts" } @DATA_INC_PATH; + unshift(@dirs, $ENV{DH_AUTOSCRIPTDIR}) if exists($ENV{DH_AUTOSCRIPTDIR}); + error("Could not find autoscript $filename (search path: " . join(':', @dirs) . ')'); + } + } + + if (-e $outfile && ($script eq 'postrm' || $script eq 'prerm')) { + # 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 ' . $TOOL_NAME . "/${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 ".$TOOL_NAME."/${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 ' . $TOOL_NAME . "/${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 ".$TOOL_NAME."/${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 ' . $TOOL_NAME . "/${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; + mkdirs($dir) if $mkdirs; + return $path; +} + +sub _update_substvar { + my ($substvar_file, $update_logic, $insert_logic) = @_; + my @lines; + my $changed = 0; + if ( -f $substvar_file) { + open(my $in, '<', $substvar_file) // error("open($substvar_file): $!"); + while (my $line = <$in>) { + chomp($line); + my $orig_value = $line; + my $updated_value = $update_logic->($line); + $changed ||= !defined($updated_value) || $orig_value ne $updated_value; + push(@lines, $updated_value) if defined($updated_value); + } + close($in); + } + my $len = scalar(@lines); + push(@lines, $insert_logic->()) if $insert_logic; + $changed ||= $len != scalar(@lines); + if ($changed && !$dh{NO_ACT}) { + open(my $out, '>', "${substvar_file}.new") // error("open(${substvar_file}.new, \"w\"): $!"); + for my $line (@lines) { + print {$out} "$line\n"; + } + close($out) // error("close(${substvar_file}.new): $!"); + rename_path("${substvar_file}.new", $substvar_file); + } + return; +} + +# Removes a whole substvar line. +sub delsubstvar { + my ($package, $substvar) = @_; + my $ext = pkgext($package); + my $substvarfile = "debian/${ext}substvars"; + + return _update_substvar($substvarfile, sub { + my ($line) = @_; + return $line if $line !~ m/^\Q${substvar}\E[?]?=/; + return; + }); +} + +# Adds a dependency on some package to the specified +# substvar in a package's substvar's file. +sub addsubstvar { + my ($package, $substvar, $deppackage, $verinfo, $remove) = @_; + my ($present); + my $ext = pkgext($package); + my $substvarfile = "debian/${ext}substvars"; + my $str = $deppackage; + $str .= " ($verinfo)" if defined $verinfo && length $verinfo; + + if (not defined($deppackage) and not $remove) { + error("Bug in helper: Must provide a value for addsubstvar (or set the remove flag, but then use delsubstvar instead)") + } + + if (defined($str) and $str =~ m/[\n]/) { + $str =~ s/\n/\\n/g; + # Per #1026014 + warning('Unescaped newlines in the value of a substvars can cause broken substvars files (see #1025714).'); + warning("Hint: If you really need a newline character, provide it as \"\${Newline}\"."); + error("Bug in helper: The substvar must not contain a raw newline character (${substvar}=${str})"); + } + + my $update_logic = sub { + my ($line) = @_; + return $line if $line !~ m/^\Q${substvar}\E([?]?=)(.*)/; + my $assignment_type = $1; + my %items = map { $_ => 1 } split(", ", $2); + $present = 1; + if ($remove) { + # Unchanged; we can avoid rewriting the file. + return $line if not exists($items{$str}); + delete($items{$str}); + my $replacement = join(", ", sort(keys(%items))); + return "${substvar}${assignment_type}${replacement}" if $replacement ne ''; + return; + } + # Unchanged; we can avoid rewriting the file. + return $line if %items and exists($items{$str}); + + $items{$str} = 1; + return "${substvar}${assignment_type}" . join(", ", sort(keys(%items))); + }; + my $insert_logic = sub { + return ("${substvar}=${str}") if not $present and not $remove; + return; + }; + return _update_substvar($substvarfile, $update_logic, $insert_logic); +} + +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' => "\t", +); + +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 = _VAR_SUBST_EXPANSION_DYNAMIC_EXPANSION_FACTOR_LIMIT * $current_size; + $expansion_size_limit = _VAR_SUBST_EXPANSION_MIN_SUPPORTED_SIZE_LIMIT + if $expansion_size_limit < _VAR_SUBST_EXPANSION_MIN_SUPPORTED_SIZE_LIMIT; + 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 >= _VAR_SUBST_SAME_POSITION_RECURSION_LIMIT); + } else { + $subst_count = 0; + $pos = $new_pos; + if (++$expansion_count >= _VAR_SUBST_EXPANSION_COUNT_LIMIT) { + 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(qq{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 > $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) { + _executable_dh_config_file_failed($file, $!, $?); + } 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; +} + +sub dpkg_architecture_value { + my $var = shift; + state %dpkg_arch_output; + 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 space-separated list of arches to match against, returns true if matched +sub samearch { + my $arch=shift; + my @archlist=split(/\s+/,shift); + state %knownsame; + + 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 _strip_spaces { + my ($v) = @_; + return if not defined($v); + $v =~ s/^\s++//; + $v =~ s/\s++$//; + return $v; +} + +sub _parse_debian_control { + my $valid_pkg_re = qr{^${PKGNAME_REGEX}$}o; + my (%seen, @profiles, $source_section, $cross_target_arch, %field_values, + $field_name, %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 + s/^\s[.]?//; + push(@{$bd_field_value}, $_) if $bd_field_value; + # Ensure it is not completely empty or the code below will assume the paragraph ended + $_ = '.' if not $_; + } elsif (not $_ and not %seen_fields) { + # Ignore empty lines before first stanza + next; + } elsif ($_) { + my ($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 = (); + $field_name = undef; + + 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 $.)"); + } + s/^\s[.]?//; + $field_values{$field_name} .= ' ' . $_; + # Ensure it is not completely empty or the code below will assume the paragraph ended + $_ = '.' if not $_; + } elsif (not $_ and not %seen_fields) { + # Ignore empty lines before first stanza + next; + } elsif ($_) { + my ($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: $."); + } + + if ($field_name =~ m/^(?:x[bc]*-)?package-type$/) { + # Normalize variants into the main "Package-Type" field + $field_name = 'package-type'; + if (exists($seen_fields{$field_name})) { + my $package = _strip_spaces($field_values{'package'} // ''); + my $help = "(issue seen prior \"Package\"-field)"; + $help = "for package ${package}" if $package; + error("Multiple definitions of (X-)Package-Type in line $. ${help}"); + } + } + $seen_fields{$field_name} = $.; + $field_values{$field_name} = $value; + $bd_field_value = undef; + } else { + # Invalid file + error("Parse error in debian/control, line $., read: $_"); + } + } + if (!$_ or eof) { # end of stanza. + if (%field_values) { + my $package = _strip_spaces($field_values{'package'} // ''); + my $build_profiles = $field_values{'build-profiles'}; + my $included_in_build_profile = 1; + my $arch = _strip_spaces($field_values{'architecture'} // ''); + my $cross_type = _strip_spaces($field_values{'x-dh-build-for-type'} // 'host'); + + # Detect duplicate package names in the same control file. + if ($package eq '') { + error("Binary paragraph ending on line $. is missing mandatory \"Package\"-field"); + } + 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}\""); + } + if ($cross_type ne 'host' and $cross_type ne 'target') { + error("Unknown value of X-DH-Build-For-Type \"$cross_type\" for package $package"); + } + + $package_types{$package} = _strip_spaces($field_values{'package-type'} // 'deb'); + $package_arches{$package} = $arch; + $package_multiarches{$package} = _strip_spaces($field_values{'multi-arch'} // ''); + $package_sections{$package} = _strip_spaces($field_values{'section'} // $source_section); + $package_cross_type{$package} = $cross_type; + push(@{$packages_by_type{'all-listed-in-control-file'}}, $package); + + if (defined($build_profiles)) { + eval { + # 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 + 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 ($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); + } + } + } + } + %field_values = (); + %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') +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); + + state %rrr = map { $_ => 1 } split(' ', $rrr_env); + 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'; +} + +sub package_type { + my ($package) = @_; + + if (! exists $package_types{$package}) { + warning "package $package is not in control info"; + return DEFAULT_PACKAGE_TYPE; + } + return $package_types{$package}; +} + +# Return true if a given package is really a udeb. +sub is_udeb { + my $package=shift; + + return package_type($package) eq 'udeb'; +} + + +sub process_pkg { + my ($package) = @_; + state %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; + }; +} + +sub debhelper_script_per_package_subst { + my ($package, $provided_subst) = @_; + my %vars = %{$provided_subst}; + $vars{'PACKAGE'} = $package if not exists($vars{'PACKAGE'}); + for my $var (keys(%{$provided_subst})) { + if ($var !~ $Debian::Debhelper::Dh_Lib::MAINTSCRIPT_TOKEN_REGEX) { + warning("User defined token ${var} does not match ${Debian::Debhelper::Dh_Lib::MAINTSCRIPT_TOKEN_REGEX}"); + error("Invalid provided token ${var}: It cannot be substituted as it does not follow the token name rules"); + } + if ($var =~ m/^pkg[.]\Q${package}\E[.](.+)$/) { + my $new_key = $1; + $vars{$new_key} = $provided_subst->{$var}; + } + } + return \%vars; +} + + +# 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}); + _parse_non_binnmu_date_epoch(); + return $ENV{SOURCE_DATE_EPOCH}; +} + +{ + my $_non_binnmu_date_epoch; + + # Needed for dh_strip_nondeterminism - not exported by default because it is not likely + # to be useful beyond that one helper. + sub get_non_binnmu_date_epoch { + return $_non_binnmu_date_epoch if defined($_non_binnmu_date_epoch); + _parse_non_binnmu_date_epoch(); + return $_non_binnmu_date_epoch; + } + + sub _parse_non_binnmu_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" => 2}); + $changelog->load("debian/changelog"); + + my $first_entry = $changelog->[0]; + my $non_binnmu_entry = $first_entry; + my $optional_fields = $first_entry->get_optional_fields(); + my $first_tt = $first_entry->get_timestamp(); + $first_tt =~ s/\s*\([^\)]+\)\s*$//; # Remove the optional timezone codename + my $first_timestamp = Time::Piece->strptime($first_tt, "%a, %d %b %Y %T %z")->epoch; + my $non_binnmu_timestamp = $first_timestamp; + if (exists($optional_fields->{'Binary-Only'}) and lc($optional_fields->{'Binary-Only'}) eq 'yes') { + $non_binnmu_entry = $changelog->[1]; + my $non_binnmu_options = $non_binnmu_entry->get_optional_fields(); + if (exists($non_binnmu_options->{'Binary-Only'}) and lc($non_binnmu_options->{'Binary-Only'}) eq 'yes') { + error("internal error: Could not locate the first non-binnmu entry in the change (assumed it would be the second entry)"); + } + my $non_binnmu_tt = $non_binnmu_entry->get_timestamp(); + $non_binnmu_tt =~ s/\s*\([^\)]+\)\s*$//; # Remove the optional timezone codename + $non_binnmu_timestamp = Time::Piece->strptime($non_binnmu_tt, "%a, %d %b %Y %T %z")->epoch(); + } + + $ENV{SOURCE_DATE_EPOCH} = $first_timestamp if not exists($ENV{SOURCE_DATE_EPOCH}); + $_non_binnmu_date_epoch = $non_binnmu_timestamp; + return; + } +} + +# 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 { + require Cwd; + my $cwd = Cwd::getcwd(); + my $home_dir = join('/', $cwd, generated_file('_source', 'home', 0)); + my @paths = ( + $home_dir, + ); + my @clear_env = qw( + XDG_CACHE_HOME + XDG_CONFIG_DIRS + XDG_CONFIG_HOME + XDG_DATA_HOME + XDG_DATA_DIRS + XDG_RUNTIME_DIR + ); + mkdirs(@paths); + for my $envname (@clear_env) { + delete($ENV{$envname}); + } + $ENV{'HOME'} = $home_dir; + return; +} + +sub reset_buildflags { + eval { require Dpkg::BuildFlags }; + if ($@) { + warning "unable to load build flags: $@"; + return; + } + delete($ENV{'DH_INTERNAL_BUILDFLAGS'}); + my $buildflags = Dpkg::BuildFlags->new(); + foreach my $flag ($buildflags->list()) { + next unless $flag =~ /^[A-Z]/; # Skip flags starting with lowercase + delete($ENV{$flag}); + } +} + +# 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, $default) = @_; + + return $default if not 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 =~ m/^dherroron=(\S*)$/ && $wanted eq 'dherroron') { + my $value = $1; + if ($value ne 'obsolete-compat-levels') { + warning("Unknown value \"${value}\" as parameter for \"dherroron\" seen in DEB_BUILD_OPTIONS"); + } + return $value; + } elsif ($opt eq $wanted) { + return 1; + } + } + return $default; +} + +# 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; +} + + +# Called when an executable config file failed. It provides a more helpful error message in +# some cases (especially when the file was not intended to be executable). +sub _executable_dh_config_file_failed { + my ($source, $err, $proc_err) = @_; + error("Error closing fd/process for ${source}: $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($source) and not _has_shebang_line($source)) { + warning("${source} is marked executable but does not appear to an executable config."); + warning(); + warning("If ${source} is intended to be an executable config file, please ensure it can"); + warning("be run as a stand-alone script/program (e.g. \"./${source}\")"); + warning("Otherwise, please remove the executable bit from the file (e.g. chmod -x \"${source}\")"); + warning(); + warning('Please see "Executable debhelper config files" in debhelper(7) for more information.'); + warning(); + } + $? = $proc_err; + error_exitcode("${source} (executable config)"); + return; +} + + +# 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) +sub install_dh_config_file { + my ($source, $target) = @_; + + if (!compat(8) and -x $source) { + my @sstat = stat(_) || error("cannot stat $source: $!"); + open(my $tfd, '>', $target) || error("cannot open $target: $!"); + chmod(0644, $tfd) || error("cannot chmod $target: $!"); + open(my $sfd, '-|', $source) || error("cannot run $source: $!"); + while (my $line = <$sfd>) { + print ${tfd} $line; + } + if (!close($sfd)) { + _executable_dh_config_file_failed($source, $!, $?); + } + close($tfd) || error("cannot close $target: $!"); + # Set the mtime (and atime) to ensure reproducibility. + utime($sstat[9], $sstat[9], $target); + } else { + install_file($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; + mkdirs($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 ($clear_index) = @_; + 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); + rm_files($bucket_index) if $clear_index; + 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 $tool = $TOOL_NAME; + if (ref($package) eq 'HASH') { + my $options = $package; + $tool = $options->{'tool_name'} // error('Missing mandatory "tool_name" option for log_installed_files'); + $package = $options->{'package'} // error('Missing mandatory "package" option for log_installed_files'); + } + + my $log = generated_file($package, 'installed-by-' . $tool); + 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_shebang_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; +} + +sub is_known_package { + my ($package) = @_; + state %known_packages = map { $_ => 1 } getpackages(); + 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; +} + + +sub _internal_optional_file_args { + state $_disable_file_seccomp; + 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 |