shell bypass 403
UnknownSec Shell
:
/
usr
/
share
/
perl5
/
Debian
/
Debhelper
/ [
drwxr-xr-x
]
upload
mass deface
mass delete
console
info server
name :
Dh_Lib.pm
#!/usr/bin/perl # # Library functions for debhelper programs, perl version. # # Joey Hess, GPL copyright 1997-2008. package Debian::Debhelper::Dh_Lib; use 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 => 13; # 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' => 'ddeb', # 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'; # Initialize with no color, so we are guaranteed to only do this once. $_use_color = 0; if ($mode eq 'auto') { $_use_color = 1 if -t *STDOUT or -t *STDERR; } elsif ($mode eq 'always') { $_use_color = 1; } 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, %package_t64_compat, %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 = %package_t64_compat = (); %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'); if ($package_types{$package} eq 'udeb' and !defined($build_profiles)) { $build_profiles = '<!noudeb>'; } $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; $package_t64_compat{$package} = _strip_spaces($field_values{'x-time64-compat'} // ''); 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}; } sub t64_compat_name { my ($package) = @_; if (! exists $package_t64_compat{$package}) { warning "package $package is not in control info"; return ''; } return $package_t64_compat{$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{/\.}) { # 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
© 2026 UnknownSec