From 1a42a93b11c48e696446250f2a1f1ca71b350e9b Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Tue, 14 May 2024 22:15:44 +0200 Subject: Adding upstream version 13.3.4. Signed-off-by: Daniel Baumann --- lib/Debian/Debhelper/Buildsystem.pm | 605 ++++ lib/Debian/Debhelper/Buildsystem/ant.pm | 52 + lib/Debian/Debhelper/Buildsystem/autoconf.pm | 92 + lib/Debian/Debhelper/Buildsystem/cmake.pm | 178 ++ lib/Debian/Debhelper/Buildsystem/makefile.pm | 198 ++ lib/Debian/Debhelper/Buildsystem/meson.pm | 139 + lib/Debian/Debhelper/Buildsystem/ninja.pm | 90 + lib/Debian/Debhelper/Buildsystem/perl_build.pm | 97 + lib/Debian/Debhelper/Buildsystem/perl_makemaker.pm | 104 + .../Debhelper/Buildsystem/python_distutils.pm | 214 ++ lib/Debian/Debhelper/Buildsystem/qmake.pm | 103 + lib/Debian/Debhelper/Buildsystem/qmake_qt4.pm | 15 + lib/Debian/Debhelper/DH/AddonAPI.pm | 220 ++ lib/Debian/Debhelper/DH/SequenceState.pm | 31 + lib/Debian/Debhelper/Dh_Buildsystems.pm | 315 +++ lib/Debian/Debhelper/Dh_Getopt.pm | 333 +++ lib/Debian/Debhelper/Dh_Lib.pm | 2969 ++++++++++++++++++++ lib/Debian/Debhelper/Sequence.pm | 131 + lib/Debian/Debhelper/Sequence/build_stamp.pm | 10 + lib/Debian/Debhelper/Sequence/dwz.pm | 14 + lib/Debian/Debhelper/Sequence/elf_tools.pm | 14 + lib/Debian/Debhelper/Sequence/installinitramfs.pm | 14 + lib/Debian/Debhelper/Sequence/python_support.pm | 10 + lib/Debian/Debhelper/Sequence/root_sequence.pm | 114 + lib/Debian/Debhelper/Sequence/systemd.pm | 19 + lib/Debian/Debhelper/SequencerUtil.pm | 836 ++++++ 26 files changed, 6917 insertions(+) create mode 100644 lib/Debian/Debhelper/Buildsystem.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/ant.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/autoconf.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/cmake.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/makefile.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/meson.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/ninja.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/perl_build.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/perl_makemaker.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/python_distutils.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/qmake.pm create mode 100644 lib/Debian/Debhelper/Buildsystem/qmake_qt4.pm create mode 100644 lib/Debian/Debhelper/DH/AddonAPI.pm create mode 100644 lib/Debian/Debhelper/DH/SequenceState.pm create mode 100644 lib/Debian/Debhelper/Dh_Buildsystems.pm create mode 100644 lib/Debian/Debhelper/Dh_Getopt.pm create mode 100644 lib/Debian/Debhelper/Dh_Lib.pm create mode 100644 lib/Debian/Debhelper/Sequence.pm create mode 100644 lib/Debian/Debhelper/Sequence/build_stamp.pm create mode 100644 lib/Debian/Debhelper/Sequence/dwz.pm create mode 100644 lib/Debian/Debhelper/Sequence/elf_tools.pm create mode 100644 lib/Debian/Debhelper/Sequence/installinitramfs.pm create mode 100644 lib/Debian/Debhelper/Sequence/python_support.pm create mode 100644 lib/Debian/Debhelper/Sequence/root_sequence.pm create mode 100644 lib/Debian/Debhelper/Sequence/systemd.pm create mode 100644 lib/Debian/Debhelper/SequencerUtil.pm (limited to 'lib/Debian') diff --git a/lib/Debian/Debhelper/Buildsystem.pm b/lib/Debian/Debhelper/Buildsystem.pm new file mode 100644 index 0000000..47d9b7e --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem.pm @@ -0,0 +1,605 @@ +# Defines debhelper build system class interface and implementation +# of common functionality. +# +# Copyright: © 2008-2009 Modestas Vainius +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem; + +use strict; +use warnings; +use Cwd (); +use File::Spec; +use Debian::Debhelper::Dh_Lib; + +# Build system name. Defaults to the last component of the class +# name. Do not override this method unless you know what you are +# doing. +sub NAME { + my ($this) = @_; + my $class = ref($this); + my $target_name; + if ($class) { + # Do not assume that the target buildsystem has been provided. + # NAME could be called during an error in the constructor. + if ($this->IS_GENERATOR_BUILD_SYSTEM and $this->get_targetbuildsystem) { + $target_name = $this->get_targetbuildsystem->NAME; + } + } else { + $class = $this; + } + if ($class =~ m/^.+::([^:]+)$/) { + my $name = $1; + return "${name}+${target_name}" if defined($target_name); + return $name; + } + else { + error("Invalid build system class name: $class"); + } +} + +# Description of the build system to be shown to the users. +sub DESCRIPTION { + error("class lacking a DESCRIPTION"); +} + +# Default build directory. Can be overridden in the derived +# class if really needed. +sub DEFAULT_BUILD_DIRECTORY { + "obj-" . dpkg_architecture_value("DEB_HOST_GNU_TYPE"); +} + +# Return 1 if the build system generator +sub IS_GENERATOR_BUILD_SYSTEM { + return 0; +} + +# Generator build-systems only +# The name of the supported target systems. The first one is +# assumed to be the default if DEFAULT_TARGET_BUILD_SYSTEM is +# not overridden. +sub SUPPORTED_TARGET_BUILD_SYSTEMS { + error("class lacking SUPPORTED_TARGET_BUILD_SYSTEMS"); +} + +# Generator build-systems only +# Name of default target build system if target is unspecified +# (e.g. --buildsystem=cmake instead of cmake+makefile). +sub DEFAULT_TARGET_BUILD_SYSTEM { + my ($this) = @_; + my @targets = $this->SUPPORTED_TARGET_BUILD_SYSTEMS; + # Assume they are listed in order. + return $targets[0]; +} + +# For regular build systems, the same as DESCRIPTION +# For generator based build systems, the DESCRIPTION of the generator build +# system + the target build system. Do not override this method unless you +# know what you are doing. +sub FULL_DESCRIPTION { + my ($this) = @_; + my $description = $this->DESCRIPTION; + return $description if not exists($this->{'targetbuildsystem'}); + my $target_build_system = $this->{'targetbuildsystem'}; + return $description if not defined($target_build_system); + my $target_desc = $target_build_system->FULL_DESCRIPTION; + return "${description} combined with ${target_desc}"; +} + +# Constructs a new build system object. Named parameters: +# - sourcedir- specifies source directory (relative to the current (top) +# directory) where the sources to be built live. If not +# specified or empty, defaults to the current directory. +# - builddir - specifies build directory to use. Path is relative to the +# current (top) directory. If undef or empty, +# DEFAULT_BUILD_DIRECTORY directory will be used. +# - parallel - max number of parallel processes to be spawned for building +# sources (-1 = unlimited; 1 = no parallel) +# - targetbuildsystem - The target build system for generator based build +# systems. Only set for generator build systems. +# Derived class can override the constructor to initialize common object +# parameters. Do NOT use constructor to execute commands or otherwise +# configure/setup build environment. There is absolutely no guarantee the +# constructed object will be used to build something. Use pre_building_step(), +# $build_step() or post_building_step() methods for this. +sub new { + my ($class, %opts)=@_; + + my $this = bless({ sourcedir => '.', + builddir => undef, + parallel => undef, + cwd => Cwd::getcwd() }, $class); + + # Setup the target buildsystem early, so e.g. _set_builddir also + # applies to the target build system. Useful if the generator + # and target does not agree on (e.g.) the default build dir. + my $target_bs_name; + if (exists $opts{targetbuildsystem}) { + $target_bs_name = $opts{targetbuildsystem}; + } + + $target_bs_name //= $this->DEFAULT_TARGET_BUILD_SYSTEM if $this->IS_GENERATOR_BUILD_SYSTEM; + + if (defined($target_bs_name)) { + my %target_opts = %opts; + # Let the target know it is used as a target build system. + # E.g. the makefile has special cases based on whether it is + # the main or a target build system. + delete($target_opts{'targetbuildsystem'}); + $target_opts{'_is_targetbuildsystem'} = 1; + my $target_system =_create_buildsystem_instance($target_bs_name, 1, %target_opts); + $this->set_targetbuildsystem($target_system); + } + + $this->{'_is_targetbuildsystem'} = $opts{'_is_targetbuildsystem'} + if exists($opts{'_is_targetbuildsystem'}); + + if (exists $opts{sourcedir}) { + # Get relative sourcedir abs_path (without symlinks) + my $abspath = Cwd::abs_path($opts{sourcedir}); + if (! -d $abspath || $abspath !~ /^\Q$this->{cwd}\E/) { + error("invalid or non-existing path to the source directory: ".$opts{sourcedir}); + } + $this->{sourcedir} = File::Spec->abs2rel($abspath, $this->{cwd}); + } + if (exists $opts{builddir}) { + $this->_set_builddir($opts{builddir}); + } + if (defined $opts{parallel}) { + $this->{parallel} = $opts{parallel}; + } + + return $this; +} + +# Private method to set a build directory. If undef, use default. +# Do $this->{builddir} = undef or pass $this->get_sourcedir() to +# unset the build directory. +sub _set_builddir { + my $this=shift; + my $builddir=shift || $this->DEFAULT_BUILD_DIRECTORY; + + if (defined $builddir) { + $builddir = $this->canonpath($builddir); # Canonicalize + + # Sanitize $builddir + if ($builddir =~ m#^\.\./#) { + # We can't handle those as relative. Make them absolute + $builddir = File::Spec->catdir($this->{cwd}, $builddir); + } + elsif ($builddir =~ /\Q$this->{cwd}\E/) { + $builddir = File::Spec->abs2rel($builddir, $this->{cwd}); + } + + # If build directory ends up the same as source directory, drop it + if ($builddir eq $this->get_sourcedir()) { + $builddir = undef; + } + } + $this->{builddir} = $builddir; + # Use get as guard because this method is (also) called from the + # constructor before the target build system is setup. + if ($this->get_targetbuildsystem) { + $this->get_targetbuildsystem->{builddir} = $builddir; + }; + return $builddir; +} + +sub set_targetbuildsystem { + my ($this, $target_system) = @_; + my $ok = 0; + my $target_bs_name = $target_system->NAME; + if (not $this->IS_GENERATOR_BUILD_SYSTEM) { + my $name = $this->NAME; + error("Cannot set a target build system: Buildsystem ${name} is not a generator build system"); + } + for my $supported_bs_name ($this->SUPPORTED_TARGET_BUILD_SYSTEMS) { + if ($supported_bs_name eq $target_bs_name) { + $ok = 1; + last; + } + } + if (not $ok) { + my $name = $this->NAME; + error("Buildsystem ${name} does not support ${target_bs_name} as target build system."); + } + $this->{'targetbuildsystem'} = $target_system +} + +sub _is_targetbuildsystem { + my ($this) = @_; + return 0 if not exists($this->{'_is_targetbuildsystem'}); + return $this->{'_is_targetbuildsystem'}; +} + +# Returns the target build system if it is provided +sub get_targetbuildsystem { + my $this = shift; + return if not exists($this->{'targetbuildsystem'}); + return $this->{'targetbuildsystem'}; +} + +# This instance method is called to check if the build system is able +# to build a source package. It will be called during the build +# system auto-selection process, inside the root directory of the debian +# source package. The current build step is passed as an argument. +# Return 0 if the source is not buildable, or a positive integer +# otherwise. +# +# Generally, it is enough to look for invariant unique build system +# files shipped with clean source to determine if the source might +# be buildable or not. However, if the build system is derived from +# another other auto-buildable build system, this method +# may also check if the source has already been built with this build +# system partially by looking for temporary files or other common +# results the build system produces during the build process. The +# latter checks must be unique to the current build system and must +# be very unlikely to be true for either its parent or other build +# systems. If it is determined that the source has already built +# partially with this build system, the value returned must be +# greater than the one of the SUPER call. +sub check_auto_buildable { + my $this=shift; + my ($step)=@_; + return 0; +} + +# Derived class can call this method in its constructor +# to enforce in source building even if the user requested otherwise. +sub enforce_in_source_building { + my $this=shift; + if ($this->get_builddir()) { + $this->{warn_insource} = 1; + $this->{builddir} = undef; + } + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->enforce_in_source_building(@_); + # Only warn in one build system. + delete($this->{warn_insource}); + } +} + +# Derived class can call this method in its constructor to *prefer* +# out of source building. Unless build directory has already been +# specified building will proceed in the DEFAULT_BUILD_DIRECTORY or +# the one specified in the 'builddir' named parameter (which may +# match the source directory). Typically you should pass @_ from +# the constructor to this call. +sub prefer_out_of_source_building { + my $this=shift; + my %args=@_; + if (!defined $this->get_builddir()) { + if (!$this->_set_builddir($args{builddir}) && !$args{builddir}) { + # If we are here, DEFAULT_BUILD_DIRECTORY matches + # the source directory, building might fail. + error("default build directory is the same as the source directory." . + " Please specify a custom build directory"); + } + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->prefer_out_of_source_building(@_); + } + } +} + +# Enhanced version of File::Spec::canonpath. It collapses .. +# too so it may return invalid path if symlinks are involved. +# On the other hand, it does not need for the path to exist. +sub canonpath { + my ($this, $path)=@_; + my @canon; + my $back=0; + foreach my $comp (split(m%/+%, $path)) { + if ($comp eq '.') { + next; + } + elsif ($comp eq '..') { + if (@canon > 0) { pop @canon; } else { $back++; } + } + else { + push @canon, $comp; + } + } + return (@canon + $back > 0) ? join('/', ('..')x$back, @canon) : '.'; +} + +# Given both $path and $base are relative to the $root, converts and +# returns path of $path being relative to the $base. If either $path or +# $base is absolute, returns another $path (converted to) absolute. +sub _rel2rel { + my ($this, $path, $base, $root)=@_; + $root = $this->{cwd} unless defined $root; + + if (File::Spec->file_name_is_absolute($path)) { + return $path; + } + elsif (File::Spec->file_name_is_absolute($base)) { + return File::Spec->rel2abs($path, $root); + } + else { + return File::Spec->abs2rel( + File::Spec->rel2abs($path, $root), + File::Spec->rel2abs($base, $root) + ); + } +} + +# Get path to the source directory +# (relative to the current (top) directory) +sub get_sourcedir { + my $this=shift; + return $this->{sourcedir}; +} + +# Convert path relative to the source directory to the path relative +# to the current (top) directory. +sub get_sourcepath { + my ($this, $path)=@_; + return File::Spec->catfile($this->get_sourcedir(), $path); +} + +# Get path to the build directory if it was specified +# (relative to the current (top) directory). undef if the same +# as the source directory. +sub get_builddir { + my $this=shift; + return $this->{builddir}; +} + +# Convert path that is relative to the build directory to the path +# that is relative to the current (top) directory. +# If $path is not specified, always returns build directory path +# relative to the current (top) directory regardless if builddir was +# specified or not. +sub get_buildpath { + my ($this, $path)=@_; + my $builddir = $this->get_builddir() || $this->get_sourcedir(); + if (defined $path) { + return File::Spec->catfile($builddir, $path); + } + return $builddir; +} + +# When given a relative path to the source directory, converts it +# to the path that is relative to the build directory. If $path is +# not given, returns a path to the source directory that is relative +# to the build directory. +sub get_source_rel2builddir { + my $this=shift; + my $path=shift; + + my $dir = '.'; + if ($this->get_builddir()) { + $dir = $this->_rel2rel($this->get_sourcedir(), $this->get_builddir()); + } + if (defined $path) { + return File::Spec->catfile($dir, $path); + } + return $dir; +} + +sub get_parallel { + my $this=shift; + return $this->{parallel}; +} + +# This parallel support for the given step +sub disable_parallel { + my ($this) = @_; + $this->{parallel} = 1; + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->disable_parallel; + } +} + +# When given a relative path to the build directory, converts it +# to the path that is relative to the source directory. If $path is +# not given, returns a path to the build directory that is relative +# to the source directory. +sub get_build_rel2sourcedir { + my $this=shift; + my $path=shift; + + my $dir = '.'; + if ($this->get_builddir()) { + $dir = $this->_rel2rel($this->get_builddir(), $this->get_sourcedir()); + } + if (defined $path) { + return File::Spec->catfile($dir, $path); + } + return $dir; +} + +# Creates a build directory. +sub mkdir_builddir { + my $this=shift; + if ($this->get_builddir()) { + install_dir($this->get_builddir()); + } +} + +sub check_auto_buildable_clean_oos_buildir { + my $this = shift; + my ($step) = @_; + # This only applies to clean + return 0 if $step ne 'clean'; + my $builddir = $this->get_builddir; + # If there is no builddir, then this rule does not apply. + return 0 if not defined($builddir) or not -d $builddir; + return 1; +} + +sub _generic_doit_in_dir { + my ($this, $dir, $sub, @args) = @_; + my %args; + if (ref($args[0])) { + %args = %{shift(@args)}; + } + $args{chdir} = $dir; + return $sub->(\%args, @args); +} + +# Changes working directory to the source directory (if needed), +# calls print_and_doit(@_) and changes working directory back to the +# top directory. +sub doit_in_sourcedir { + my ($this, @args) = @_; + $this->_generic_doit_in_dir($this->get_sourcedir, \&print_and_doit, @args); + return 1; +} + +# Changes working directory to the source directory (if needed), +# calls print_and_doit(@_) and changes working directory back to the +# top directory. Errors are ignored. +sub doit_in_sourcedir_noerror { + my ($this, @args) = @_; + return $this->_generic_doit_in_dir($this->get_sourcedir, \&print_and_doit_noerror, @args); +} + +# Changes working directory to the build directory (if needed), +# calls print_and_doit(@_) and changes working directory back to the +# top directory. +sub doit_in_builddir { + my ($this, @args) = @_; + $this->_generic_doit_in_dir($this->get_buildpath, \&print_and_doit, @args); + return 1; +} + +# Changes working directory to the build directory (if needed), +# calls print_and_doit(@_) and changes working directory back to the +# top directory. Errors are ignored. +sub doit_in_builddir_noerror { + my ($this, @args) = @_; + return $this->_generic_doit_in_dir($this->get_buildpath, \&print_and_doit_noerror, @args); +} + +# In case of out of source tree building, whole build directory +# gets wiped (if it exists) and 1 is returned. If build directory +# had 2 or more levels, empty parent directories are also deleted. +# If build directory does not exist, nothing is done and 0 is returned. +sub rmdir_builddir { + my $this=shift; + my $only_empty=shift; + if ($this->get_builddir()) { + my $buildpath = $this->get_buildpath(); + if (-d $buildpath) { + my @dir = File::Spec->splitdir($this->get_build_rel2sourcedir()); + my $peek; + if (not $only_empty) { + doit("rm", "-rf", $buildpath); + pop @dir; + } + # If build directory is relative and had 2 or more levels, delete + # empty parent directories until the source or top directory level. + if (not File::Spec->file_name_is_absolute($buildpath)) { + while (($peek=pop @dir) && $peek ne '.' && $peek ne '..') { + my $dir = $this->get_sourcepath(File::Spec->catdir(@dir, $peek)); + doit("rmdir", "--ignore-fail-on-non-empty", $dir); + last if -d $dir; + } + } + } + return 1; + } + return 0; +} + +# Instance method that is called before performing any step (see below). +# Action name is passed as an argument. Derived classes overriding this +# method should also call SUPER implementation of it. +sub pre_building_step { + my $this=shift; + my ($step)=@_; + + # Warn if in source building was enforced but build directory was + # specified. See enforce_in_source_building(). + if ($this->{warn_insource}) { + warning("warning: " . $this->NAME() . + " does not support building out of source tree. In source building enforced."); + delete $this->{warn_insource}; + } + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->pre_building_step(@_); + } +} + +# Instance method that is called after performing any step (see below). +# Action name is passed as an argument. Derived classes overriding this +# method should also call SUPER implementation of it. +sub post_building_step { + my $this=shift; + my ($step)=@_; + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->post_building_step(@_); + } +} + +# The instance methods below provide support for configuring, +# building, testing, install and cleaning source packages. +# In case of failure, the method may just error() out. +# +# These methods should be overridden by derived classes to +# implement build system specific steps needed to build the +# source. Arbitrary number of custom step arguments might be +# passed. Default implementations do nothing. +# +# Note: For generator build systems, the default is to +# delegate the step to the target build system for all +# steps except configure. +sub configure { + my $this=shift; +} + +sub build { + my $this=shift; + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->build(@_); + } +} + +sub test { + my $this=shift; + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->test(@_); + } +} + +# destdir parameter specifies where to install files. +sub install { + my $this=shift; + my ($destdir) = @_; + + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->install(@_); + } +} + +sub clean { + my $this=shift; + + if ($this->IS_GENERATOR_BUILD_SYSTEM) { + $this->get_targetbuildsystem->clean(@_); + } +} + + +sub _create_buildsystem_instance { + my ($full_name, $required, %bsopts) = @_; + my @parts = split(m{[+]}, $full_name, 2); + my $name = $parts[0]; + my $module = "Debian::Debhelper::Buildsystem::$name"; + if (@parts > 1) { + if (exists($bsopts{'targetbuildsystem'})) { + error("Conflicting target buildsystem for ${name} (load as ${full_name}, but target configured in bsopts)"); + } + $bsopts{'targetbuildsystem'} = $parts[1]; + } + + eval "use $module"; + if ($@) { + return if not $required; + error("unable to load build system class '$name': $@"); + } + return $module->new(%bsopts); +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/ant.pm b/lib/Debian/Debhelper/Buildsystem/ant.pm new file mode 100644 index 0000000..49aaf1e --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/ant.pm @@ -0,0 +1,52 @@ +# A debhelper build system class for handling Ant based projects. +# +# Copyright: © 2009 Joey Hess +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::ant; + +use strict; +use warnings; +use parent qw(Debian::Debhelper::Buildsystem); + +sub DESCRIPTION { + "Ant (build.xml)" +} + +sub check_auto_buildable { + my $this=shift; + return (-e $this->get_sourcepath("build.xml")) ? 1 : 0; +} + +sub new { + my $class=shift; + my $this=$class->SUPER::new(@_); + $this->enforce_in_source_building(); + return $this; +} + +sub build { + my $this=shift; + my $d_ant_prop = $this->get_sourcepath('debian/ant.properties'); + my @args; + if ( -f $d_ant_prop ) { + push(@args, '-propertyfile', $d_ant_prop); + } + + # Set the username to improve the reproducibility + push(@args, "-Duser.name", "debian"); + + $this->doit_in_sourcedir("ant", @args, @_); +} + +sub clean { + my $this=shift; + my $d_ant_prop = $this->get_sourcepath('debian/ant.properties'); + my @args; + if ( -f $d_ant_prop ) { + push(@args, '-propertyfile', $d_ant_prop); + } + $this->doit_in_sourcedir("ant", @args, "clean", @_); +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/autoconf.pm b/lib/Debian/Debhelper/Buildsystem/autoconf.pm new file mode 100644 index 0000000..3b25008 --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/autoconf.pm @@ -0,0 +1,92 @@ +# A debhelper build system class for handling Autoconf based projects +# +# Copyright: © 2008 Joey Hess +# © 2008-2009 Modestas Vainius +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::autoconf; + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(%dh dpkg_architecture_value sourcepackage compat); +use parent qw(Debian::Debhelper::Buildsystem::makefile); + +sub DESCRIPTION { + "GNU Autoconf (configure)" +} + +sub check_auto_buildable { + my $this=shift; + my ($step)=@_; + + return 0 unless -f $this->get_sourcepath("configure") && + -x _; + + # Handle configure explicitly; inherit the rest + return 1 if $step eq "configure"; + return $this->SUPER::check_auto_buildable(@_); +} + +sub configure { + my $this=shift; + + # Standard set of options for configure. + my @opts; + push @opts, "--build=" . dpkg_architecture_value("DEB_BUILD_GNU_TYPE"); + push @opts, "--prefix=/usr"; + push @opts, "--includedir=\${prefix}/include"; + push @opts, "--mandir=\${prefix}/share/man"; + push @opts, "--infodir=\${prefix}/share/info"; + push @opts, "--sysconfdir=/etc"; + push @opts, "--localstatedir=/var"; + # We pass --disable/enable-* options that might be unknown, so we + # should not emit warnings. + push @opts, "--disable-option-checking"; + if ($dh{QUIET}) { + push @opts, "--enable-silent-rules"; + } else { + push @opts, "--disable-silent-rules"; + } + my $multiarch=dpkg_architecture_value("DEB_HOST_MULTIARCH"); + if (! compat(8)) { + if (defined $multiarch) { + push @opts, "--libdir=\${prefix}/lib/$multiarch"; + push(@opts, "--libexecdir=\${prefix}/lib/$multiarch") if compat(11); + } + else { + push(@opts, "--libexecdir=\${prefix}/lib") if compat(11); + } + } + else { + push @opts, "--libexecdir=\${prefix}/lib/" . sourcepackage(); + } + push @opts, "--runstatedir=/run" if not compat(10); + push @opts, "--disable-maintainer-mode"; + push @opts, "--disable-dependency-tracking"; + # Provide --host only if different from --build, as recommended in + # autotools-dev README.Debian: When provided (even if equal) + # autoconf 2.52+ switches to cross-compiling mode. + if (dpkg_architecture_value("DEB_BUILD_GNU_TYPE") + ne dpkg_architecture_value("DEB_HOST_GNU_TYPE")) { + push @opts, "--host=" . dpkg_architecture_value("DEB_HOST_GNU_TYPE"); + } + + $this->mkdir_builddir(); + eval { + $this->doit_in_builddir($this->get_source_rel2builddir("configure"), @opts, @_); + }; + if ($@) { + if (-e $this->get_buildpath("config.log")) { + $this->doit_in_builddir('tail', '-v', '-n', '+0', 'config.log'); + } + die $@; + } +} + +sub test { + my $this=shift; + $this->make_first_existing_target(['test', 'check'], + "VERBOSE=1", @_); +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/cmake.pm b/lib/Debian/Debhelper/Buildsystem/cmake.pm new file mode 100644 index 0000000..aa1d0c3 --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/cmake.pm @@ -0,0 +1,178 @@ +# A debhelper build system class for handling CMake based projects. +# It prefers out of source tree building. +# +# Copyright: © 2008-2009 Modestas Vainius +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::cmake; + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(%dh compat dpkg_architecture_value error is_cross_compiling); +use parent qw(Debian::Debhelper::Buildsystem); + +my @STANDARD_CMAKE_FLAGS = qw( + -DCMAKE_INSTALL_PREFIX=/usr + -DCMAKE_BUILD_TYPE=None + -DCMAKE_INSTALL_SYSCONFDIR=/etc + -DCMAKE_INSTALL_LOCALSTATEDIR=/var + -DCMAKE_EXPORT_NO_PACKAGE_REGISTRY=ON + -DCMAKE_FIND_PACKAGE_NO_PACKAGE_REGISTRY=ON +); + +my %DEB_HOST2CMAKE_SYSTEM = ( + 'linux' => 'Linux', + 'kfreebsd' => 'kFreeBSD', + 'hurd' => 'GNU', +); + +my %GNU_CPU2SYSTEM_PROCESSOR = ( + 'arm' => 'armv7l', + 'mips64el' => 'mips64', + 'powerpc64le' => 'ppc64le', +); + +my %TARGET_BUILD_SYSTEM2CMAKE_GENERATOR = ( + 'makefile' => 'Unix Makefiles', + 'ninja' => 'Ninja', +); + +sub DESCRIPTION { + "CMake (CMakeLists.txt)" +} + +sub IS_GENERATOR_BUILD_SYSTEM { + return 1; +} + +sub SUPPORTED_TARGET_BUILD_SYSTEMS { + return qw(makefile ninja); +} + +sub check_auto_buildable { + my $this=shift; + my ($step)=@_; + if (-e $this->get_sourcepath("CMakeLists.txt")) { + my $ret = ($step eq "configure" && 1) || + $this->get_targetbuildsystem->check_auto_buildable(@_); + if ($this->check_auto_buildable_clean_oos_buildir(@_)) { + # Assume that the package can be cleaned (i.e. the build directory can + # be removed) as long as it is built out-of-source tree and can be + # configured. + $ret++ if not $ret; + } + # Existence of CMakeCache.txt indicates cmake has already + # been used by a prior build step, so should be used + # instead of the parent makefile class. + $ret++ if ($ret && -e $this->get_buildpath("CMakeCache.txt")); + return $ret; + } + return 0; +} + +sub new { + my $class=shift; + my $this=$class->SUPER::new(@_); + $this->prefer_out_of_source_building(@_); + return $this; +} + +sub configure { + my $this=shift; + # Standard set of cmake flags + my @flags = @STANDARD_CMAKE_FLAGS; + my $backend = $this->get_targetbuildsystem->NAME; + + push(@flags, '-DCMAKE_INSTALL_RUNSTATEDIR=/run') if not compat(10); + # Speed up installation phase a bit. + push(@flags, "-DCMAKE_SKIP_INSTALL_ALL_DEPENDENCY=ON") if not compat(12); + # Reproducibility #962474 + push(@flags, "-DCMAKE_SKIP_RPATH=ON", '-DCMAKE_BUILD_RPATH_USE_ORIGIN=ON') if not compat(13); + if (exists($TARGET_BUILD_SYSTEM2CMAKE_GENERATOR{$backend})) { + my $generator = $TARGET_BUILD_SYSTEM2CMAKE_GENERATOR{$backend}; + push(@flags, "-G${generator}"); + } + if (not $dh{QUIET}) { + push(@flags, "-DCMAKE_VERBOSE_MAKEFILE=ON"); + } + + if ($ENV{CC}) { + push @flags, "-DCMAKE_C_COMPILER=" . $ENV{CC}; + } + if ($ENV{CXX}) { + push @flags, "-DCMAKE_CXX_COMPILER=" . $ENV{CXX}; + } + if (is_cross_compiling()) { + my $deb_host = dpkg_architecture_value("DEB_HOST_ARCH_OS"); + if (my $cmake_system = $DEB_HOST2CMAKE_SYSTEM{$deb_host}) { + push(@flags, "-DCMAKE_SYSTEM_NAME=${cmake_system}"); + } else { + error("Cannot cross-compile - CMAKE_SYSTEM_NAME not known for ${deb_host}"); + } + my $gnu_cpu = dpkg_architecture_value("DEB_HOST_GNU_CPU"); + if (exists($GNU_CPU2SYSTEM_PROCESSOR{$gnu_cpu})) { + push @flags, "-DCMAKE_SYSTEM_PROCESSOR=" . $GNU_CPU2SYSTEM_PROCESSOR{$gnu_cpu}; + } else { + push @flags, "-DCMAKE_SYSTEM_PROCESSOR=${gnu_cpu}"; + } + if (not $ENV{CC}) { + push @flags, "-DCMAKE_C_COMPILER=" . dpkg_architecture_value("DEB_HOST_GNU_TYPE") . "-gcc"; + } + if (not $ENV{CXX}) { + push @flags, "-DCMAKE_CXX_COMPILER=" . dpkg_architecture_value("DEB_HOST_GNU_TYPE") . "-g++"; + } + push(@flags, "-DPKG_CONFIG_EXECUTABLE=/usr/bin/" . dpkg_architecture_value("DEB_HOST_GNU_TYPE") . "-pkg-config"); + push(@flags, "-DPKGCONFIG_EXECUTABLE=/usr/bin/" . dpkg_architecture_value("DEB_HOST_GNU_TYPE") . "-pkg-config"); + push(@flags, "-DQMAKE_EXECUTABLE=/usr/bin/" . dpkg_architecture_value("DEB_HOST_GNU_TYPE") . "-qmake"); + } + push(@flags, "-DCMAKE_INSTALL_LIBDIR=lib/" . dpkg_architecture_value("DEB_HOST_MULTIARCH")); + + # CMake doesn't respect CPPFLAGS, see #653916. + if ($ENV{CPPFLAGS} && ! compat(8)) { + $ENV{CFLAGS} .= ' ' . $ENV{CPPFLAGS}; + $ENV{CXXFLAGS} .= ' ' . $ENV{CPPFLAGS}; + } + + $this->mkdir_builddir(); + eval { + $this->doit_in_builddir("cmake", @flags, @_, $this->get_source_rel2builddir()); + }; + if (my $err = $@) { + if (-e $this->get_buildpath("CMakeCache.txt")) { + $this->doit_in_builddir('tail', '-v', '-n', '+0', 'CMakeCache.txt'); + } + if (-e $this->get_buildpath('CMakeFiles/CMakeOutput.log')) { + $this->doit_in_builddir('tail', '-v', '-n', '+0', 'CMakeFiles/CMakeOutput.log'); + } + if (-e $this->get_buildpath('CMakeFiles/CMakeError.log')) { + $this->doit_in_builddir('tail', '-v', '-n', '+0', 'CMakeFiles/CMakeError.log'); + } + die $err; + } +} + +sub build { + my $this=shift; + my $target = $this->get_targetbuildsystem; + if ($target->NAME eq 'makefile') { + # Add VERBOSE=1 for #973029 when not asked to be quiet/terse. + push(@_, "VERBOSE=1") if not $dh{QUIET}; + } + return $this->SUPER::build(@_); +} + +sub test { + my $this=shift; + my $target = $this->get_targetbuildsystem; + $ENV{CTEST_OUTPUT_ON_FAILURE} = 1; + if ($target->NAME eq 'makefile') { + # Unlike make, CTest does not have "unlimited parallel" setting (-j implies + # -j1). So in order to simulate unlimited parallel, allow to fork a huge + # number of threads instead. + my $parallel = ($this->get_parallel() > 0) ? $this->get_parallel() : 999; + push(@_, "ARGS+=-j$parallel"); + } + return $this->SUPER::test(@_); +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/makefile.pm b/lib/Debian/Debhelper/Buildsystem/makefile.pm new file mode 100644 index 0000000..64b7c6b --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/makefile.pm @@ -0,0 +1,198 @@ +# A debhelper build system class for handling simple Makefile based projects. +# +# Copyright: © 2008 Joey Hess +# © 2008-2009 Modestas Vainius +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::makefile; + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(dpkg_architecture_value escape_shell clean_jobserver_makeflags is_cross_compiling compat + should_use_root gain_root_cmd error); +use parent qw(Debian::Debhelper::Buildsystem); + +my %DEB_DEFAULT_TOOLS = ( + 'CC' => 'gcc', + 'CXX' => 'g++', + 'PKG_CONFIG' => 'pkg-config', +); + +# make makes things difficult by not providing a simple way to test +# whether a Makefile target exists. Using -n and checking for a nonzero +# exit status is not good enough, because even with -n, make will +# run commands needed to eg, generate include files -- and those commands +# could fail even though the target exists -- and we should let the target +# run and propagate any failure. +# +# Using -n and checking for at least one line of output is better. +# That will indicate make either wants to run one command, or +# has output a "nothing to be done" message if the target exists but is a +# noop. +# +# However, that heuristic is also not good enough, because a Makefile +# could run code that outputs something, even though the -n is asking +# it not to run anything. (Again, done for includes.) To detect this false +# positive, there is unfortunately only one approach left: To +# look for the error message printed by make when a target does not exist. +# +# This could break if make's output changes. It would only break a minority +# of packages where this latter test is needed. The best way to avoid that +# problem would be to fix make to have this simple and highly useful +# missing feature. +# +# A final option would be to use -p and parse the output data base. +# It's more practical for dh to use that method, since it operates on +# only special debian/rules files, and not arbitrary Makefiles which +# can be arbitrarily complicated, use implicit targets, and so on. +sub exists_make_target { + my $this=shift; + my $target=shift; + + my @opts=("-s", "-n", "--no-print-directory"); + my $buildpath = $this->get_buildpath(); + unshift @opts, "-C", $buildpath if $buildpath ne "."; + + my $pid = open(MAKE, "-|"); + defined($pid) || error("fork failed: $!"); + if (! $pid) { + open(STDERR, ">&STDOUT"); + $ENV{LC_ALL}='C'; + exec($this->{makecmd}, @opts, $target, @_); + exit(1); + } + + local $/=undef; + my $output=; + chomp $output; + close MAKE; + + return defined $output + && length $output + && $output !~ /\*\*\* No rule to make target (`|')\Q$target\E'/; +} + +sub do_make { + my $this=shift; + + # Avoid possible warnings about unavailable jobserver, + # and force make to start a new jobserver. + clean_jobserver_makeflags(); + + # Note that this will override any -j settings in MAKEFLAGS. + my $parallel = $this->get_parallel(); + if ($parallel == 0 or $parallel > 1) { + # We have to use the empty string for "unlimited" + $parallel = '' if $parallel == 0; + unshift(@_, "-j${parallel}"); + } else { + unshift(@_, '-j1'); + } + + my @root_cmd; + if (exists($this->{_run_make_as_root}) and $this->{_run_make_as_root}) { + @root_cmd = gain_root_cmd(); + } + $this->doit_in_builddir(@root_cmd, $this->{makecmd}, @_); +} + +sub make_first_existing_target { + my $this=shift; + my $targets=shift; + + foreach my $target (@$targets) { + if ($this->exists_make_target($target, @_)) { + $this->do_make($target, @_); + return $target; + } + } + return undef; +} + +sub DESCRIPTION { + "simple Makefile" +} + +sub new { + my $class=shift; + my $this=$class->SUPER::new(@_); + $this->{makecmd} = (exists $ENV{MAKE}) ? $ENV{MAKE} : "make"; + return $this; +} + +sub check_auto_buildable { + my $this=shift; + my ($step) = @_; + + if (-e $this->get_buildpath("Makefile") || + -e $this->get_buildpath("makefile") || + -e $this->get_buildpath("GNUmakefile")) + { + # This is always called in the source directory, but generally + # Makefiles are created (or live) in the build directory. + return 1; + } elsif ($this->check_auto_buildable_clean_oos_buildir(@_) + and $this->check_auto_buildable('configure')) { + # Assume that the package can be cleaned (i.e. the build directory can + # be removed) as long as it is built out-of-source tree and can be + # configured. This is useful for derivative buildsystems which + # generate Makefiles. + return 1; + } + return 0; +} + +sub build { + my $this=shift; + if (not $this->_is_targetbuildsystem + and ref($this) eq 'Debian::Debhelper::Buildsystem::makefile' + and is_cross_compiling()) { + # Only inject build tools variables during cross-compile when + # makefile is the explicit *main* build system. + for my $var (sort(keys(%DEB_DEFAULT_TOOLS))) { + my $tool = $DEB_DEFAULT_TOOLS{$var}; + if ($ENV{$var}) { + unshift @_, $var . "=" . $ENV{$var}; + } else { + unshift @_, $var . "=" . dpkg_architecture_value("DEB_HOST_GNU_TYPE") . "-" . $tool; + } + } + } + if (ref($this) eq 'Debian::Debhelper::Buildsystem::makefile' and not compat(10)) { + unshift @_, "INSTALL=install --strip-program=true"; + } + $this->do_make(@_); +} + +sub test { + my $this=shift; + $this->make_first_existing_target(['test', 'check'], @_); +} + +sub install { + my $this=shift; + my $destdir=shift; + if (ref($this) eq 'Debian::Debhelper::Buildsystem::makefile' and not compat(10)) { + unshift @_, "INSTALL=install --strip-program=true"; + } + if ( -f $this->get_buildpath('libtool')) { + $this->disable_parallel(); + } + + if (should_use_root('debhelper/upstream-make-install') and $< != 0) { + $this->{_run_make_as_root} = 1; + } + + $this->make_first_existing_target(['install'], + "DESTDIR=$destdir", + "AM_UPDATE_INFO_DIR=no", @_); +} + +sub clean { + my $this=shift; + if (!$this->rmdir_builddir()) { + $this->make_first_existing_target(['distclean', 'realclean', 'clean'], @_); + } +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/meson.pm b/lib/Debian/Debhelper/Buildsystem/meson.pm new file mode 100644 index 0000000..49fbbb6 --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/meson.pm @@ -0,0 +1,139 @@ +# A debhelper build system class for handling Meson based projects. +# +# Copyright: © 2017 Michael Biebl +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::meson; + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(compat dpkg_architecture_value is_cross_compiling doit warning error generated_file); +use parent qw(Debian::Debhelper::Buildsystem); + +sub DESCRIPTION { + "Meson (meson.build)" +} + +sub IS_GENERATOR_BUILD_SYSTEM { + return 1; +} + +sub SUPPORTED_TARGET_BUILD_SYSTEMS { + return qw(ninja); +} + + +sub check_auto_buildable { + my $this=shift; + my ($step)=@_; + + return 0 unless -e $this->get_sourcepath("meson.build"); + + # Handle configure explicitly; inherit the rest + return 1 if $step eq "configure"; + my $ret = $this->get_targetbuildsystem->check_auto_buildable(@_); + if ($ret == 0 and $this->check_auto_buildable_clean_oos_buildir(@_)) { + # Assume that the package can be cleaned (i.e. the build directory can + # be removed) as long as it is built out-of-source tree and can be + # configured. + $ret++; + } + return $ret; +} + +sub new { + my $class=shift; + my $this=$class->SUPER::new(@_); + $this->prefer_out_of_source_building(@_); + return $this; +} + +sub configure { + my $this=shift; + + # Standard set of options for meson. + my @opts = ( + '--wrap-mode=nodownload', + ); + push @opts, "--buildtype=plain"; + push @opts, "--prefix=/usr"; + push @opts, "--sysconfdir=/etc"; + push @opts, "--localstatedir=/var"; + my $multiarch=dpkg_architecture_value("DEB_HOST_MULTIARCH"); + push @opts, "--libdir=lib/$multiarch"; + push(@opts, "--libexecdir=lib/$multiarch") if compat(11); + + if (is_cross_compiling()) { + # http://mesonbuild.com/Cross-compilation.html + my $cross_file = $ENV{'DH_MESON_CROSS_FILE'}; + if (not $cross_file) { + my $debcrossgen = '/usr/share/meson/debcrossgen'; + if (not -x $debcrossgen) { + warning("Missing debcrossgen (${debcrossgen}) cannot generate a meson cross file and non was provided"); + error("Cannot cross-compile: Please use meson (>= 0.42.1) or provide a cross file via DH_MESON_CROSS_FILE"); + } + my $filename = generated_file('_source', 'meson-cross-file.conf'); + my %options = ( + stdout => '/dev/null', + update_env => { LC_ALL => 'C.UTF-8'}, + ); + doit(\%options, $debcrossgen, "-o${filename}"); + $cross_file = $filename; + } + if ($cross_file !~ m{^/}) { + # Make the file name absolute as meson will be called from the build dir. + require Cwd; + $cross_file =~ s{^\./}{}; + $cross_file = Cwd::getcwd() . "/${cross_file}"; + } + push(@opts, '--cross-file', $cross_file); + } + + $this->mkdir_builddir(); + eval { + my %options = ( + update_env => { LC_ALL => 'C.UTF-8'}, + ); + $this->doit_in_builddir(\%options, "meson", $this->get_source_rel2builddir(), @opts, @_); + }; + if ($@) { + if (-e $this->get_buildpath("meson-logs/meson-log.txt")) { + $this->doit_in_builddir('tail', '-v', '-n', '+0', 'meson-logs/meson-log.txt'); + } + die $@; + } +} + +sub test { + my $this = shift; + my $target = $this->get_targetbuildsystem; + + eval { + if (compat(12) or $target->NAME ne 'ninja') { + $target->test(@_); + } else { + # In compat 13 with meson+ninja, we prefer using "meson test" + # over "ninja test" + my %options = ( + update_env => { + 'LC_ALL' => 'C.UTF-8', + } + ); + if ($this->get_parallel() > 0) { + $options{update_env}{MESON_TESTTHREADS} = $this->get_parallel(); + } + $this->doit_in_builddir(\%options, 'meson', 'test', @_); + } + }; + if (my $err = $@) { + if (-e $this->get_buildpath("meson-logs/testlog.txt")) { + $this->doit_in_builddir('tail', '-v', '-n', '+0', 'meson-logs/testlog.txt'); + } + die $err; + } + return 1; +} + + + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/ninja.pm b/lib/Debian/Debhelper/Buildsystem/ninja.pm new file mode 100644 index 0000000..c08ff16 --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/ninja.pm @@ -0,0 +1,90 @@ +# A debhelper build system class for handling ninja based projects. +# +# Copyright: © 2017 Michael Biebl +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::ninja; + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(%dh dpkg_architecture_value); +use parent qw(Debian::Debhelper::Buildsystem); + +sub DESCRIPTION { + "Ninja (build.ninja)" +} + +sub new { + my $class=shift; + my $this=$class->SUPER::new(@_); + $this->{buildcmd} = "ninja"; + return $this; +} + +sub check_auto_buildable { + my $this=shift; + my ($step) = @_; + + if (-e $this->get_buildpath("build.ninja")) + { + # This is always called in the source directory, but generally + # Ninja files are created (or live) in the build directory. + return 1; + } + return 0; +} + +sub build { + my $this=shift; + my %options = ( + update_env => { + 'LC_ALL' => 'C.UTF-8', + } + ); + if (!$dh{QUIET}) { + unshift @_, "-v"; + } + if ($this->get_parallel() > 0) { + unshift @_, "-j" . $this->get_parallel(); + } + $this->doit_in_builddir(\%options, $this->{buildcmd}, @_); +} + +sub test { + my $this=shift; + my %options = ( + update_env => { + 'LC_ALL' => 'C.UTF-8', + } + ); + if ($this->get_parallel() > 0) { + $options{update_env}{MESON_TESTTHREADS} = $this->get_parallel(); + } + $this->doit_in_builddir(\%options, $this->{buildcmd}, "test", @_); +} + +sub install { + my $this=shift; + my $destdir=shift; + my %options = ( + update_env => { + 'LC_ALL' => 'C.UTF-8', + 'DESTDIR' => $destdir, + } + ); + $this->doit_in_builddir(\%options, $this->{buildcmd}, "install", @_); +} + +sub clean { + my $this=shift; + if (!$this->rmdir_builddir()) { + my %options = ( + update_env => { + 'LC_ALL' => 'C.UTF-8', + } + ); + $this->doit_in_builddir(\%options, $this->{buildcmd}, "clean", @_); + } +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/perl_build.pm b/lib/Debian/Debhelper/Buildsystem/perl_build.pm new file mode 100644 index 0000000..40f6d1c --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/perl_build.pm @@ -0,0 +1,97 @@ +# A build system class for handling Perl Build based projects. +# +# Copyright: © 2008-2009 Joey Hess +# © 2008-2009 Modestas Vainius +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::perl_build; + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(compat is_cross_compiling perl_cross_incdir warning); +use parent qw(Debian::Debhelper::Buildsystem); +use Config; + +sub DESCRIPTION { + "Perl Module::Build (Build.PL)" +} + +sub check_auto_buildable { + my ($this, $step) = @_; + + # Handles everything + my $ret = -e $this->get_sourcepath("Build.PL"); + if ($step ne "configure") { + $ret &&= -e $this->get_sourcepath("Build"); + } + return $ret ? 1 : 0; +} + +sub do_perl { + my $this=shift; + my %options; + if (is_cross_compiling()) { + my $cross_incdir = perl_cross_incdir(); + if (defined $cross_incdir) { + my $perl5lib = $cross_incdir; + $perl5lib .= $Config{path_sep} . $ENV{PERL5LIB} + if defined $ENV{PERL5LIB}; + $options{update_env} = { PERL5LIB => $perl5lib }; + } else { + warning("cross Config.pm does not exist (missing build dependency on perl-xs-dev?)"); + } + } + $this->doit_in_sourcedir(\%options, "perl", @_); +} + +sub new { + my $class=shift; + my $this= $class->SUPER::new(@_); + $this->enforce_in_source_building(); + return $this; +} + +sub configure { + my $this=shift; + my (@flags, @perl_flags); + $ENV{PERL_MM_USE_DEFAULT}=1; + if ($ENV{CFLAGS} && ! compat(8)) { + push @flags, "--config", "optimize=$ENV{CFLAGS} $ENV{CPPFLAGS}"; + } + if ($ENV{LDFLAGS} && ! compat(8)) { + my $ld = $Config{ld}; + if (is_cross_compiling()) { + my $incdir = perl_cross_incdir(); + $ld = qx/perl -I$incdir -MConfig -e 'print \$Config{ld}'/ + if defined $incdir; + } + push @flags, "--config", "ld=$ld $ENV{CFLAGS} $ENV{LDFLAGS}"; + } + push(@perl_flags, '-I.') if compat(10); + $this->do_perl(@perl_flags, "Build.PL", "--installdirs", "vendor", @flags, @_); +} + +sub build { + my $this=shift; + $this->do_perl("Build", @_); +} + +sub test { + my $this=shift; + $this->do_perl("Build", "test", "--verbose", 1, @_); +} + +sub install { + my $this=shift; + my $destdir=shift; + $this->do_perl("Build", "install", "--destdir", "$destdir", "--create_packlist", 0, @_); +} + +sub clean { + my $this=shift; + if (-e $this->get_sourcepath("Build")) { + $this->do_perl("Build", "realclean", "--allow_mb_mismatch", 1, @_); + } +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/perl_makemaker.pm b/lib/Debian/Debhelper/Buildsystem/perl_makemaker.pm new file mode 100644 index 0000000..c8c401b --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/perl_makemaker.pm @@ -0,0 +1,104 @@ +# A debhelper build system class for handling Perl MakeMaker based projects. +# +# Copyright: © 2008-2009 Joey Hess +# © 2008-2009 Modestas Vainius +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::perl_makemaker; + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(compat is_cross_compiling perl_cross_incdir warning); +use parent qw(Debian::Debhelper::Buildsystem::makefile); +use Config; + +sub DESCRIPTION { + "Perl ExtUtils::MakeMaker (Makefile.PL)" +} + +sub check_auto_buildable { + my $this=shift; + my ($step)=@_; + + # Handles everything if Makefile.PL exists. Otherwise - next class. + if (-e $this->get_sourcepath("Makefile.PL")) { + if ($step eq "configure") { + return 1; + } + else { + return $this->SUPER::check_auto_buildable(@_); + } + } + return 0; +} + +sub new { + my $class=shift; + my $this=$class->SUPER::new(@_); + $this->enforce_in_source_building(); + return $this; +} + +sub configure { + my $this=shift; + my (@flags, @perl_flags); + # If set to a true value then MakeMaker's prompt function will + # # always return the default without waiting for user input. + $ENV{PERL_MM_USE_DEFAULT}=1; + # This prevents Module::Install from interactive behavior. + $ENV{PERL_AUTOINSTALL}="--skipdeps"; + + if ($ENV{CFLAGS} && ! compat(8)) { + push @flags, "OPTIMIZE=$ENV{CFLAGS} $ENV{CPPFLAGS}"; + } + my $cross_flag; + if (is_cross_compiling()) { + my $incdir = perl_cross_incdir(); + if (defined $incdir) { + $cross_flag = "-I$incdir"; + } else { + warning("cross Config.pm does not exist (missing build dependency on perl-xs-dev?)"); + } + } + if ($ENV{LDFLAGS} && ! compat(8)) { + my $ld = $Config{ld}; + $ld = qx/perl $cross_flag -MConfig -e 'print \$Config{ld}'/ + if is_cross_compiling() and defined $cross_flag; + push @flags, "LD=$ld $ENV{CFLAGS} $ENV{LDFLAGS}"; + } + + push(@perl_flags, '-I.') if compat(10); + + push @perl_flags, $cross_flag + if is_cross_compiling() and defined $cross_flag; + + $this->doit_in_sourcedir("perl", @perl_flags, "Makefile.PL", "INSTALLDIRS=vendor", + # if perl_build is not tested first, need to pass packlist + # option to handle fallthrough case + (compat(7) ? "create_packlist=0" : ()), + @flags, @_); +} + +sub test { + my $this=shift; + # Make tests verbose + $this->SUPER::test("TEST_VERBOSE=1", @_); +} + +sub install { + my $this=shift; + my $destdir=shift; + + # Special case for Makefile.PL that uses + # Module::Build::Compat. PREFIX should not be passed + # for those; it already installs into /usr by default. + my $makefile=$this->get_sourcepath("Makefile"); + if (system(qq{grep -q "generated automatically by MakeMaker" $makefile}) != 0) { + $this->SUPER::install($destdir, @_); + } + else { + $this->SUPER::install($destdir, "PREFIX=/usr", @_); + } +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/python_distutils.pm b/lib/Debian/Debhelper/Buildsystem/python_distutils.pm new file mode 100644 index 0000000..e5fe7ed --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/python_distutils.pm @@ -0,0 +1,214 @@ +# A debhelper build system class for building Python Distutils based +# projects. It prefers out of source tree building. +# +# Copyright: © 2008 Joey Hess +# © 2008-2009 Modestas Vainius +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::python_distutils; + +use strict; +use warnings; +use Cwd (); +use Debian::Debhelper::Dh_Lib qw(error deprecated_functionality); +use parent qw(Debian::Debhelper::Buildsystem); + +sub DESCRIPTION { + "Python Distutils (setup.py) [DEPRECATED]" +} + +sub DEFAULT_BUILD_DIRECTORY { + my $this=shift; + return $this->canonpath($this->get_sourcepath("build")); +} + +sub new { + my $class=shift; + my $this=$class->SUPER::new(@_); + # Out of source tree building is preferred. + $this->prefer_out_of_source_building(@_); + return $this; +} + +sub check_auto_buildable { + my $this=shift; + return -e $this->get_sourcepath("setup.py") ? 1 : 0; +} + +sub not_our_cfg { + my $this=shift; + my $ret; + if (open(my $cfg, '<', $this->get_buildpath(".pydistutils.cfg"))) { + $ret = not "# Created by dh_auto\n" eq <$cfg>; + close $cfg; + } + return $ret; +} + +sub create_cfg { + my $this=shift; + if (open(my $cfg, ">", $this->get_buildpath(".pydistutils.cfg"))) { + print $cfg "# Created by dh_auto", "\n"; + print $cfg "[build]\nbuild-base=", $this->get_build_rel2sourcedir(), "\n"; + close $cfg; + return 1; + } + return 0; +} + +sub pre_building_step { + my $this=shift; + my $step=shift; + + deprecated_functionality('Please use the third-party "pybuild" build system instead of python-distutils', + 12); + + return unless grep /$step/, qw(build install clean); + + if ($this->get_buildpath() ne $this->DEFAULT_BUILD_DIRECTORY()) { + # --build-base can only be passed to the build command. However, + # it is always read from the config file (really weird design). + # Therefore create such a cfg config file. + # See http://bugs.python.org/issue818201 + # http://bugs.python.org/issue1011113 + not $this->not_our_cfg() or + error("cannot set custom build directory: .pydistutils.cfg is in use"); + $this->mkdir_builddir(); + $this->create_cfg() or + error("cannot set custom build directory: unwritable .pydistutils.cfg"); + # Distutils reads $HOME/.pydistutils.cfg + $ENV{HOME} = Cwd::abs_path($this->get_buildpath()); + } + + $this->SUPER::pre_building_step($step); +} + +sub dbg_build_needed { + my $this=shift; + my $act=shift; + + # Return a list of python-dbg package which are listed + # in the build-dependencies. This is kinda ugly, but building + # dbg extensions without checking if they're supposed to be + # built may result in various FTBFS if the package is not + # built in a clean chroot. + + my @dbg; + open (my $fd, '<', 'debian/control') || + error("cannot read debian/control: $!\n"); + foreach my $builddeps (join('', <$fd>) =~ + /^Build-Depends[^:]*:.*\n(?:^[^\w\n].*\n)*/gmi) { + while ($builddeps =~ /(python[^, ]*-dbg)/g) { + push @dbg, $1; + } + } + + close($fd); + return @dbg; + +} + +sub setup_py { + my $this=shift; + my $act=shift; + + # We need to run setup.py with the default python last + # as distutils/setuptools modifies the shebang lines of scripts. + # This ensures that #!/usr/bin/python is installed last and + # not pythonX.Y + # Take into account that the default Python must not be in + # the requested Python versions. + # Then, run setup.py with each available python, to build + # extensions for each. + + my $python_default = `pyversions -d`; + if ($? == -1) { + error("failed to run pyversions") + } + my $ecode = $? >> 8; + if ($ecode != 0) { + error("pyversions -d failed [$ecode]") + } + $python_default =~ s/^\s+//; + $python_default =~ s/\s+$//; + my @python_requested = split ' ', `pyversions -r`; + if ($? == -1) { + error("failed to run pyversions") + } + $ecode = $? >> 8; + if ($ecode != 0) { + error("pyversions -r failed [$ecode]") + } + if (grep /^\Q$python_default\E/, @python_requested) { + @python_requested = ( + grep(!/^\Q$python_default\E/, @python_requested), + "python", + ); + } + + my @python_dbg; + my @dbg_build_needed = $this->dbg_build_needed(); + foreach my $python (map { $_."-dbg" } @python_requested) { + if (grep /^(python-all-dbg|\Q$python\E)/, @dbg_build_needed) { + push @python_dbg, $python; + } + elsif (($python eq "python-dbg") + and (grep /^\Q$python_default\E/, @dbg_build_needed)) { + push @python_dbg, $python_default."-dbg"; + } + } + + foreach my $python (@python_dbg, @python_requested) { + if (-x "/usr/bin/".$python) { + # To allow backports of debhelper we don't pass + # --install-layout=deb to 'setup.py install` for + # those Python versions where the option is + # ignored by distutils/setuptools. + if ( $act eq "install" and not + ( ($python =~ /^python(?:-dbg)?$/ + and $python_default =~ /^python2\.[2345]$/) + or $python =~ /^python2\.[2345](?:-dbg)?$/ )) { + $this->doit_in_sourcedir($python, "setup.py", + $act, @_, "--install-layout=deb"); + } + else { + $this->doit_in_sourcedir($python, "setup.py", + $act, @_); + } + } + } +} + +sub build { + my $this=shift; + $this->setup_py("build", + "--force", + @_); +} + +sub install { + my $this=shift; + my $destdir=shift; + $this->setup_py("install", + "--force", + "--root=$destdir", + "--no-compile", + "-O0", + @_); +} + +sub clean { + my $this=shift; + $this->setup_py("clean", "-a", @_); + + # Config file will remain if it was created by us + if (!$this->not_our_cfg()) { + unlink($this->get_buildpath(".pydistutils.cfg")); + $this->rmdir_builddir(1); # only if empty + } + # The setup.py might import files, leading to python creating pyc + # files. + $this->doit_in_sourcedir('find', '.', '-name', '*.pyc', '-exec', 'rm', '{}', '+'); +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/qmake.pm b/lib/Debian/Debhelper/Buildsystem/qmake.pm new file mode 100644 index 0000000..18b896d --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/qmake.pm @@ -0,0 +1,103 @@ +# A debhelper build system class for Qt projects +# (based on the makefile class). +# +# Copyright: © 2010 Kelvin Modderman +# License: GPL-2+ + +package Debian::Debhelper::Buildsystem::qmake; + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(dpkg_architecture_value error is_cross_compiling); +use parent qw(Debian::Debhelper::Buildsystem::makefile); + +my %OS_MKSPEC_MAPPING = ( + 'linux' => 'linux-g++', + 'kfreebsd' => 'gnukfreebsd-g++', + 'hurd' => 'hurd-g++', +); + +sub DESCRIPTION { + "qmake (*.pro)"; +} + +sub check_auto_buildable { + my $this=shift; + my @projects=glob($this->get_sourcepath('*.pro')); + my $ret=0; + + if (@projects > 0) { + $ret=1; + # Existence of a Makefile generated by qmake indicates qmake + # class has already been used by a prior build step, so should + # be used instead of the parent makefile class. + my $mf=$this->get_buildpath("Makefile"); + if (-e $mf) { + $ret = $this->SUPER::check_auto_buildable(@_); + open(my $fh, '<', $mf) + or error("unable to open Makefile: $mf"); + while(<$fh>) { + if (m/^# Generated by qmake/i) { + $ret++; + last; + } + } + close($fh); + } + } + + return $ret; +} + +sub configure { + my $this=shift; + my @options; + my @flags; + + push @options, '-makefile'; + if (is_cross_compiling()) { + my $host_os = dpkg_architecture_value("DEB_HOST_ARCH_OS"); + + if (defined(my $spec = $OS_MKSPEC_MAPPING{$host_os})) { + push(@options, "-spec", $spec); + } else { + error("Cannot cross-compile: Missing entry for HOST OS ${host_os} for qmake's -spec option"); + } + } + + if ($ENV{CFLAGS}) { + push @flags, "QMAKE_CFLAGS_RELEASE=$ENV{CFLAGS} $ENV{CPPFLAGS}"; + push @flags, "QMAKE_CFLAGS_DEBUG=$ENV{CFLAGS} $ENV{CPPFLAGS}"; + } + if ($ENV{CXXFLAGS}) { + push @flags, "QMAKE_CXXFLAGS_RELEASE=$ENV{CXXFLAGS} $ENV{CPPFLAGS}"; + push @flags, "QMAKE_CXXFLAGS_DEBUG=$ENV{CXXFLAGS} $ENV{CPPFLAGS}"; + } + if ($ENV{LDFLAGS}) { + push @flags, "QMAKE_LFLAGS_RELEASE=$ENV{LDFLAGS}"; + push @flags, "QMAKE_LFLAGS_DEBUG=$ENV{LDFLAGS}"; + } + push @flags, "QMAKE_STRIP=:"; + push @flags, "PREFIX=/usr"; + + $this->mkdir_builddir(); + $this->doit_in_builddir($this->_qmake(), @options, @flags, @_); +} + +sub install { + my $this=shift; + my $destdir=shift; + + # qmake generated Makefiles use INSTALL_ROOT in install target + # where one would expect DESTDIR to be used. + $this->SUPER::install($destdir, "INSTALL_ROOT=$destdir", @_); +} + +sub _qmake { + if (is_cross_compiling()) { + return dpkg_architecture_value("DEB_HOST_GNU_TYPE") . "-qmake"; + } + return 'qmake'; +} + +1 diff --git a/lib/Debian/Debhelper/Buildsystem/qmake_qt4.pm b/lib/Debian/Debhelper/Buildsystem/qmake_qt4.pm new file mode 100644 index 0000000..60d9084 --- /dev/null +++ b/lib/Debian/Debhelper/Buildsystem/qmake_qt4.pm @@ -0,0 +1,15 @@ +package Debian::Debhelper::Buildsystem::qmake_qt4; + +use strict; +use warnings; +use parent qw(Debian::Debhelper::Buildsystem::qmake); + +sub DESCRIPTION { + "qmake for QT 4 (*.pro)"; +} + +sub _qmake { + return 'qmake-qt4'; +} + +1 diff --git a/lib/Debian/Debhelper/DH/AddonAPI.pm b/lib/Debian/Debhelper/DH/AddonAPI.pm new file mode 100644 index 0000000..499ec00 --- /dev/null +++ b/lib/Debian/Debhelper/DH/AddonAPI.pm @@ -0,0 +1,220 @@ +# Defines dh sequence state variables +# +# License: GPL-2+ + +package Debian::Debhelper::DH::AddonAPI; +use strict; +use warnings; + +use Debian::Debhelper::Dh_Lib qw(warning error); +use Debian::Debhelper::Sequence; +use Debian::Debhelper::SequencerUtil; +use Debian::Debhelper::DH::SequenceState; + + +our ($DH_INTERNAL_ADDON_TYPE, $DH_INTERNAL_ADDON_NAME); + +sub _add_sequence { + my @args = @_; + my $seq = Debian::Debhelper::Sequence->new(@args); + my $name = $seq->name; + $Debian::Debhelper::DH::SequenceState::sequences{$name} = $seq; + if ($seq->allowed_subsequences eq SEQUENCE_ARCH_INDEP_SUBSEQUENCES) { + for my $subseq ((SEQUENCE_TYPE_ARCH_ONLY, SEQUENCE_TYPE_INDEP_ONLY)) { + my $subname = "${name}-${subseq}"; + $Debian::Debhelper::DH::SequenceState::sequences{$subname} = $seq; + } + } + return; +} + +sub _skip_cmd_if_deb_build_options_contains { + my ($command, $flag) = @_; + push(@{$Debian::Debhelper::DH::SequenceState::commands_skippable_via_deb_build_options{$command}}, $flag); + return; +} + +sub _assert_not_conditional_sequence_addon { + my ($feature) = @_; + return if $DH_INTERNAL_ADDON_TYPE eq 'both'; + warning("The add-on ${DH_INTERNAL_ADDON_NAME} relies on a feature (${feature}) (possibly indirectly), which is " + . 'not supported for conditional debhelper sequence add-ons.'); + warning("Hint: You may have to move the build-dependency for dh-sequence-${DH_INTERNAL_ADDON_NAME} to " + . 'Build-Depends to avoid this error assuming it is possible to use the sequence unconditionally.'); + error("${feature} is not supported for conditional dh sequence add-ons.\n"); +} + +sub _filter_sequences_for_conditional_add_ons { + my @sequences = @_; + # If it is unconditional, then there is no issues. + return @sequences if $DH_INTERNAL_ADDON_TYPE eq 'both' or not @sequences; + for my $seq (@sequences) { + # Typically, if you add a command to a sequence, then you will in fact add it to two. E.g. + # Adding dh_foo after dh_installdocs will affect both install-arch AND install-indep. We want + # this to "just work(tm)" with a conditional add-on to avoid too much hassle (i.e. only affect + # the relevant sequence). At the same time, we must abort if a sequence like "clean" is + # affected. + # + # We solve the above by checking if the sequence has an -arch + an -indep variant and then + # insert the command only for that sequence variant. + + if ($seq->allowed_subsequences ne SEQUENCE_ARCH_INDEP_SUBSEQUENCES) { + my $sequence_name = $seq->name; + warning("The add-on ${DH_INTERNAL_ADDON_NAME} attempted to modify the sequence ${sequence_name} (possibly " + . "indirectly) but the add-on is conditional for \"*-${DH_INTERNAL_ADDON_TYPE}\" targets"); + warning("Hint: You may have to move the build-dependency for dh-sequence-${DH_INTERNAL_ADDON_NAME} to " + . 'Build-Depends to avoid this error assuming it is possible to use the sequence unconditionally.'); + error("The add-on ${DH_INTERNAL_ADDON_NAME} cannot be use conditionally for \"*-${DH_INTERNAL_ADDON_TYPE}\"" + . " targets\n"); + } + } + return @sequences; +} + +sub _register_cmd_added_by_addon { + my ($cmd) = @_; + my $existing = $Debian::Debhelper::DH::SequenceState::commands_added_by_addon{$cmd}; + if ($existing) { + if ($existing->{'addon-type'} ne $DH_INTERNAL_ADDON_TYPE) { + my $old_addon_name = $existing->{'addon-name'}; + my $old_addon_type = $existing->{'addon-type'}; + # Technically, "both" could be made compatible with "indep" OR "arch" (but not both at the same time). + # Implement if it turns out to be relevant. + warning("Both dh sequence add-ons ${DH_INTERNAL_ADDON_NAME} and ${old_addon_name} have attempted to add " + . "the command $cmd (possibly indirectly)."); + warning("However, the two add-ons do not have compatible constraints (${DH_INTERNAL_ADDON_TYPE} vs. " + . "${old_addon_type})."); + warning("Hint: You may have to move the build-dependency for dh-sequence- to " + . ' the same build-dependency field to avoid this error assuming it is possible.'); + error("Multiple sequences have conflicting requests for $cmd.\n"); + } + return; + } + + $Debian::Debhelper::DH::SequenceState::commands_added_by_addon{$cmd} = { + 'addon-name' => $DH_INTERNAL_ADDON_NAME, + 'addon-type' => $DH_INTERNAL_ADDON_TYPE, + }; + return; +} + +sub _sequences_containing_cmd { + my ($cmd) = @_; + my @sequences; + foreach my $sequence_name (keys(%Debian::Debhelper::DH::SequenceState::sequences)) { + my $seq = $Debian::Debhelper::DH::SequenceState::sequences{$sequence_name}; + for my $scmd (@{$seq->{'_cmds'}}) { + if ($scmd->{'command'} eq $cmd) { + push(@sequences, $seq); + last; + } + } + } + return @sequences; +} + +sub _seq_cmd { + my ($cmd_name) = @_; + return { + 'command' => $cmd_name, + 'command-options' => [], + 'sequence-limitation' => $DH_INTERNAL_ADDON_TYPE, + }; +} + +# sequence addon interface +sub _insert { + my ($offset, $existing, $new) = @_; + my @affected_sequences = _sequences_containing_cmd($existing); + @affected_sequences = _filter_sequences_for_conditional_add_ons(@affected_sequences); + return if not @affected_sequences; + _register_cmd_added_by_addon($new); + for my $seq (@affected_sequences) { + $seq->_insert($offset, $existing, _seq_cmd($new)); + } + return 1; +} +sub insert_before { + return _insert(-1, @_); +} +sub insert_after { + return _insert(1, @_); +} +sub remove_command { + my ($command) = @_; + # Implement if actually needed (I *think* it basically means to transform dh_foo to dh_foo -a/-i) + _assert_not_conditional_sequence_addon('remove_command'); + my @affected_sequences = _sequences_containing_cmd($command); + @affected_sequences = _filter_sequences_for_conditional_add_ons(@affected_sequences); + return 1 if not @affected_sequences; + for my $seq (@affected_sequences) { + $seq->remove_command($command); + } + return 1; +} +sub add_command { + my ($command, $sequence) = @_; + _assert_not_conditional_sequence_addon('add_command'); + _register_cmd_added_by_addon($command); + if (not exists($Debian::Debhelper::DH::SequenceState::sequences{$sequence})) { + _add_sequence($sequence, SEQUENCE_NO_SUBSEQUENCES, _seq_cmd($command)); + } else { + my $seq = $Debian::Debhelper::DH::SequenceState::sequences{$sequence}; + _filter_sequences_for_conditional_add_ons($seq); + $seq->add_command_at_start(_seq_cmd($command)) + } + return 1; +} +sub add_command_at_end { + my ($command, $sequence) = @_; + _assert_not_conditional_sequence_addon('add_command'); + _register_cmd_added_by_addon($command); + if (not exists($Debian::Debhelper::DH::SequenceState::sequences{$sequence})) { + _add_sequence($sequence, SEQUENCE_NO_SUBSEQUENCES, _seq_cmd($command)); + } else { + my $seq = $Debian::Debhelper::DH::SequenceState::sequences{$sequence}; + _filter_sequences_for_conditional_add_ons($seq); + $seq->add_command_at_end(_seq_cmd($command)) + } + return 1; +} + +sub add_command_options { + my $command=shift; + # Implement if actually needed (Complicated as dh_foo becomes dh_foo -a && dh_foo -i + # and that implies smarter deduplication logic) + _assert_not_conditional_sequence_addon('add_command_options'); + push(@{$Debian::Debhelper::DH::SequenceState::command_opts{$command}}, @_); + return 1; +} + +sub remove_command_options { + my ($command, @cmd_options) = @_; + # Implement if actually needed (Complicated as dh_foo becomes + # dh_foo -a && dh_foo -i and that implies smarter deduplication logic) + _assert_not_conditional_sequence_addon('remove_command_options'); + if (@cmd_options) { + # Remove only specified options + if (my $opts = $Debian::Debhelper::DH::SequenceState::command_opts{$command}) { + foreach my $opt (@cmd_options) { + $opts = [ grep { $_ ne $opt } @$opts ]; + } + $Debian::Debhelper::DH::SequenceState::command_opts{$command} = $opts; + } + } + else { + # Clear all additional options + delete($Debian::Debhelper::DH::SequenceState::command_opts{$command}); + } + return 1; +} + +sub declare_command_obsolete { + my ($command) = @_; + _assert_not_conditional_sequence_addon('declare_command_obsolete'); + $Debian::Debhelper::DH::SequenceState::obsolete_command{$command} = $DH_INTERNAL_ADDON_NAME; + return 1; +} + + +1; diff --git a/lib/Debian/Debhelper/DH/SequenceState.pm b/lib/Debian/Debhelper/DH/SequenceState.pm new file mode 100644 index 0000000..b029e01 --- /dev/null +++ b/lib/Debian/Debhelper/DH/SequenceState.pm @@ -0,0 +1,31 @@ +# Defines dh sequence state variables +# +# License: GPL-2+ + +package Debian::Debhelper::DH::SequenceState; +use strict; +use warnings; + +our ( + # Definitions of sequences. + %sequences, + # Additional command options + %command_opts, + # Track commands added by (which) addons + %commands_added_by_addon, + # Removed commands + %obsolete_command, + # Commands that can be skipped due to DEB_BUILD_OPTIONS=X flags + %commands_skippable_via_deb_build_options, + # Options passed that should be passed on to underlying helpers (in order) + @options, + # Options passed by name (to assist can_skip with which options are used) + %seen_options, + # Whether there were sequences of options that inhibit certain optimizations + # * $unoptimizable_option_bundle => can skip iff cli-options hint is present and empty + # * $unoptimizable_user_option => We can never skip anything (non-option seen) + $unoptimizable_option_bundle, + $unoptimizable_user_option, +); + +1; diff --git a/lib/Debian/Debhelper/Dh_Buildsystems.pm b/lib/Debian/Debhelper/Dh_Buildsystems.pm new file mode 100644 index 0000000..08b1477 --- /dev/null +++ b/lib/Debian/Debhelper/Dh_Buildsystems.pm @@ -0,0 +1,315 @@ +# A module for loading and managing debhelper build system classes. +# This module is intended to be used by all dh_auto_* programs. +# +# Copyright: © 2009 Modestas Vainius +# License: GPL-2+ + +package Debian::Debhelper::Dh_Buildsystems; + +use strict; +use warnings; +use Debian::Debhelper::Buildsystem; +use Debian::Debhelper::Dh_Lib; +use File::Spec; + +use Exporter qw(import); +our @EXPORT=qw(&buildsystems_init &buildsystems_do &load_buildsystem &load_all_buildsystems); + +use constant BUILD_STEPS => qw(configure build test install clean); + +# Historical order must be kept for backwards compatibility. New +# build systems MUST be added to the END of the list. +our @BUILDSYSTEMS = ( + "autoconf", + (! compat(7) ? "perl_build" : ()), + "perl_makemaker", + "makefile", + "python_distutils", + (compat(7) ? "perl_build" : ()), + "cmake+makefile", + "cmake+ninja", + "ant", + "qmake", + "qmake_qt4", + "meson+ninja", + "ninja", +); + +our @THIRD_PARTY_BUILDSYSTEMS = ( + 'maven', + 'gradle', +); + +my $opt_buildsys; +my $opt_sourcedir; +my $opt_builddir; +my $opt_list; +my $opt_parallel; + +*create_buildsystem_instance = \&Debian::Debhelper::Buildsystem::_create_buildsystem_instance; + +sub _insert_cmd_opts { + my (%bsopts) = @_; + if (!exists $bsopts{builddir} && defined $opt_builddir) { + $bsopts{builddir} = ($opt_builddir eq "") ? undef : $opt_builddir; + } + if (!exists $bsopts{sourcedir} && defined $opt_sourcedir) { + $bsopts{sourcedir} = ($opt_sourcedir eq "") ? undef : $opt_sourcedir; + } + if (!exists $bsopts{parallel}) { + $bsopts{parallel} = $opt_parallel; + } + return %bsopts; +} + +# Autoselect a build system from the list of instances +sub autoselect_buildsystem { + my $step=shift; + my $selected; + my $selected_level = 0; + + foreach my $inst (@_) { + # Only more specific build system can be considered beyond + # the currently selected one. + if (defined($selected)) { + my $ok = $inst->isa(ref($selected)) ? 1 : 0; + if (not $ok and $inst->IS_GENERATOR_BUILD_SYSTEM) { + $ok = 1 if $inst->get_targetbuildsystem->NAME eq $selected->NAME; + } + next if not $ok; + } + + # If the build system says it is auto-buildable at the current + # step and it can provide more specific information about its + # status than its parent (if any), auto-select it. + my $level = $inst->check_auto_buildable($step); + if ($level > $selected_level) { + $selected = $inst; + $selected_level = $level; + } + } + return $selected; +} + +# Similar to create_buildsystem_instance(), but it attempts to autoselect +# a build system if none was specified. In case autoselection fails or an +# explicit “none” is requested, undef is returned. +sub load_buildsystem { + my $system=shift; + my $step=shift; + my %opts = _insert_cmd_opts(@_); + my $system_options; + if (defined($system) && ref($system) eq 'HASH') { + $system_options = $system; + $system = $system_options->{'system'}; + } + if (defined $system) { + return undef if $system eq 'none'; + my $inst = create_buildsystem_instance($system, 1, %opts); + return $inst; + } + else { + # Try to determine build system automatically + my @buildsystems; + foreach $system (@BUILDSYSTEMS) { + push @buildsystems, create_buildsystem_instance($system, 1, %opts); + } + if (!$system_options || $system_options->{'enable-thirdparty'}) { + foreach $system (@THIRD_PARTY_BUILDSYSTEMS) { + push @buildsystems, create_buildsystem_instance($system, 0, %opts); + } + } + return autoselect_buildsystem($step, @buildsystems); + } +} + +sub load_all_buildsystems { + my $incs=shift || \@INC; + my %opts = _insert_cmd_opts(@_); + my (%buildsystems, %genbuildsystems, @buildsystems); + + foreach my $inc (@$incs) { + my $path = File::Spec->catdir($inc, "Debian/Debhelper/Buildsystem"); + if (-d $path) { + foreach my $module_path (glob "$path/*.pm") { + my $name = basename($module_path); + $name =~ s/\.pm$//; + next if exists $buildsystems{$name} or exists $genbuildsystems{$name}; + my $system = create_buildsystem_instance($name, 1, %opts); + if ($system->IS_GENERATOR_BUILD_SYSTEM) { + $genbuildsystems{$name} = 1; + for my $target_name ($system->SUPPORTED_TARGET_BUILD_SYSTEMS) { + my $full_name = "${name}+${target_name}"; + my $full_system = create_buildsystem_instance($name, 1, %opts, + 'targetbuildsystem' => $target_name); + $buildsystems{$full_name} = $full_system; + } + } else { + $buildsystems{$name} = $system; + } + } + } + } + + # Standard debhelper build systems first + foreach my $name (@BUILDSYSTEMS) { + error("standard debhelper build system '$name' could not be found/loaded") + if not exists $buildsystems{$name}; + push @buildsystems, $buildsystems{$name}; + delete $buildsystems{$name}; + } + + foreach my $name (@THIRD_PARTY_BUILDSYSTEMS) { + next if not exists $buildsystems{$name}; + my $inst = $buildsystems{$name}; + $inst->{thirdparty} = 1; + push(@buildsystems, $inst); + delete($buildsystems{$name}); + } + + # The rest are 3rd party build systems + foreach my $name (sort(keys(%buildsystems))) { + my $inst = $buildsystems{$name}; + $inst->{thirdparty} = 1; + push @buildsystems, $inst; + } + + return @buildsystems; +} + +sub buildsystems_init { + my %args=@_; + + # Compat 10 defaults to --parallel by default + my $max_parallel = compat(9) ? 1 : -1; + + # Available command line options + my %options = ( + "D=s" => \$opt_sourcedir, + "sourcedir=s" => \$opt_sourcedir, + "sourcedirectory=s" => \$opt_sourcedir, + + "B:s" => \$opt_builddir, + "builddir:s" => \$opt_builddir, + "builddirectory:s" => \$opt_builddir, + + "S=s" => \$opt_buildsys, + "buildsystem=s" => \$opt_buildsys, + + "l" => \$opt_list, + "list" => \$opt_list, + + "parallel" => sub { $max_parallel = -1 }, + 'no-parallel' => sub { $max_parallel = 1 }, + "max-parallel=i" => \$max_parallel, + + 'reload-all-buildenv-variables' => sub { + Debian::Debhelper::Dh_Lib::reset_buildflags(); + }, + ); + if (compat(8)) { + # This option only works in compat 9+ where we actually set buildflags + $options{'reload-all-buildenv-variables'} = sub { + die("--reload-all-buildenv-variables only work reliably in compat 9+.\n"); + }; + } + $args{options}{$_} = $options{$_} foreach keys(%options); + Debian::Debhelper::Dh_Lib::init(%args); + Debian::Debhelper::Dh_Lib::setup_buildenv(); + set_parallel($max_parallel); +} + +sub set_parallel { + my $max=shift; + + # Get number of processes from parallel=n option, limiting it + # with $max if needed + $opt_parallel=get_buildoption("parallel") || 1; + + if ($max > 0 && $opt_parallel > $max) { + $opt_parallel = $max; + } +} + +sub buildsystems_list { + my $step=shift; + + my @buildsystems = load_all_buildsystems(); + my %auto_selectable = map { $_ => 1 } @THIRD_PARTY_BUILDSYSTEMS; + my $auto = autoselect_buildsystem($step, grep { ! $_->{thirdparty} || $auto_selectable{$_->NAME} } @buildsystems); + my $specified_text; + + if ($opt_buildsys) { + for my $inst (@buildsystems) { + my $full_name = $inst->NAME; + if ($full_name eq $opt_buildsys) { + $specified_text = $full_name; + } elsif ($inst->IS_GENERATOR_BUILD_SYSTEM and ref($inst)->NAME eq $opt_buildsys) { + my $default = $inst->DEFAULT_TARGET_BUILD_SYSTEM; + $specified_text = "${opt_buildsys}+${default} (default for ${opt_buildsys})"; + } + } + } + + # List build systems (including auto and specified status) + foreach my $inst (@buildsystems) { + printf("%-20s %s", $inst->NAME(), $inst->FULL_DESCRIPTION()); + print " [3rd party]" if $inst->{thirdparty}; + print "\n"; + } + print "\n"; + print "Auto-selected: ", $auto->NAME(), "\n" if defined $auto; + print "Specified: ", $specified_text, "\n" if defined $specified_text; + print "No system auto-selected or specified\n" + if ! defined $auto && ! defined $specified_text; +} + +sub buildsystems_do { + my $step=shift; + + if (!defined $step) { + $step = basename($0); + $step =~ s/^dh_auto_//; + } + + if (grep(/^\Q$step\E$/, BUILD_STEPS) == 0) { + error("unrecognized build step: " . $step); + } + + if ($opt_list) { + buildsystems_list($step); + exit 0; + } + + my $buildsystem = load_buildsystem($opt_buildsys, $step); + if (defined $buildsystem) { + my ($xdg_runtime_dir, $err, $ref); + local $SIG{'INT'} = sub { $ref = 'INT'; die(\$ref); }; + local $SIG{'TERM'} = sub { $ref = 'TERM'; die(\$ref); }; + if ($step eq 'test' and not compat(12)) { + require File::Temp; + $xdg_runtime_dir = File::Temp->newdir('dh-xdg-rundir-XXXXXXXX', + TMPDIR => 1, + CLEANUP => 1, + ); + $ENV{'XDG_RUNTIME_DIR'} = $xdg_runtime_dir->dirname; + } + eval { + $buildsystem->pre_building_step($step); + $buildsystem->$step(@_, @{$dh{U_PARAMS}}); + $buildsystem->post_building_step($step); + }; + $err = $@; + doit('rm', '-fr', '--', $xdg_runtime_dir) if $xdg_runtime_dir; + if ($err) { + my $sig; + die($err) if $err ne \$ref; + $sig = $ref; + delete($SIG{$sig}); + kill($sig => $$); + } + } + return 0; +} + +1 diff --git a/lib/Debian/Debhelper/Dh_Getopt.pm b/lib/Debian/Debhelper/Dh_Getopt.pm new file mode 100644 index 0000000..6d95405 --- /dev/null +++ b/lib/Debian/Debhelper/Dh_Getopt.pm @@ -0,0 +1,333 @@ +#!/usr/bin/perl +# +# Debhelper option processing library. +# +# Joey Hess GPL copyright 1998-2002 + +package Debian::Debhelper::Dh_Getopt; +use strict; +use warnings; + +use Debian::Debhelper::Dh_Lib; +use Getopt::Long; + +my (%exclude_package, %internal_excluded_package, %explicitly_reqested_packages, %profile_enabled_packages, + $profile_excluded_pkg); + +sub showhelp { + my $prog=basename($0); + print "Usage: $prog [options]\n\n"; + print " $prog is a part of debhelper. See debhelper(7)\n"; + print " and $prog(1) for complete usage instructions.\n"; + exit(1); +} + +# Passed an option name and an option value, adds packages to the list +# of packages. We need this so the list will be built up in the right +# order. +sub AddPackage { my($option,$value)=@_; + if ($option eq 'i' or $option eq 'indep') { + push @{$dh{DOPACKAGES}}, getpackages('indep'); + $dh{DOINDEP}=1; + } + elsif ($option eq 'a' or $option eq 'arch' or + $option eq 's' or $option eq 'same-arch') { + push @{$dh{DOPACKAGES}}, getpackages('arch'); + $dh{DOARCH}=1; + if ($option eq 's' or $option eq 'same-arch') { + deprecated_functionality('-s/--same-arch is deprecated; please use -a/--arch instead', + 12, + '-s/--same-arch has been removed; please use -a/--arch instead' + ); + } + } + elsif ($option eq 'p' or $option eq 'package') { + assert_opt_is_known_package($value, '-p/--package'); + %profile_enabled_packages = map { $_ => 1 } getpackages('both') if not %profile_enabled_packages; + $explicitly_reqested_packages{$value} = 1; + # Silently ignore packages that are not enabled by the + # profile. + if (exists($profile_enabled_packages{$value})) { + push @{$dh{DOPACKAGES}}, $value; + } else { + $profile_excluded_pkg = 1; + } + } + else { + error("bad option $option - should never happen!\n"); + } +} + +# Sets a package as the debug package. +sub SetDebugPackage { my($option,$value)=@_; + $dh{DEBUGPACKAGE} = $value; + # For backwards compatibility + $dh{DEBUGPACKAGES} = [$value]; +} + +# Add a package to a list of packages that should not be acted on. +sub ExcludePackage { + my($option, $value)=@_; + assert_opt_is_known_package($value, '-N/--no-package'); + $exclude_package{$value}=1; +} + +# Add another item to the exclude list. +sub AddExclude { my($option,$value)=@_; + push @{$dh{EXCLUDE}},$value; +} + +# This collects non-options values. +sub NonOption { + push @{$dh{ARGV}}, @_; +} + +sub getoptions { + my $array=shift; + my %params=@_; + + if (! exists $params{bundling} || $params{bundling}) { + Getopt::Long::config("bundling"); + } + Getopt::Long::config('no_ignore_case'); + if ( ! -f 'debian/control' or ! compat(12, 1)) { + Getopt::Long::config('no_auto_abbrev'); + } + + my @test; + my %options=( + "v" => \$dh{VERBOSE}, + "verbose" => \$dh{VERBOSE}, + + "no-act" => \$dh{NO_ACT}, + + "i" => \&AddPackage, + "indep" => \&AddPackage, + + "a" => \&AddPackage, + "arch" => \&AddPackage, + + "p=s" => \&AddPackage, + "package=s" => \&AddPackage, + + "N=s" => \&ExcludePackage, + "no-package=s" => \&ExcludePackage, + + "remaining-packages" => \$dh{EXCLUDE_LOGGED}, + + "dbg-package=s" => \&SetDebugPackage, + + "s" => \&AddPackage, + "same-arch" => \&AddPackage, + + "n" => \$dh{NOSCRIPTS}, + "noscripts" => \$dh{NOSCRIPTS}, + "no-scripts" => \$dh{NOSCRIPTS}, + "o" => \$dh{ONLYSCRIPTS}, + "onlyscripts" => \$dh{ONLYSCRIPTS}, + "only-scripts" => \$dh{ONLYSCRIPTS}, + + "X=s" => \&AddExclude, + "exclude=s" => \&AddExclude, + + "d" => \$dh{D_FLAG}, + + "P=s" => \$dh{TMPDIR}, + "tmpdir=s" => \$dh{TMPDIR}, + + "u=s", => \$dh{U_PARAMS}, + + "V:s", => \$dh{V_FLAG}, + + "A" => \$dh{PARAMS_ALL}, + "all" => \$dh{PARAMS_ALL}, + + "h|help" => \&showhelp, + + "mainpackage=s" => \$dh{MAINPACKAGE}, + + "name=s" => \$dh{NAME}, + + "error-handler=s" => \$dh{ERROR_HANDLER}, + + "O=s" => sub { push @test, $_[1] }, + + (ref $params{options} ? %{$params{options}} : ()) , + + "<>" => \&NonOption, + ); + + if ($params{test}) { + foreach my $key (keys %options) { + $options{$key}=sub {}; + } + } + + my $oldwarn; + if ($params{test} || $params{ignore_unknown_options}) { + $oldwarn=$SIG{__WARN__}; + $SIG{__WARN__}=sub {}; + } + my $ret=Getopt::Long::GetOptionsFromArray($array, %options); + if ($params{test} || $params{ignore_unknown_options}) { + $SIG{__WARN__}=$oldwarn; + } + + foreach my $opt (@test) { + # Try to parse an option, and skip it + # if it is not known. + if (getoptions([$opt], %params, + ignore_unknown_options => 0, + test => 1)) { + getoptions([$opt], %params); + } + } + + return 1 if $params{ignore_unknown_options}; + return $ret; +} + +sub split_options_string { + my $str=shift; + $str=~s/^\s+//; + return split(/\s+/,$str); +} + +# Parse options and set %dh values. +sub parseopts { + my %params=@_; + + my @ARGV_extra; + + # DH_INTERNAL_OPTIONS is used to pass additional options from + # dh through an override target to a command. + if (defined $ENV{DH_INTERNAL_OPTIONS}) { + @ARGV_extra=split(/\x1e/, $ENV{DH_INTERNAL_OPTIONS}); + getoptions(\@ARGV_extra, %params); + + # Avoid forcing acting on packages specified in + # DH_INTERNAL_OPTIONS. This way, -p can be specified + # at the command line to act on a specific package, but when + # nothing is specified, the excludes will cause the set of + # packages DH_INTERNAL_OPTIONS specifies to be acted on. + if (defined $dh{DOPACKAGES}) { + foreach my $package (getpackages()) { + if (! grep { $_ eq $package } @{$dh{DOPACKAGES}}) { + $exclude_package{$package} = 1; + $internal_excluded_package{$package} = 1; + } + } + } + delete $dh{DOPACKAGES}; + delete $dh{DOINDEP}; + delete $dh{DOARCH}; + } + + # DH_OPTIONS can contain additional options to be parsed like @ARGV + if (defined $ENV{DH_OPTIONS}) { + @ARGV_extra=split_options_string($ENV{DH_OPTIONS}); + my $ret=getoptions(\@ARGV_extra, %params); + if (!$ret) { + warning("warning: ignored unknown options in DH_OPTIONS"); + } + } + + my $ret=getoptions(\@ARGV, %params); + if (!$ret) { + if (! compat(7)) { + error("unknown option or error during option parsing; aborting"); + } + } + + # Check to see if -V was specified. If so, but no parameters were + # passed, the variable will be defined but empty. + if (defined($dh{V_FLAG})) { + $dh{V_FLAG_SET}=1; + } + + # If we have not been given any packages to act on, assume they + # want us to act on them all. Note we have to do this before excluding + # packages out, below. + if (! defined $dh{DOPACKAGES} || ! @{$dh{DOPACKAGES}}) { + my $do_exit = 0; + if ($profile_excluded_pkg) { + if (! $dh{BLOCK_NOOP_WARNINGS}) { + warning('All requested packages have been excluded' + . ' (e.g. via a Build-Profile or due to architecture restrictions).'); + } + $do_exit = 1; + } + if ($dh{DOINDEP} || $dh{DOARCH}) { + # User specified that all arch (in)dep package be + # built, and there are none of that type. + if (! $dh{BLOCK_NOOP_WARNINGS}) { + warning("You asked that all arch in(dep) packages be built, but there are none of that type."); + } + $do_exit = 1; + } + exit(0) if $do_exit; + push @{$dh{DOPACKAGES}},getpackages("both"); + } + + # Remove excluded packages from the list of packages to act on. + # Also unique the list, in case some options were specified that + # added a package to it twice. + my @package_list; + my $package; + my %packages_seen; + foreach $package (@{$dh{DOPACKAGES}}) { + if (defined($dh{EXCLUDE_LOGGED}) && + grep { $_ eq basename($0) } load_log($package)) { + $exclude_package{$package}=1; + } + if (! $exclude_package{$package}) { + if (! exists $packages_seen{$package}) { + $packages_seen{$package}=1; + push @package_list, $package; + } + } + } + @{$dh{DOPACKAGES}}=@package_list; + + if (! defined $dh{DOPACKAGES} || ! @{$dh{DOPACKAGES}}) { + if (! $dh{BLOCK_NOOP_WARNINGS}) { + my %archs; + if (%explicitly_reqested_packages) { + # Avoid sending a confusing error message when debhelper must exclude a package given via -p. + # This commonly happens due to Build-Profiles or/and when build only a subset of the packages + # (e.g. dpkg-buildpackage -A vs. -B vs. none of the options) + for my $pkg (sort(keys(%explicitly_reqested_packages))) { + if (exists($internal_excluded_package{$pkg}) or not exists($profile_enabled_packages{$pkg})) { + delete($explicitly_reqested_packages{$pkg}); + } + } + if (not %explicitly_reqested_packages) { + warning('All requested packages have been excluded' + . ' (e.g. via a Build-Profile or due to architecture restrictions).'); + exit(0); + } + } + for my $pkg (getpackages()) { + $archs{package_declared_arch($pkg)} = 1; + } + warning("No packages to build. Possible architecture mismatch: " . hostarch() . + ", want: " . join(" ", sort keys %archs)); + } + exit(0); + } + + if (defined $dh{U_PARAMS}) { + # Split the U_PARAMS up into an array. + my $u=$dh{U_PARAMS}; + undef $dh{U_PARAMS}; + push @{$dh{U_PARAMS}}, split(/\s+/,$u); + } + + # Anything left in @ARGV is options that appeared after a -- + # These options are added to the U_PARAMS array, while the + # non-option values we collected replace them in @ARGV; + push @{$dh{U_PARAMS}}, @ARGV, @ARGV_extra; + @ARGV=@{$dh{ARGV}} if exists $dh{ARGV}; +} + +1 diff --git a/lib/Debian/Debhelper/Dh_Lib.pm b/lib/Debian/Debhelper/Dh_Lib.pm new file mode 100644 index 0000000..01470f4 --- /dev/null +++ b/lib/Debian/Debhelper/Dh_Lib.pm @@ -0,0 +1,2969 @@ +#!/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' => 5, + # 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' => 14, + # Magic value for xargs + 'XARGS_INSERT_PARAMS_HERE' => \'', #'# Hi emacs. + # Magic value for debhelper tools to request "current version" + 'DH_BUILTIN_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' => 7, +}; + + +# 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 + process_pkg + compute_doc_main_package + isnative + is_udeb +), + # File/path related actions +qw( + basename + dirname + install_file + install_prog + install_lib + install_dir + install_dh_config_file + make_symlink + make_symlink_raw_target + rename_path + find_hardlinks + rm_files + excludefile + is_so_or_exec_elf_file + is_empty_dir + reset_perm_and_owner + log_installed_files + + filearray + filedoublearray + glob_expand + glob_expand_error_handler_reject + glob_expand_error_handler_warn_and_discard + glob_expand_error_handler_silently_ignore + glob_expand_error_handler_reject_nomagic_warn_discard +), + # Generate triggers, substvars, maintscripts, build-time temporary files +qw( + autoscript + autotrigger + addsubstvar + delsubstvar + + generated_file + restore_file_on_clean +), + # Split tasks among different cores +qw( + on_pkgs_in_parallel + on_items_in_parallel + on_selected_pkgs_in_parallel +), + # R³ framework +qw( + should_use_root + gain_root_cmd + +), + # Architecture, cross-tooling, build options and profiles +qw( + dpkg_architecture_value + hostarch + cross_command + is_cross_compiling + is_build_profile_active + get_buildoption + perl_cross_incdir +), + # Other +qw( + open_gz + get_source_date_epoch + deprecated_functionality +), + # Special-case functionality (e.g. tool specific), debhelper(-core) functionality and deprecated functions +qw( + inhibit_log + load_log + write_log + commit_override_log + debhelper_script_subst + is_make_jobserver_unavailable + clean_jobserver_makeflags + set_buildflags + DEFAULT_PACKAGE_TYPE + DBGSYM_PACKAGE_TYPE + DH_BUILTIN_VERSION + is_known_package + assert_opt_is_known_package + restore_all_files + + buildarch +)); + +my $MAX_PROCS = get_buildoption("parallel") || 1; +my $DH_TOOL_VERSION; + +our $PKGNAME_REGEX = qr/[a-z0-9][-+\.a-z0-9]+/o; +our $PKGVERSION_REGEX = qr/ + (?: \d+ : )? # Optional epoch + [0-9][0-9A-Za-z.+:~]* # Upstream version (with no hyphens) + (?: - [0-9A-Za-z.+:~]+ )* # Optional debian revision (+ upstreams versions with hyphens) + /xoa; +our $MAINTSCRIPT_TOKEN_REGEX = qr/[A-Za-z0-9_.+]+/o; + +# From Policy 5.1: +# +# The field name is composed of US-ASCII characters excluding control +# characters, space, and colon (i.e., characters in the ranges U+0021 +# (!) through U+0039 (9), and U+003B (;) through U+007E (~), +# inclusive). Field names must not begin with the comment character +# (U+0023 #), nor with the hyphen character (U+002D -). +our $DEB822_FIELD_REGEX = qr/ + [\x21\x22\x24-\x2C\x2F-\x39\x3B-\x7F] # First character + [\x21-\x39\x3B-\x7F]* # Subsequent characters (if any) + /xoa; + +our $PARSE_DH_SEQUENCE_INFO = 0; + +# We need logging in compat 9 or in override/hook targets (for --remaining-packages to work) +# - This option is a global toggle to disable logs for special commands (e.g. dh or dh_clean) +# It is initialized during "init". This implies that commands that never calls init are +# not dh_* commands or do not need the log +my $write_log = undef; + +sub init { + my %params=@_; + + if ($params{internal_parse_dh_sequence_info}) { + $PARSE_DH_SEQUENCE_INFO = 1; + } + + # Check if we can by-pass the expensive Getopt::Long by optimising for the + # common case of "-a" or "-i" + if (scalar(@ARGV) == 1 && ($ARGV[0] eq '-a' || $ARGV[0] eq '-i') && + ! (defined $ENV{DH_OPTIONS} && length $ENV{DH_OPTIONS}) && + ! (defined $ENV{DH_INTERNAL_OPTIONS} && length $ENV{DH_INTERNAL_OPTIONS})) { + + # Single -i or -a as dh does it. + if ($ARGV[0] eq '-i') { + push(@{$dh{DOPACKAGES}}, getpackages('indep')); + $dh{DOINDEP} = 1; + } else { + push(@{$dh{DOPACKAGES}}, getpackages('arch')); + $dh{DOARCH} = 1; + } + + if (! @{$dh{DOPACKAGES}}) { + if (! $dh{BLOCK_NOOP_WARNINGS}) { + warning("You asked that all arch in(dep) packages be built, but there are none of that type."); + } + exit(0); + } + # Clear @ARGV so we do not hit the expensive case below + @ARGV = (); + } + + # Check to see if an option line starts with a dash, + # or DH_OPTIONS is set. + # If so, we need to pass this off to the resource intensive + # Getopt::Long, which I'd prefer to avoid loading at all if possible. + if ((defined $ENV{DH_OPTIONS} && length $ENV{DH_OPTIONS}) || + (defined $ENV{DH_INTERNAL_OPTIONS} && length $ENV{DH_INTERNAL_OPTIONS}) || + grep /^-/, @ARGV) { + eval { require Debian::Debhelper::Dh_Getopt; }; + error($@) if $@; + Debian::Debhelper::Dh_Getopt::parseopts(%params); + } + + # Another way to set excludes. + if (exists $ENV{DH_ALWAYS_EXCLUDE} && length $ENV{DH_ALWAYS_EXCLUDE}) { + push @{$dh{EXCLUDE}}, split(":", $ENV{DH_ALWAYS_EXCLUDE}); + } + + # Generate EXCLUDE_FIND. + if ($dh{EXCLUDE}) { + $dh{EXCLUDE_FIND}=''; + foreach (@{$dh{EXCLUDE}}) { + my $x=$_; + $x=escape_shell($x); + $x=~s/\./\\\\./g; + $dh{EXCLUDE_FIND}.="-regex .\\*$x.\\* -or "; + } + $dh{EXCLUDE_FIND}=~s/ -or $//; + } + + # Check to see if DH_VERBOSE environment variable was set, if so, + # make sure verbose is on. Otherwise, check DH_QUIET. + if (defined $ENV{DH_VERBOSE} && $ENV{DH_VERBOSE} ne "") { + $dh{VERBOSE}=1; + } elsif (defined $ENV{DH_QUIET} && $ENV{DH_QUIET} ne "" || get_buildoption("terse")) { + $dh{QUIET}=1; + } + + # Check to see if DH_NO_ACT environment variable was set, if so, + # make sure no act mode is on. + if (defined $ENV{DH_NO_ACT} && $ENV{DH_NO_ACT} ne "") { + $dh{NO_ACT}=1; + } + + # Get the name of the main binary package (first one listed in + # debian/control). Only if the main package was not set on the + # command line. + if (! exists $dh{MAINPACKAGE} || ! defined $dh{MAINPACKAGE}) { + my @allpackages=getpackages(); + $dh{MAINPACKAGE}=$allpackages[0]; + } + + # Check if packages to build have been specified, if not, fall back to + # the default, building all relevant packages. + if (! defined $dh{DOPACKAGES} || ! @{$dh{DOPACKAGES}}) { + push @{$dh{DOPACKAGES}}, getpackages('both'); + } + + # Check to see if -P was specified. If so, we can only act on a single + # package. + if ($dh{TMPDIR} && $#{$dh{DOPACKAGES}} > 0) { + error("-P was specified, but multiple packages would be acted on (".join(",",@{$dh{DOPACKAGES}}).")."); + } + + # Figure out which package is the first one we were instructed to build. + # This package gets special treatement: files and directories specified on + # the command line may affect it. + $dh{FIRSTPACKAGE}=${$dh{DOPACKAGES}}[0]; + + # If no error handling function was specified, just propagate + # errors out. + if (! exists $dh{ERROR_HANDLER} || ! defined $dh{ERROR_HANDLER}) { + $dh{ERROR_HANDLER}='exit 1'; + } + + $dh{U_PARAMS} //= []; + + if ($params{'inhibit_log'}) { + $write_log = 0; + } else { + # Only initialize if unset (i.e. avoid overriding an early call + # to inhibit_log() + $write_log //= 1; + } +} + +# Ensure the log is written if requested but only if the command was +# successful. +sub END { + return if $? != 0 or not $write_log; + # If there is no 'debian/control', then we are not being run from + # a package directory and then the write_log will not do what we + # expect. + return if not -f 'debian/control'; + if (compat(9, 1) || $ENV{DH_INTERNAL_OVERRIDE}) { + write_log(basename($0), @{$dh{DOPACKAGES}}); + } +} + +sub logfile { + my $package=shift; + my $ext=pkgext($package); + return "debian/${ext}debhelper.log" +} + +sub load_log { + my ($package, $db)=@_; + + my @log; + open(LOG, "<", logfile($package)) || return; + while () { + chomp; + my $command = $_; + push @log, $command; + $db->{$package}{$command}=1 if defined $db; + } + close LOG; + return @log; +} + +sub write_log { + my $cmd=shift; + my @packages=@_; + + return if $dh{NO_ACT}; + + foreach my $package (@packages) { + my $log = logfile($package); + open(LOG, ">>", $log) || error("failed to write to ${log}: $!"); + print LOG $cmd."\n"; + close LOG; + } +} + +sub commit_override_log { + my @packages=@_; + + return if $dh{NO_ACT}; + + foreach my $package (@packages) { + my @log = load_log($package); + my $log = logfile($package); + open(LOG, ">", $log) || error("failed to write to ${log}: $!"); + print LOG $_."\n" foreach @log; + close LOG; + } +} + +sub inhibit_log { + $write_log=0; +} + +# Pass it an array containing the arguments of a shell command like would +# be run by exec(). It turns that into a line like you might enter at the +# shell, escaping metacharacters and quoting arguments that contain spaces. +sub escape_shell { + my @args=@_; + my @ret; + foreach my $word (@args) { + if ($word=~/\s/) { + # Escape only a few things since it will be quoted. + # Note we use double quotes because you cannot + # escape ' in single quotes, while " can be escaped + # in double. + # This does make -V"foo bar" turn into "-Vfoo bar", + # but that will be parsed identically by the shell + # anyway.. + $word=~s/([\n`\$"\\])/\\$1/g; + push @ret, "\"$word\""; + } + else { + # This list is from _Unix in a Nutshell_. (except '#') + $word=~s/([\s!"\$()*+#;<>?@\[\]\\`|~])/\\$1/g; + push @ret,$word; + } + } + return join(' ', @ret); +} + +# Run a command, and display the command to stdout if verbose mode is on. +# Throws error if command exits nonzero. +# +# All commands that modify files in $TMP should be run via this +# function. +# +# Note that this cannot handle complex commands, especially anything +# involving redirection. Use complex_doit instead. +sub doit { + doit_noerror(@_) || error_exitcode(_format_cmdline(@_)); +} + +sub doit_noerror { + verbose_print(_format_cmdline(@_)) if $dh{VERBOSE}; + + goto \&_doit; +} + +sub print_and_doit { + print_and_doit_noerror(@_) || error_exitcode(_format_cmdline(@_)); +} + +sub print_and_doit_noerror { + nonquiet_print(_format_cmdline(@_)); + + goto \&_doit; +} + +sub _doit { + my (@cmd) = @_; + my $options = ref($cmd[0]) ? shift(@cmd) : undef; + # In compat <= 11, we warn, in compat 12 we assume people know what they are doing. + if (not defined($options) and @cmd == 1 and compat(12) and $cmd[0] =~ m/[\s<&>|;]/) { + deprecated_functionality('doit() + doit_*() calls will no longer spawn a shell in compat 12 for single string arguments (please use complex_doit instead)', + 12); + return 1 if $dh{NO_ACT}; + return system(@cmd) == 0; + } + return 1 if $dh{NO_ACT}; + my $pid = fork() // error("fork(): $!"); + if (not $pid) { + if (defined($options)) { + if (defined(my $dir = $options->{chdir})) { + if ($dir ne '.') { + chdir($dir) or error("chdir(\"${dir}\") failed: $!"); + } + } + open(STDIN, '<', '/dev/null') or error("redirect STDIN failed: $!"); + if (defined(my $output = $options->{stdout})) { + open(STDOUT, '>', $output) or error("redirect STDOUT failed: $!"); + } + if (defined(my $update_env = $options->{update_env})) { + while (my ($k, $v) = each(%{$update_env})) { + if (defined($v)) { + $ENV{$k} = $v; + } else { + delete($ENV{$k}); + } + } + } + } + # Force execvp call to avoid shell. Apparently, even exec can + # involve a shell if you don't do this. + exec { $cmd[0] } @cmd; + } + return waitpid($pid, 0) == $pid && $? == 0; +} + +sub _format_cmdline { + my (@cmd) = @_; + my $options = ref($cmd[0]) ? shift(@cmd) : {}; + my $cmd_line = escape_shell(@cmd); + if (defined(my $update_env = $options->{update_env})) { + my $need_env = 0; + my @params; + for my $key (sort(keys(%{$update_env}))) { + my $value = $update_env->{$key}; + if (defined($value)) { + my $quoted_key = escape_shell($key); + push(@params, join('=', $quoted_key, escape_shell($value))); + # shell does not like: "FU BAR"=1 cmd + # if the ENV key has weird symbols, the best bet is to use env + $need_env = 1 if $quoted_key ne $key; + } else { + $need_env = 1; + push(@params, escape_shell("--unset=${key}")); + } + } + unshift(@params, 'env', '--') if $need_env; + $cmd_line = join(' ', @params, $cmd_line); + } + if (defined(my $dir = $options->{chdir})) { + $cmd_line = join(' ', 'cd', escape_shell($dir), '&&', $cmd_line) if $dir ne '.'; + } + if (defined(my $output = $options->{stdout})) { + $cmd_line .= ' > ' . escape_shell($output); + } + return $cmd_line; +} + +sub qx_cmd { + my (@cmd) = @_; + my ($output, @output); + open(my $fd, '-|', @cmd) or error('fork+exec (' . escape_shell(@cmd) . "): $!"); + if (wantarray) { + @output = <$fd>; + } else { + local $/ = undef; + $output = <$fd>; + } + if (not close($fd)) { + error("close pipe failed: $!") if $!; + error_exitcode(escape_shell(@cmd)); + } + return @output if wantarray; + return $output; +} + +# Run a command and display the command to stdout if verbose mode is on. +# Use doit() if you can, instead of this function, because this function +# forks a shell. However, this function can handle more complicated stuff +# like redirection. +sub complex_doit { + verbose_print(join(" ",@_)); + + if (! $dh{NO_ACT}) { + # The join makes system get a scalar so it forks off a shell. + system(join(" ", @_)) == 0 || error_exitcode(join(" ", @_)) + } +} + + +sub error_exitcode { + my $command=shift; + if ($? == -1) { + error("$command failed to execute: $!"); + } + elsif ($? & 127) { + error("$command died with signal ".($? & 127)); + } + elsif ($?) { + error("$command returned exit code ".($? >> 8)); + } + else { + warning("This tool claimed that $command have failed, but it"); + warning("appears to have returned 0."); + error("Probably a bug in this tool is hiding the actual problem."); + } +} + +# Some shortcut functions for installing files and dirs to always +# have the same owner and mode +# install_file - installs a non-executable +# install_prog - installs an executable +# install_lib - installs a shared library (some systems may need x-bit, others don't) +# install_dir - installs a directory +{ + my $_loaded = 0; + sub install_file { + unshift(@_, 0644); + goto \&_install_file_to_path; + } + + sub install_prog { + unshift(@_, 0755); + goto \&_install_file_to_path; + } + sub install_lib { + unshift(@_, 0644); + goto \&_install_file_to_path; + } + + sub _install_file_to_path { + my ($mode, $source, $dest) = @_; + if (not $_loaded) { + $_loaded++; + require File::Copy; + } + verbose_print(sprintf('install -p -m%04o %s', $mode, escape_shell($source, $dest))) + if $dh{VERBOSE}; + return 1 if $dh{NO_ACT}; + # "install -p -mXXXX foo bar" silently discards broken + # symlinks to install the file in place. File::Copy does not, + # so emulate it manually. (#868204) + if ( -l $dest and not -e $dest and not unlink($dest) and $! != ENOENT) { + error("unlink $dest failed: $!"); + } + File::Copy::copy($source, $dest) or error("copy($source, $dest): $!"); + chmod($mode, $dest) or error("chmod($mode, $dest): $!"); + my (@stat) = stat($source); + error("stat($source): $!") if not @stat; + utime($stat[8], $stat[9], $dest) + or error(sprintf("utime(%d, %d, %s): $!", $stat[8] , $stat[9], $dest)); + return 1; + } +} + +sub install_dir { + my @to_create = grep { not -d $_ } @_; + return if not @to_create; + state $_loaded; + if (not $_loaded) { + $_loaded++; + require File::Path; + } + verbose_print(sprintf('install -d %s', escape_shell(@to_create))) + if $dh{VERBOSE}; + return 1 if $dh{NO_ACT}; + eval { + File::Path::make_path(@to_create, { + # install -d uses 0755 (no umask), make_path uses 0777 (& umask) by default. + # Since we claim to run install -d, then ensure the mode is correct. + 'chmod' => 0755, + }); + }; + if (my $err = "$@") { + $err =~ s/\s+at\s+\S+\s+line\s+\d+\.?\n//; + error($err); + } +} + +sub rename_path { + my ($source, $dest) = @_; + + if ($dh{VERBOSE}) { + my $files = escape_shell($source, $dest); + verbose_print("mv $files"); + } + return 1 if $dh{NO_ACT}; + if (not rename($source, $dest)) { + my $ok = 0; + if ($! == EXDEV) { + # Replay with a fork+exec to handle crossing two mount + # points (See #897569) + $ok = _doit('mv', $source, $dest); + } + if (not $ok) { + my $files = escape_shell($source, $dest); + error("mv $files: $!"); + } + } + return 1; +} + +sub reset_perm_and_owner { + my ($mode, @paths) = @_; + my $_mode; + my $use_root = should_use_root(); + # Dark goat blood to tell 0755 from "0755" + if (length( do { no warnings "numeric"; $mode & "" } ) ) { + # 0755, leave it alone. + $_mode = $mode; + } else { + # "0755" -> convert to 0755 + $_mode = oct($mode); + } + if ($dh{VERBOSE}) { + verbose_print(sprintf('chmod %#o -- %s', $_mode, escape_shell(@paths))); + verbose_print(sprintf('chown 0:0 -- %s', escape_shell(@paths))) if $use_root; + } + return if $dh{NO_ACT}; + for my $path (@paths) { + chmod($_mode, $path) or error(sprintf('chmod(%#o, %s): %s', $mode, $path, $!)); + if ($use_root) { + chown(0, 0, $path) or error("chown(0, 0, $path): $!"); + } + } +} + +# Run a command that may have a huge number of arguments, like xargs does. +# Pass in a reference to an array containing the arguments, and then other +# parameters that are the command and any parameters that should be passed to +# it each time. +sub xargs { + my ($args, @static_args) = @_; + + # The kernel can accept command lines up to 20k worth of characters. + my $command_max=20000; # LINUX SPECIFIC!! + # (And obsolete; it's bigger now.) + # I could use POSIX::ARG_MAX, but that would be slow. + + # Figure out length of static portion of command. + my $static_length=0; + my $subst_index = -1; + for my $i (0..$#static_args) { + my $arg = $static_args[$i]; + if ($arg eq XARGS_INSERT_PARAMS_HERE) { + error("Only one insertion place supported in xargs, got command: @static_args") if $subst_index > -1; + $subst_index = $i; + next; + } + $static_length+=length($arg)+1; + } + + my @collect=(); + my $length=$static_length; + foreach (@$args) { + if (length($_) + 1 + $static_length > $command_max) { + error("This command is greater than the maximum command size allowed by the kernel, and cannot be split up further. What on earth are you doing? \"@_ $_\""); + } + $length+=length($_) + 1; + if ($length < $command_max) { + push @collect, $_; + } + else { + if ($#collect > -1) { + if ($subst_index < 0) { + doit(@static_args, @collect); + } else { + my @cmd = @static_args; + splice(@cmd, $subst_index, 1, @collect); + doit(@cmd); + } + } + @collect=($_); + $length=$static_length + length($_) + 1; + } + } + if ($#collect > -1) { + if ($subst_index < 0) { + doit(@static_args, @collect); + } else { + my @cmd = @static_args; + splice(@cmd, $subst_index, 1, @collect); + doit(@cmd); + } + } +} + +# Print something if the verbose flag is on. +sub verbose_print { + my $message=shift; + + if ($dh{VERBOSE}) { + print "\t$message\n"; + } +} + +# Print something unless the quiet flag is on +sub nonquiet_print { + my $message=shift; + + if (!$dh{QUIET}) { + 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(basename($0), 'bold') . ': ' . _color('error', 'bold red') . ": $message\n"); +} + +# Output a warning. +sub warning { + my ($message) = @_; + $message //= ''; + + print STDERR _color(basename($0), 'bold') . ': ' . _color('warning', 'bold yellow') . ": $message\n"; +} + +# Returns the basename of the argument passed to it. +sub basename { + my $fn=shift; + + $fn=~s/\/$//g; # ignore trailing slashes + $fn=~s:^.*/(.*?)$:$1:; + return $fn; +} + +# Returns the directory name of the argument passed to it. +sub dirname { + my $fn=shift; + + $fn=~s/\/$//g; # ignore trailing slashes + $fn=~s:^(.*)/.*?$:$1:; + return $fn; +} + +# Pass in a number, will return true iff the current compatibility level +# is less than or equal to that number. +my $compat_from_bd; +{ + my $check_pending_removals = get_buildoption('dherroron', '') eq 'obsolete-compat-levels' ? 1 : 0; + my $warned_compat = $ENV{DH_INTERNAL_TESTSUITE_SILENT_WARNINGS} ? 1 : 0; + my $c; + + # Used mainly for testing + sub resetcompat { + undef $c; + undef $compat_from_bd; + } + + sub compat { + my $num=shift; + my $nowarn=shift; + + getpackages() if not defined($compat_from_bd); + + if (! defined $c) { + $c=1; + if (-e 'debian/compat') { + open(my $compat_in, '<', "debian/compat") || error "debian/compat: $!"; + my $l=<$compat_in>; + close($compat_in); + if (! defined $l || ! length $l) { + error("debian/compat must contain a positive number (found an empty first line)"); + + } + else { + chomp $l; + my $new_compat = $l; + $new_compat =~ s/^\s*+//; + $new_compat =~ s/\s*+$//; + if ($new_compat !~ m/^\d+$/) { + error("debian/compat must contain a positive number (found: \"${new_compat}\")"); + } + if (defined($compat_from_bd) and $compat_from_bd != -1) { + warning("Please specify the debhelper compat level exactly once."); + warning(" * debian/compat requests compat ${new_compat}."); + warning(" * debian/control requests compat ${compat_from_bd} via \"debhelper-compat (= ${compat_from_bd})\""); + warning(); + warning("Hint: If you just added a build-dependency on debhelper-compat, then please remember to remove debian/compat"); + warning(); + error("debhelper compat level specified both in debian/compat and via build-dependency on debhelper-compat"); + } + $c = $new_compat; + } + } elsif ($compat_from_bd != -1) { + $c = $compat_from_bd; + } elsif (not $nowarn) { + error("Please specify the compatibility level in debian/compat"); + } + + if (defined $ENV{DH_COMPAT}) { + $c=$ENV{DH_COMPAT}; + } + } + if (not $nowarn) { + if ($c < MIN_COMPAT_LEVEL) { + error("Compatibility levels before ${\MIN_COMPAT_LEVEL} are no longer supported (level $c requested)"); + } + + if ($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') + && !compat(5)) { + # Add fragments to top so they run in reverse order when removing. + if (not defined($sed) or ref($sed)) { + verbose_print("[META] Prepend autosnippet \"$filename\" to $script [${outfile}.new]"); + if (not $dh{NO_ACT}) { + open(my $out_fd, '>', "${outfile}.new") or error("open(${outfile}.new): $!"); + print {$out_fd} '# Automatically added by ' . basename($0) . "/${tool_version}\n"; + autoscript_sed($sed, $infile, undef, $out_fd); + print {$out_fd} "# End automatically added section\n"; + open(my $in_fd, '<', $outfile) or error("open($outfile): $!"); + while (my $line = <$in_fd>) { + print {$out_fd} $line; + } + close($in_fd); + close($out_fd) or error("close(${outfile}.new): $!"); + } + } else { + complex_doit("echo \"# Automatically added by ".basename($0)."/${tool_version}\"> $outfile.new"); + autoscript_sed($sed, $infile, "$outfile.new"); + complex_doit("echo '# End automatically added section' >> $outfile.new"); + complex_doit("cat $outfile >> $outfile.new"); + } + rename_path("${outfile}.new", $outfile); + } elsif (not defined($sed) or ref($sed)) { + verbose_print("[META] Append autosnippet \"$filename\" to $script [${outfile}]"); + if (not $dh{NO_ACT}) { + open(my $out_fd, '>>', $outfile) or error("open(${outfile}): $!"); + print {$out_fd} '# Automatically added by ' . basename($0) . "/${tool_version}\n"; + autoscript_sed($sed, $infile, undef, $out_fd); + print {$out_fd} "# End automatically added section\n"; + close($out_fd) or error("close(${outfile}): $!"); + } + } else { + complex_doit("echo \"# Automatically added by ".basename($0)."/${tool_version}\">> $outfile"); + autoscript_sed($sed, $infile, $outfile); + complex_doit("echo '# End automatically added section' >> $outfile"); + } +} + +sub autoscript_sed { + my ($sed, $infile, $outfile, $out_fd) = @_; + if (not defined($sed) or ref($sed)) { + my $out = $out_fd; + open(my $in, '<', $infile) or error("open $infile failed: $!"); + if (not defined($out_fd)) { + open($out, '>>', $outfile) or error("open($outfile): $!"); + } + if (not defined($sed) or ref($sed) eq 'CODE') { + while (<$in>) { $sed->() if $sed; print {$out} $_; } + } else { + my $rstr = sprintf('#(%s)#', join('|', reverse(sort(keys(%$sed))))); + my $regex = qr/$rstr/; + while (my $line = <$in>) { + $line =~ s/$regex/$sed->{$1}/eg; + print {$out} $line; + } + } + if (not defined($out_fd)) { + close($out) or error("close $outfile failed: $!"); + } + close($in) or error("close $infile failed: $!"); + } + else { + error("Internal error - passed open handle for legacy method") if defined($out_fd); + complex_doit("sed \"$sed\" $infile >> $outfile"); + } +} + +# Adds a trigger to the package +{ + my %VALID_TRIGGER_TYPES = map { $_ => 1 } qw( + interest interest-await interest-noawait + activate activate-await activate-noawait + ); + + sub autotrigger { + my ($package, $trigger_type, $trigger_target) = @_; + my ($triggers_file, $ifd, $tool_version); + + if (not exists($VALID_TRIGGER_TYPES{$trigger_type})) { + require Carp; + Carp::confess("Invalid/unknown trigger ${trigger_type}"); + } + return if $dh{NO_ACT}; + + $tool_version = _tool_version(); + $triggers_file = generated_file($package, 'triggers'); + if ( -f $triggers_file ) { + open($ifd, '<', $triggers_file) + or error("open $triggers_file failed $!"); + } else { + open($ifd, '<', '/dev/null') + or error("open /dev/null failed $!"); + } + open(my $ofd, '>', "${triggers_file}.new") + or error("open ${triggers_file}.new failed: $!"); + while (my $line = <$ifd>) { + next if $line =~ m{\A \Q${trigger_type}\E \s+ + \Q${trigger_target}\E (?:\s|\Z) + }x; + print {$ofd} $line; + } + print {$ofd} '# Triggers added by ' . basename($0) . "/${tool_version}\n"; + print {$ofd} "${trigger_type} ${trigger_target}\n"; + close($ofd) or error("closing ${triggers_file}.new failed: $!"); + close($ifd); + rename_path("${triggers_file}.new", $triggers_file); + } +} + +# Generated files are cleaned by dh_clean AND dh_prep +# - Package can be set to "_source" to generate a file relevant +# for the source package (the meson build does this atm.). +# Files for "_source" are only cleaned by dh_clean. +sub generated_file { + my ($package, $filename, $mkdirs) = @_; + my $dir = "debian/.debhelper/generated/${package}"; + my $path = "${dir}/${filename}"; + $mkdirs //= 1; + install_dir($dir) if $mkdirs; + return $path; +} + +# Removes a whole substvar line. +sub delsubstvar { + my $package=shift; + my $substvar=shift; + + my $ext=pkgext($package); + my $substvarfile="debian/${ext}substvars"; + + if (-e $substvarfile) { + complex_doit("grep -a -s -v '^${substvar}=' $substvarfile > $substvarfile.new || true"); + rename_path("${substvarfile}.new", $substvarfile); + } +} + +# Adds a dependency on some package to the specified +# substvar in a package's substvar's file. +sub addsubstvar { + my $package=shift; + my $substvar=shift; + my $deppackage=shift; + my $verinfo=shift; + my $remove=shift; + + my $ext=pkgext($package); + my $substvarfile="debian/${ext}substvars"; + my $str=$deppackage; + $str.=" ($verinfo)" if defined $verinfo && length $verinfo; + + # Figure out what the line will look like, based on what's there + # now, and what we're to add or remove. + my $line=""; + if (-e $substvarfile) { + my %items; + open(my $in, '<', $substvarfile) || error "read $substvarfile: $!"; + while (<$in>) { + chomp; + if (/^\Q$substvar\E=(.*)/) { + %items = map { $_ => 1} split(", ", $1); + + last; + } + } + close($in); + if (! $remove) { + $items{$str}=1; + } + else { + delete $items{$str}; + } + $line=join(", ", sort keys %items); + } + elsif (! $remove) { + $line=$str; + } + + if (length $line) { + complex_doit("(grep -a -s -v ${substvar} $substvarfile; echo ".escape_shell("${substvar}=$line").") > $substvarfile.new"); + rename_path("$substvarfile.new", $substvarfile); + } + else { + delsubstvar($package,$substvar); + } +} + +sub _glob_expand_error_default_msg { + my ($pattern, $dir_ref) = @_; + my $dir_list = join(', ', map { escape_shell($_) } @{$dir_ref}); + return "Cannot find (any matches for) \"${pattern}\" (tried in $dir_list)"; +} + +sub glob_expand_error_handler_reject { + my $msg = _glob_expand_error_default_msg(@_); + error("$msg\n"); + return; +} + +sub glob_expand_error_handler_warn_and_discard { + my $msg = _glob_expand_error_default_msg(@_); + warning("$msg\n"); + return; +} + +# Emulates the "old" glob mechanism; not recommended for new code as +# it permits some globs expand to nothing with only a warning. +sub glob_expand_error_handler_reject_nomagic_warn_discard { + my ($pattern, $dir_ref) = @_; + for my $dir (@{$dir_ref}) { + my $full_pattern = "$dir/$pattern"; + my @matches = bsd_glob($full_pattern, GLOB_CSH & ~(GLOB_TILDE)); + if (@matches) { + goto \&glob_expand_error_handler_reject; + } + } + goto \&glob_expand_error_handler_warn_and_discard; +} + +sub glob_expand_error_handler_silently_ignore { + return; +} + +sub glob_expand { + my ($dir_ref, $error_handler, @patterns) = @_; + my @dirs = @{$dir_ref}; + my @result; + for my $pattern (@patterns) { + my @m; + for my $dir (@dirs) { + my $full_pattern = "$dir/$pattern"; + @m = bsd_glob($full_pattern, GLOB_CSH & ~(GLOB_NOMAGIC|GLOB_TILDE)); + last if @m; + # Handle "foo{bar}" pattern (#888251) + if (-l $full_pattern or -e _) { + push(@m, $full_pattern); + last; + } + } + if (not @m) { + $error_handler //= \&glob_expand_error_handler_reject; + $error_handler->($pattern, $dir_ref); + } + push(@result, @m); + } + return @result; +} + + +my %BUILT_IN_SUBST = ( + 'Space' => ' ', + 'Dollar' => '$', + 'Newline' => "\n", + 'Tab' => "\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 () { + 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) = @_; + $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- OR dh-sequence- ( ) + 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'; +} + +# Return true if a given package is really a udeb. +sub is_udeb { + my $package=shift; + + if (! exists $package_types{$package}) { + warning "package $package is not in control info"; + return 0; + } + return $package_types{$package} eq 'udeb'; +} + +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; + }; +} + +# Handles #DEBHELPER# substitution in a script; also can generate a new +# script from scratch if none exists but there is a .debhelper file for it. +sub debhelper_script_subst { + my ($package, $script, $extra_vars) = @_; + + my $tmp=tmpdir($package); + my $ext=pkgext($package); + my $file=pkgfile($package,$script); + my %variables = defined($extra_vars) ? %{$extra_vars} : (); + my $service_script = generated_file($package, "${script}.service", 0); + my @generated_scripts = ("debian/$ext$script.debhelper", $service_script); + my $subst; + @generated_scripts = grep { -f } @generated_scripts; + if ($script eq 'prerm' or $script eq 'postrm') { + @generated_scripts = reverse(@generated_scripts); + } + if (not exists($variables{'DEBHELPER'})) { + $variables{'DEBHELPER'} = sub { + return _concat_slurp_script_files(@generated_scripts); + }; + } + $subst = _substitution_generator(\%variables); + + if ($file ne '') { + if ($dh{VERBOSE}) { + verbose_print('cp -f ' . escape_shell($file) . " $tmp/DEBIAN/$script"); + verbose_print("[META] Replace #TOKEN#s in \"$tmp/DEBIAN/$script\""); + } + if (not $dh{NO_ACT}) { + my $regex = qr{#(${MAINTSCRIPT_TOKEN_REGEX})#}o; + open(my $out_fd, '>', "$tmp/DEBIAN/$script") or error("open($tmp/DEBIAN/$script) failed: $!"); + open(my $in_fd, '<', $file) or error("open($file) failed: $!"); + while (my $line = <$in_fd>) { + $line =~ s{$regex}{$subst->($1) // "#${1}#"}ge; + print {$out_fd} $line; + } + close($in_fd); + close($out_fd) or error("close($tmp/DEBIAN/$script) failed: $!"); + } + reset_perm_and_owner('0755', "$tmp/DEBIAN/$script"); + } + elsif (@generated_scripts) { + if ($dh{VERBOSE}) { + verbose_print(q{printf '#!/bin/sh\nset -e\n' > } . "$tmp/DEBIAN/$script"); + verbose_print("cat @generated_scripts >> $tmp/DEBIAN/$script"); + } + if (not $dh{NO_ACT}) { + open(my $out_fd, '>', "$tmp/DEBIAN/$script") or error("open($tmp/DEBIAN/$script): $!"); + print {$out_fd} "#!/bin/sh\n"; + print {$out_fd} "set -e\n"; + for my $generated_script (@generated_scripts) { + open(my $in_fd, '<', $generated_script) + or error("open($generated_script) failed: $!"); + while (my $line = <$in_fd>) { + print {$out_fd} $line; + } + close($in_fd); + } + close($out_fd) or error("close($tmp/DEBIAN/$script) failed: $!"); + } + reset_perm_and_owner('0755', "$tmp/DEBIAN/$script"); + } +} + +sub rm_files { + my @files = @_; + verbose_print('rm -f ' . escape_shell(@files)) + if $dh{VERBOSE}; + return 1 if $dh{NO_ACT}; + for my $file (@files) { + if (not unlink($file) and $! != ENOENT) { + error("unlink $file failed: $!"); + } + } + return 1; +} + +sub make_symlink_raw_target { + my ($src, $dest) = @_; + verbose_print('ln -s ' . escape_shell($src, $dest)) + if $dh{VERBOSE}; + return 1 if $dh{NO_ACT}; + if (not symlink($src, $dest)) { + error("symlink($src, $dest) failed: $!"); + } + return 1; +} + +# make_symlink($dest, $src[, $tmp]) creates a symlink from $dest -> $src. +# if $tmp is given, $dest will be created within it. +# Usually $tmp should be the value of tmpdir($package); +sub make_symlink{ + my $dest = shift; + my $src = _expand_path(shift); + my $tmp = shift; + $tmp = '' if not defined($tmp); + + if ($dest =~ m{(?:^|/)*[.]{2}(?:/|$)}) { + error("Invalid destination/link name (contains \"..\"-segments): $dest"); + } + + $src =~ s{^(?:[.]/+)++}{}; + $dest =~ s{^(?:[.]/+)++}{}; + + $src=~s:^/++::; + $dest=~s:^/++::; + + if ($src eq $dest) { + warning("skipping link from $src to self"); + return; + } + + + + # Policy says that if the link is all within one toplevel + # directory, it should be relative. If it's between + # top level directories, leave it absolute. + my @src_dirs = grep { $_ ne '.' } split(m:/+:,$src); + my @dest_dirs = grep { $_ ne '.' } split(m:/+:,$dest); + if (@src_dirs > 0 && $src_dirs[0] eq $dest_dirs[0]) { + # Figure out how much of a path $src and $dest + # share in common. + my $x; + for ($x=0; $x < @src_dirs && $src_dirs[$x] eq $dest_dirs[$x]; $x++) {} + # Build up the new src. + $src=""; + for (1..$#dest_dirs - $x) { + $src.="../"; + } + for ($x .. $#src_dirs) { + $src.=$src_dirs[$_]."/"; + } + if ($x > $#src_dirs && ! length $src) { + $src="."; # special case + } + $src=~s:/$::; + } + else { + # Make sure it's properly absolute. + $src="/$src"; + } + + my $full_dest = "$tmp/$dest"; + if ( -l $full_dest ) { + # All ok - we can always replace a link, and target directory must exists + } elsif (-d _) { + # We cannot replace a directory though + error("link destination $full_dest is a directory"); + } else { + # Make sure the directory the link will be in exists. + my $basedir=dirname($full_dest); + install_dir($basedir); + } + rm_files($full_dest); + make_symlink_raw_target($src, $full_dest); +} + +# _expand_path expands all path "." and ".." components, but doesn't +# resolve symbolic links. +sub _expand_path { + my $start = @_ ? shift : '.'; + my @pathname = split(m:/+:,$start); + my @respath; + for my $entry (@pathname) { + if ($entry eq '.' || $entry eq '') { + # Do nothing + } + elsif ($entry eq '..') { + if ($#respath == -1) { + # Do nothing + } + else { + pop @respath; + } + } + else { + push @respath, $entry; + } + } + + my $result; + for my $entry (@respath) { + $result .= '/' . $entry; + } + if (! defined $result) { + $result="/"; # special case + } + return $result; +} + +# Checks if make's jobserver is enabled via MAKEFLAGS, but +# the FD used to communicate with it is actually not available. +sub is_make_jobserver_unavailable { + if (exists $ENV{MAKEFLAGS} && + $ENV{MAKEFLAGS} =~ /(?:^|\s)--jobserver-(?:fds|auth)=(\d+)/) { + if (!open(my $in, "<&$1")) { + return 1; # unavailable + } + else { + close $in; + return 0; # available + } + } + + return; # no jobserver specified +} + +# Cleans out jobserver options from MAKEFLAGS. +sub clean_jobserver_makeflags { + if (exists $ENV{MAKEFLAGS}) { + if ($ENV{MAKEFLAGS} =~ /(?:^|\s)--jobserver-(?:fds|auth)=\d+/) { + $ENV{MAKEFLAGS} =~ s/(?:^|\s)--jobserver-(?:fds|auth)=\S+//g; + $ENV{MAKEFLAGS} =~ s/(?:^|\s)-j\b//g; + } + delete $ENV{MAKEFLAGS} if $ENV{MAKEFLAGS} =~ /^\s*$/; + } +} + +# If cross-compiling, returns appropriate cross version of command. +sub cross_command { + my ($package, $command) = @_; + if (package_cross_type($package) eq 'target') { + if (dpkg_architecture_value("DEB_HOST_GNU_TYPE") ne dpkg_architecture_value("DEB_TARGET_GNU_TYPE")) { + return dpkg_architecture_value("DEB_TARGET_GNU_TYPE") . "-$command"; + } + } + if (is_cross_compiling()) { + return dpkg_architecture_value("DEB_HOST_GNU_TYPE")."-$command"; + } + else { + return $command; + } +} + +# Returns the SOURCE_DATE_EPOCH ENV variable if set OR computes it +# from the latest changelog entry, sets the SOURCE_DATE_EPOCH ENV +# variable and returns the computed value. +sub get_source_date_epoch { + return $ENV{SOURCE_DATE_EPOCH} if exists($ENV{SOURCE_DATE_EPOCH}); + eval { require Dpkg::Changelog::Debian }; + if ($@) { + warning "unable to set SOURCE_DATE_EPOCH: $@"; + return; + } + eval { require Time::Piece }; + if ($@) { + warning "unable to set SOURCE_DATE_EPOCH: $@"; + return; + } + + my $changelog = Dpkg::Changelog::Debian->new(range => {"count" => 1}); + $changelog->load("debian/changelog"); + + my $tt = @{$changelog}[0]->get_timestamp(); + $tt =~ s/\s*\([^\)]+\)\s*$//; # Remove the optional timezone codename + my $timestamp = Time::Piece->strptime($tt, "%a, %d %b %Y %T %z"); + + return $ENV{SOURCE_DATE_EPOCH} = $timestamp->epoch(); +} + +# Setup the build ENV by setting dpkg-buildflags (via set_buildflags()) plus +# cleaning up HOME (etc) in compat 13+ +sub setup_buildenv { + set_buildflags(); + if (not compat(12)) { + setup_home_and_xdg_dirs(); + } +} + +sub setup_home_and_xdg_dirs { + 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 + ); + install_dir(@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 \"dherrron\" 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_shbang_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/.lintian-overrides) into +# the package. Under compat 9+ it may execute the file and use its +# output instead. +# +# install_dh_config_file(SOURCE, TARGET[, MODE]) +sub install_dh_config_file { + my ($source, $target, $mode) = @_; + $mode = 0644 if not defined($mode); + + if (!compat(8) and -x $source) { + my @sstat = stat(_) || error("cannot stat $source: $!"); + open(my $tfd, '>', $target) || error("cannot open $target: $!"); + chmod($mode, $tfd) || error("cannot chmod $target: $!"); + open(my $sfd, '-|', $source) || error("cannot run $source: $!"); + while (my $line = <$sfd>) { + print ${tfd} $line; + } + if (!close($sfd)) { + _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_to_path($mode, $source, $target); + } + return 1; +} + +sub restore_file_on_clean { + my ($file) = @_; + my $bucket_index = 'debian/.debhelper/bucket/index'; + my $bucket_dir = 'debian/.debhelper/bucket/files'; + my $checksum; + install_dir($bucket_dir); + if ($file =~ m{^/}) { + error("restore_file_on_clean requires a path relative to the package dir"); + } + $file =~ s{^\./}{}g; + $file =~ s{//++}{}g; + if ($file =~ m{^\.} or $file =~ m{/CVS/} or $file =~ m{/\.svn/}) { + # We do not want to smash a Vcs repository by accident. + warning("Attempt to store $file, which looks like a VCS file or"); + warning("a hidden package file (like quilt's \".pc\" directory)"); + error("This tool probably contains a bug."); + } + if (-l $file or not -f _) { + error("Cannot store $file: Can only store regular files (no symlinks, etc.)"); + } + require Digest::SHA; + + $checksum = Digest::SHA->new('256')->addfile($file, 'b')->hexdigest; + + if (not $dh{NO_ACT}) { + my ($in_index); + open(my $fd, '+>>', $bucket_index) + or error("open($bucket_index, a+) failed: $!"); + seek($fd, 0, 0); + while (my $line = <$fd>) { + my ($cs, $stored_file); + chomp($line); + ($cs, $stored_file) = split(m/ /, $line, 2); + next if ($stored_file ne $file); + $in_index = 1; + } + if (not $in_index) { + # Copy and then rename so we always have the full copy of + # the file in the correct place (if any at all). + doit('cp', '-an', '--reflink=auto', $file, "${bucket_dir}/${checksum}.tmp"); + rename_path("${bucket_dir}/${checksum}.tmp", "${bucket_dir}/${checksum}"); + print {$fd} "${checksum} ${file}\n"; + } + close($fd) or error("close($bucket_index) failed: $!"); + } + + return 1; +} + +sub restore_all_files { + my ($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 $log = generated_file($package, 'installed-by-' . basename($0)); + open(my $fh, '>>', $log) or error("open $log: $!"); + for my $src (@patterns) { + print $fh "$src\n"; + } + close($fh) or error("close $log: $!"); + + return 1; +} + +use constant { + # The ELF header is at least 0x32 bytes (32bit); any filer shorter than that is not an ELF file + ELF_MIN_LENGTH => 0x32, + ELF_MAGIC => "\x7FELF", + ELF_ENDIAN_LE => 0x01, + ELF_ENDIAN_BE => 0x02, + ELF_TYPE_EXECUTABLE => 0x0002, + ELF_TYPE_SHARED_OBJECT => 0x0003, +}; + +sub is_so_or_exec_elf_file { + my ($file) = @_; + open(my $fd, '<:raw', $file) or error("open $file: $!"); + my $buflen = 0; + my ($buf, $endian); + while ($buflen < ELF_MIN_LENGTH) { + my $r = read($fd, $buf, ELF_MIN_LENGTH - $buflen, $buflen) // error("read ($file): $!"); + last if $r == 0; # EOF + $buflen += $r + } + close($fd); + return 0 if $buflen < ELF_MIN_LENGTH; + + return 0 if substr($buf, 0x00, 4) ne ELF_MAGIC; + $endian = unpack('c', substr($buf, 0x05, 1)); + my ($long_format, $short_format); + + if ($endian == ELF_ENDIAN_BE) { + $long_format = 'N'; + $short_format = 'n'; + } elsif ($endian == ELF_ENDIAN_LE) { + $long_format = 'V'; + $short_format = 'v'; + } else { + return 0; + } + my $elf_version = substr($buf, 0x14, 4); + my $elf_type = substr($buf, 0x10, 2); + + + return 0 if unpack($long_format, $elf_version) != 0x00000001; + my $elf_type_unpacked = unpack($short_format, $elf_type); + return 0 if $elf_type_unpacked != ELF_TYPE_EXECUTABLE and $elf_type_unpacked != ELF_TYPE_SHARED_OBJECT; + return 1; +} + +sub _has_shbang_line { + my ($file) = @_; + open(my $fd, '<', $file) or error("open $file: $!"); + my $line = <$fd>; + close($fd); + return 1 if (defined($line) and substr($line, 0, 2) eq '#!'); + return 0; +} + +# Returns true iff the given argument is an empty directory. +# Corner-cases: +# - false if not a directory +sub is_empty_dir { + my ($dir) = @_; + return 0 if not -d $dir; + my $ret = 1; + opendir(my $dir_fd, $dir) or error("opendir($dir) failed: $!"); + while (defined(my $entry = readdir($dir_fd))) { + next if $entry eq '.' or $entry eq '..'; + $ret = 0; + last; + } + closedir($dir_fd); + return $ret; +} + +sub on_pkgs_in_parallel(&) { + unshift(@_, $dh{DOPACKAGES}); + goto \&on_items_in_parallel; +} + +# Given a list of files, find all hardlinked files and return: +# 1: a list of unique files (all files in the list are not hardlinked with any other file in that list) +# 2: a map where the keys are names of hardlinks and the value points to the name selected as the file put in the +# list of unique files. +# +# This is can be used to relink hard links after modifying one of them. +sub find_hardlinks { + my (@all_files) = @_; + my (%seen, %hardlinks, @unique_files); + for my $file (@all_files) { + my ($dev, $inode, undef, $nlink)=stat($file); + if (defined $nlink && $nlink > 1) { + if (! $seen{"$inode.$dev"}) { + $seen{"$inode.$dev"}=$file; + push(@unique_files, $file); + } else { + # This is a hardlink. + $hardlinks{$file}=$seen{"$inode.$dev"}; + } + } else { + push(@unique_files, $file); + } + } + return (\@unique_files, \%hardlinks); +} + +sub on_items_in_parallel { + my ($pkgs_ref, $code) = @_; + my @pkgs = @{$pkgs_ref}; + my %pids; + my $parallel = $MAX_PROCS; + my $count_per_proc = int( (scalar(@pkgs) + $parallel - 1)/ $parallel); + my $exit = 0; + if ($count_per_proc < 1) { + $count_per_proc = 1; + if (@pkgs > 3) { + # Forking has a considerable overhead, so bulk the number + # a bit. We do not do this unconditionally, because we + # want parallel issues (if any) to appear already with 2 + # packages and two procs (because people are lazy when + # testing). + # + # Same reason for also unconditionally forking with 1 pkg + # in 1 proc. + $count_per_proc = 2; + } + } + # Assertion, $count_per_proc * $parallel >= scalar(@pkgs) + while (@pkgs) { + my @batch = splice(@pkgs, 0, $count_per_proc); + my $pid = fork() // error("fork: $!"); + if (not $pid) { + # Child processes should not write to the log file + inhibit_log(); + eval { + $code->(@batch); + }; + if (my $err = $@) { + $err =~ s/\n$//; + print STDERR "$err\n"; + exit(2); + } + exit(0); + } + $pids{$pid} = 1; + } + while (%pids) { + my $pid = wait; + error("wait() failed: $!") if $pid == -1; + delete($pids{$pid}); + if ($? != 0) { + $exit = 1; + } + } + if ($exit) { + error("Aborting due to earlier error"); + } + return; +} + +*on_selected_pkgs_in_parallel = \&on_items_in_parallel; + +sub compute_doc_main_package { + my ($doc_package) = @_; + # if explicitly set, then choose that. + return $dh{DOC_MAIN_PACKAGE} if $dh{DOC_MAIN_PACKAGE}; + # In compat 10 (and earlier), there is no auto-detection + return $doc_package if compat(10); + my $target_package = $doc_package; + # If it is not a -doc package, then docs should be installed + # under its own package name. + return $doc_package if $target_package !~ s/-doc$//; + # FOO-doc hosts the docs for FOO; seems reasonable + return $target_package if exists($package_types{$target_package}); + if ($doc_package =~ m/^lib./) { + # Special case, "libFOO-doc" can host docs for "libFOO-dev" + my $lib_dev = "${target_package}-dev"; + return $lib_dev if exists($package_types{$lib_dev}); + # Technically, we could go look for a libFOO-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 diff --git a/lib/Debian/Debhelper/Sequence.pm b/lib/Debian/Debhelper/Sequence.pm new file mode 100644 index 0000000..ba627f4 --- /dev/null +++ b/lib/Debian/Debhelper/Sequence.pm @@ -0,0 +1,131 @@ +#!/usr/bin/perl +# +# Internal library functions for the dh(1) command + +package Debian::Debhelper::Sequence; +use strict; +use warnings; + +use Exporter qw(import); + +use Debian::Debhelper::Dh_Lib qw(error); +use Debian::Debhelper::SequencerUtil qw(extract_rules_target_name sequence_type SEQUENCE_NO_SUBSEQUENCES + SEQUENCE_ARCH_INDEP_SUBSEQUENCES SEQUENCE_TYPE_ARCH_ONLY SEQUENCE_TYPE_INDEP_ONLY SEQUENCE_TYPE_BOTH + FLAG_OPT_SOURCE_BUILDS_NO_ARCH_PACKAGES FLAG_OPT_SOURCE_BUILDS_NO_INDEP_PACKAGES); + + +sub _as_command { + my ($input) = @_; + if (ref($input) eq 'HASH') { + return $input; + } + my $rules_target = extract_rules_target_name($input); + if (defined($rules_target)) { + my $sequence_type = sequence_type($rules_target); + return { + 'command' => $input, + 'command-options' => [], + 'sequence-limitation' => $sequence_type, + } + } + return { + 'command' => $input, + 'command-options' => [], + 'sequence-limitation' => SEQUENCE_TYPE_BOTH, + } +} + +sub new { + my ($class, $name, $sequence_type, @cmds) = @_; + return bless({ + '_name' => $name, + '_subsequences' => $sequence_type, + '_cmds' => [map {_as_command($_)} @cmds], + }, $class); +} + +sub name { + my ($this) = @_; + return $this->{'_name'}; +} + +sub allowed_subsequences { + my ($this) = @_; + return $this->{'_subsequences'}; +} + +sub _insert { + my ($this, $offset, $existing, $new) = @_; + my @list = @{$this->{'_cmds'}}; + my @new; + my $new_cmd = _as_command($new); + foreach my $command (@list) { + if ($command->{'command'} eq $existing) { + push(@new, $new_cmd) if $offset < 0; + push(@new, $command); + push(@new, $new_cmd) if $offset > 0; + } else { + push(@new, $command); + } + } + $this->{'_cmds'} = \@new; + return; +} + +sub remove_command { + my ($this, $command) = @_; + $this->{'_cmds'} = [grep { $_->{'command'} ne $command } @{$this->{'_cmds'}}]; + return; +} + +sub add_command_at_start { + my ($this, $command) = @_; + unshift(@{$this->{'_cmds'}}, _as_command($command)); + return; +} + +sub add_command_at_end { + my ($this, $command) = @_; + push(@{$this->{'_cmds'}}, _as_command($command)); + return; +} + +sub rules_target_name { + my ($this, $sequence_type) = @_; + error("Internal error: Invalid sequence type $sequence_type") if $sequence_type eq SEQUENCE_NO_SUBSEQUENCES; + my $name = $this->{'_name'}; + my $allowed_sequence_type = $this->{'_subsequences'}; + if ($sequence_type ne SEQUENCE_TYPE_BOTH and $allowed_sequence_type eq SEQUENCE_NO_SUBSEQUENCES) { + error("Internal error: Requested subsequence ${sequence_type} of sequence ${name}, but it has no subsequences"); + } + if ($sequence_type ne SEQUENCE_TYPE_BOTH) { + return "${name}-${sequence_type}"; + } + return $name; +} + +sub as_rules_target_command { + my ($this) = shift; + my $rules_name = $this->rules_target_name(@_); + return "debian/rules ${rules_name}"; +} + +sub flatten_sequence { + my ($this, $sequence_type, $flags) = @_; + error("Invalid sequence type $sequence_type") if $sequence_type eq SEQUENCE_NO_SUBSEQUENCES; + my @cmds; + for my $cmd_desc (@{$this->{'_cmds'}}) { + my $seq_limitation = $cmd_desc->{'sequence-limitation'}; + next if ($seq_limitation eq SEQUENCE_TYPE_ARCH_ONLY and ($flags & FLAG_OPT_SOURCE_BUILDS_NO_ARCH_PACKAGES)); + next if ($seq_limitation eq SEQUENCE_TYPE_INDEP_ONLY and ($flags & FLAG_OPT_SOURCE_BUILDS_NO_INDEP_PACKAGES)); + if ($seq_limitation eq $sequence_type or $sequence_type eq SEQUENCE_TYPE_BOTH or $seq_limitation eq SEQUENCE_TYPE_BOTH) { + my $cmd = $cmd_desc->{'command'}; + my @cmd_options = $cmd_desc->{'command-options'}; + push(@cmds, [$cmd, @cmd_options]); + next; + } + } + return @cmds; +} + +1; diff --git a/lib/Debian/Debhelper/Sequence/build_stamp.pm b/lib/Debian/Debhelper/Sequence/build_stamp.pm new file mode 100644 index 0000000..5c05975 --- /dev/null +++ b/lib/Debian/Debhelper/Sequence/build_stamp.pm @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +add_command_at_end('create-stamp debian/debhelper-build-stamp', 'build'); +add_command_at_end('create-stamp debian/debhelper-build-stamp', 'build-arch'); +add_command_at_end('create-stamp debian/debhelper-build-stamp', 'build-indep'); + +1 diff --git a/lib/Debian/Debhelper/Sequence/dwz.pm b/lib/Debian/Debhelper/Sequence/dwz.pm new file mode 100644 index 0000000..2e89ffa --- /dev/null +++ b/lib/Debian/Debhelper/Sequence/dwz.pm @@ -0,0 +1,14 @@ +#!/usr/bin/perl +# Enable dh_dwz + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(compat error); + +if (not compat(11)) { + error("In compat 12, dh_dwz is run by default and the dwz-sequence is no longer required."); +} + +insert_before('dh_strip', 'dh_dwz'); + +1; diff --git a/lib/Debian/Debhelper/Sequence/elf_tools.pm b/lib/Debian/Debhelper/Sequence/elf_tools.pm new file mode 100644 index 0000000..56bb07c --- /dev/null +++ b/lib/Debian/Debhelper/Sequence/elf_tools.pm @@ -0,0 +1,14 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(compat); + +insert_after('dh_missing', 'dh_strip'); +if (not compat(11)) { + insert_before('dh_strip', 'dh_dwz'); +} +insert_after('dh_strip', 'dh_makeshlibs'); +insert_after('dh_makeshlibs', 'dh_shlibdeps'); + +1; \ No newline at end of file diff --git a/lib/Debian/Debhelper/Sequence/installinitramfs.pm b/lib/Debian/Debhelper/Sequence/installinitramfs.pm new file mode 100644 index 0000000..365f283 --- /dev/null +++ b/lib/Debian/Debhelper/Sequence/installinitramfs.pm @@ -0,0 +1,14 @@ +#!/usr/bin/perl +# Enable dh_installinitramfs + +use strict; +use warnings; +use Debian::Debhelper::Dh_Lib qw(compat error); + +if (not compat(11)) { + error("In compat 12, dh_installinitramfs is run by default and the installinitramfs-sequence is no longer required."); +} + +insert_after('dh_installgsettings', 'dh_installinitramfs'); + +1; diff --git a/lib/Debian/Debhelper/Sequence/python_support.pm b/lib/Debian/Debhelper/Sequence/python_support.pm new file mode 100644 index 0000000..383407f --- /dev/null +++ b/lib/Debian/Debhelper/Sequence/python_support.pm @@ -0,0 +1,10 @@ +#!/usr/bin/perl +# Obsolete debhelper sequence file for python-support + +use warnings; +use strict; +use Debian::Debhelper::Dh_Lib qw(deprecated_functionality); + +deprecated_functionality('python_support sequence does nothing as dh_pysupport is no longer available', 11); + +1 diff --git a/lib/Debian/Debhelper/Sequence/root_sequence.pm b/lib/Debian/Debhelper/Sequence/root_sequence.pm new file mode 100644 index 0000000..105076f --- /dev/null +++ b/lib/Debian/Debhelper/Sequence/root_sequence.pm @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Debian::Debhelper::Dh_Lib qw(compat); +use Debian::Debhelper::SequencerUtil; + +my $include_if_compat_X_or_newer = sub { + my ($compat, @commands) = @_; + return if compat($compat - 1, 1); + return @commands; +}; + +my @obsolete_command = ( + $include_if_compat_X_or_newer->(11, 'dh_systemd_enable', 'dh_systemd_start'), +); + +my @commands_controlled_by_deb_build_options = ( + $include_if_compat_X_or_newer->(13, ['dh_auto_test', 'nocheck'], ['dh_dwz', 'nostrip'], ['dh_strip', 'nostrip']), +); + +my @bd_minimal = qw{ + dh_testdir +}; +my @bd = (@bd_minimal, qw{ + dh_update_autotools_config + dh_auto_configure + dh_auto_build + dh_auto_test +}); +my @i = (qw{ + dh_testroot + dh_prep + dh_installdirs + dh_auto_install + + dh_install + dh_installdocs + dh_installchangelogs + dh_installexamples + dh_installman + + dh_installcatalogs + dh_installcron + dh_installdebconf + dh_installemacsen + dh_installifupdown + dh_installinfo + dh_installinit +}, + $include_if_compat_X_or_newer->(13, 'dh_installtmpfiles'), + $include_if_compat_X_or_newer->(14, 'dh_installsysusers'), + $include_if_compat_X_or_newer->(11, 'dh_installsystemd'), + $include_if_compat_X_or_newer->(12, 'dh_installsystemduser'), +qw{ + dh_installmenu + dh_installmime + dh_installmodules + dh_installlogcheck + dh_installlogrotate + dh_installpam + dh_installppp + dh_installudev + dh_installgsettings +}, + (!compat(11) ? qw(dh_installinitramfs) : qw()), +qw{ + dh_installalternatives + dh_bugfiles + dh_ucf + dh_lintian + dh_gconf + dh_icons + dh_perl + dh_usrlocal + + dh_link + dh_installwm + dh_installxfonts + dh_strip_nondeterminism + dh_compress + dh_fixperms + dh_missing +}); + +# Looking for dh_dwz, dh_strip, dh_makeshlibs, dh_shlibdeps (et al)? They are +# in the elf-tools addon. +my @b=qw{ + dh_installdeb + dh_gencontrol + dh_md5sums + dh_builddeb +}; + +_add_sequence('build', SEQUENCE_ARCH_INDEP_SUBSEQUENCES, @bd); +_add_sequence('install', SEQUENCE_ARCH_INDEP_SUBSEQUENCES, to_rules_target("build"), @i); +_add_sequence('binary', SEQUENCE_ARCH_INDEP_SUBSEQUENCES, to_rules_target("install"), @b); +_add_sequence('clean', SEQUENCE_NO_SUBSEQUENCES, @bd_minimal, qw{ + dh_auto_clean + dh_clean +}); + +for my $command (@obsolete_command) { + declare_command_obsolete($command); +} + +for my $entry (@commands_controlled_by_deb_build_options) { + my ($command, $dbo_flag) = @{$entry}; + # Dear reader; Should you be in doubt, then this is internal API that is + # subject to change without notice. If you need this feature, please + # make an explicit feature request, so we can implement a better solution. + _skip_cmd_if_deb_build_options_contains($command, $dbo_flag); +} + +1; diff --git a/lib/Debian/Debhelper/Sequence/systemd.pm b/lib/Debian/Debhelper/Sequence/systemd.pm new file mode 100644 index 0000000..484e764 --- /dev/null +++ b/lib/Debian/Debhelper/Sequence/systemd.pm @@ -0,0 +1,19 @@ +#!/usr/bin/perl +use warnings; +use strict; +use Debian::Debhelper::Dh_Lib qw(compat error); + +if (not compat(10)) { + error("The systemd-sequence is no longer provided in compat >= 11, please rely on dh_installsystemd instead"); +} + + +# dh_systemd_enable runs unconditionally, and before dh_installinit, so that +# the latter can use invoke-rc.d and all symlinks are already in place. +insert_before("dh_installinit", "dh_systemd_enable"); + +# dh_systemd_start handles the case where there is no corresponding init +# script, so it runs after dh_installinit. +insert_after("dh_installinit", "dh_systemd_start"); + +1 diff --git a/lib/Debian/Debhelper/SequencerUtil.pm b/lib/Debian/Debhelper/SequencerUtil.pm new file mode 100644 index 0000000..2b2531e --- /dev/null +++ b/lib/Debian/Debhelper/SequencerUtil.pm @@ -0,0 +1,836 @@ +#!/usr/bin/perl +# +# Internal library functions for the dh(1) command + +package Debian::Debhelper::SequencerUtil; +use strict; +use warnings; +use constant { + 'DUMMY_TARGET' => 'debhelper-fail-me', + 'SEQUENCE_NO_SUBSEQUENCES' => 'none', + 'SEQUENCE_ARCH_INDEP_SUBSEQUENCES' => 'both', + 'SEQUENCE_TYPE_ARCH_ONLY' => 'arch', + 'SEQUENCE_TYPE_INDEP_ONLY' => 'indep', + 'SEQUENCE_TYPE_BOTH' => 'both', + 'FLAG_OPT_SOURCE_BUILDS_NO_ARCH_PACKAGES' => 0x1, + 'FLAG_OPT_SOURCE_BUILDS_NO_INDEP_PACKAGES' => 0x2, + 'UNSKIPPABLE_CLI_OPTIONS_BUILD_SYSTEM' => q(-S|--buildsystem|-D|--sourcedir|--sourcedirectory|-B|--builddir|--builddirectory), +}; + +use Exporter qw(import); + +use Debian::Debhelper::Dh_Lib qw( + %dh + basename + commit_override_log + compat error + escape_shell + get_buildoption + getpackages + load_log + package_is_arch_all + pkgfile + rm_files + tmpdir + warning + write_log +); + + +our @EXPORT = qw( + extract_rules_target_name + to_rules_target + sequence_type + unpack_sequence + rules_explicit_target + extract_skipinfo + compute_selected_addons + load_sequence_addon + run_sequence_command_and_exit_on_failure + should_skip_due_to_dpo + check_for_obsolete_commands + compute_starting_point_in_sequences + parse_dh_cmd_options + run_hook_target + run_through_command_sequence + DUMMY_TARGET + SEQUENCE_NO_SUBSEQUENCES + SEQUENCE_ARCH_INDEP_SUBSEQUENCES + SEQUENCE_TYPE_ARCH_ONLY + SEQUENCE_TYPE_INDEP_ONLY + SEQUENCE_TYPE_BOTH + FLAG_OPT_SOURCE_BUILDS_NO_ARCH_PACKAGES + FLAG_OPT_SOURCE_BUILDS_NO_INDEP_PACKAGES +); + +our (%EXPLICIT_TARGETS, $RULES_PARSED); + +sub extract_rules_target_name { + my ($command) = @_; + if ($command =~ m{^debian/rules\s++(.++)}) { + return $1 + } + return; +} + +sub to_rules_target { + return 'debian/rules '.join(' ', @_); +} + +sub sequence_type { + my ($sequence_name) = @_; + if ($sequence_name =~ m/-indep$/) { + return 'indep'; + } elsif ($sequence_name =~ m/-arch$/) { + return 'arch'; + } + return 'both'; +} + +sub _agg_subseq { + my ($current_subseq, $outer_subseq) = @_; + if ($current_subseq eq $outer_subseq) { + return $current_subseq; + } + if ($current_subseq eq 'both') { + return $outer_subseq; + } + return $current_subseq; +} + +sub unpack_sequence { + my ($sequences, $sequence_name, $always_inline, $completed_sequences, $flags) = @_; + my (@sequence, @targets, %seen, %non_inlineable_targets, @stack); + my $sequence_type = sequence_type($sequence_name); + # Walk through the sequence effectively doing a DFS of the rules targets + # (when we are allowed to inline them). + my $seq = $sequences->{$sequence_name}; + $flags //= 0; + + push(@stack, [$seq->flatten_sequence($sequence_type, $flags)]); + while (@stack) { + my $current_sequence = pop(@stack); + COMMAND: + while (@{$current_sequence}) { + my $command = shift(@{$current_sequence}); + if (ref($command) eq 'ARRAY') { + $command = $command->[0]; + } + my $rules_target=extract_rules_target_name($command); + next if (defined($rules_target) and exists($completed_sequences->{$rules_target})); + if (defined($rules_target) and $always_inline) { + my $subsequence = $sequences->{$rules_target}; + my $subseq_type = _agg_subseq(sequence_type($rules_target), $sequence_type); + push(@stack, $current_sequence); + $current_sequence = [$subsequence->flatten_sequence($subseq_type, $flags)]; + } elsif (defined($rules_target)) { + my $subsequence = $sequences->{$rules_target}; + my $subseq_type = _agg_subseq(sequence_type($rules_target), $sequence_type); + my @subseq_types = ($subseq_type); + my %subtarget_status; + my ($transparent_subseq, $opaque_subseq, $subtarget_decided_both); + if ($subseq_type eq SEQUENCE_TYPE_BOTH) { + push(@subseq_types, SEQUENCE_TYPE_ARCH_ONLY, SEQUENCE_TYPE_INDEP_ONLY); + } + for my $ss_type (@subseq_types) { + my $full_rule_target = ($ss_type eq SEQUENCE_TYPE_BOTH) ? $rules_target : "${rules_target}-${ss_type}"; + if (exists($completed_sequences->{$full_rule_target})) { + $subtarget_status{$ss_type} = 'complete'; + last if $ss_type eq $subseq_type; + } + elsif (defined(rules_explicit_target($full_rule_target))) { + $subtarget_status{$ss_type} = 'opaque'; + last if $ss_type eq $subseq_type; + } + else { + $subtarget_status{$ss_type} = 'transparent'; + } + } + # At this point, %subtarget_status has 1 or 3 kv-pairs. + # - If it has 1, then just check that and be done + # - If it has 3, then "both" must be "transparent". + + if (scalar(keys(%subtarget_status)) == 3) { + if ($subtarget_status{${\SEQUENCE_TYPE_ARCH_ONLY}} eq $subtarget_status{${\SEQUENCE_TYPE_INDEP_ONLY}}) { + # The "both" target is transparent and the subtargets agree. This is the common case + # of "everything is transparent" (or both subtargets are opaque) and we reduce that by + # reducing it to only have one key. + %subtarget_status = ( $subseq_type => $subtarget_status{${\SEQUENCE_TYPE_ARCH_ONLY}} ); + # There is one special-case for this flow if both targets are opaque. + $subtarget_decided_both = 1; + } else { + # The subtargets have different status but we know that the "both" key must be irrelevant + # then. Remove it to simplify matters below. + delete($subtarget_status{${\SEQUENCE_TYPE_BOTH}}); + } + } + + if (scalar(keys(%subtarget_status)) == 1) { + # "Simple" case where we only have to check exactly one result + if ($subtarget_status{$subseq_type} eq 'opaque') { + $opaque_subseq = $subseq_type; + } + elsif ($subtarget_status{$subseq_type} eq 'transparent') { + $transparent_subseq = $subseq_type; + } + } else { + # Either can be transparent, opaque or complete at this point. + if ($subtarget_status{${\SEQUENCE_TYPE_ARCH_ONLY}} eq 'transparent') { + $transparent_subseq = SEQUENCE_TYPE_ARCH_ONLY + } elsif ($subtarget_status{${\SEQUENCE_TYPE_INDEP_ONLY}} eq 'transparent') { + $transparent_subseq = SEQUENCE_TYPE_INDEP_ONLY + } + if ($subtarget_status{${\SEQUENCE_TYPE_ARCH_ONLY}} eq 'opaque') { + $opaque_subseq = SEQUENCE_TYPE_ARCH_ONLY + } elsif ($subtarget_status{${\SEQUENCE_TYPE_INDEP_ONLY}} eq 'opaque') { + $opaque_subseq = SEQUENCE_TYPE_INDEP_ONLY + } + } + if ($opaque_subseq) { + if ($subtarget_decided_both) { + # Final special-case - we are here because the rules file define X-arch AND X-indep but + # not X. In this case, we want two d/rules X-{arch,indep} calls rather than a single + # d/rules X call. + for my $ss_type ((SEQUENCE_TYPE_ARCH_ONLY, SEQUENCE_TYPE_INDEP_ONLY)) { + my $rules_target_cmd = $subsequence->as_rules_target_command($ss_type); + push(@targets, $rules_target_cmd) if not $seen{$rules_target_cmd}++; + } + } else { + my $rules_target_cmd = $subsequence->as_rules_target_command($opaque_subseq); + push(@targets, $rules_target_cmd) if not $seen{$rules_target_cmd}++; + } + } + if ($transparent_subseq) { + push(@stack, $current_sequence); + $current_sequence = [$subsequence->flatten_sequence($transparent_subseq, $flags)]; + } + next COMMAND; + } else { + if (defined($rules_target) and not $always_inline) { + next COMMAND if exists($non_inlineable_targets{$rules_target}); + push(@targets, $command) if not $seen{$command}++; + } elsif (! $seen{$command}) { + $seen{$command} = 1; + push(@sequence, $command); + } + } + } + } + return (\@targets, \@sequence); +} + + +sub rules_explicit_target { + # Checks if a specified target exists as an explicit target + # in debian/rules. + # undef is returned if target does not exist, 0 if target is noop + # and 1 if target has dependencies or executes commands. + my ($target) = @_; + + if (! $RULES_PARSED) { + my $processing_targets = 0; + my $not_a_target = 0; + my $current_target; + open(MAKE, "LC_ALL=C make -Rrnpsf debian/rules ${\DUMMY_TARGET} 2>/dev/null |"); + while () { + if ($processing_targets) { + if (/^# Not a target:/) { + $not_a_target = 1; + } else { + if (!$not_a_target && m/^([^#:]+)::?\s*(.*)$/) { + # Target is defined. NOTE: if it is a dependency of + # .PHONY it will be defined too but that's ok. + # $2 contains target dependencies if any. + $current_target = $1; + $EXPLICIT_TARGETS{$current_target} = ($2) ? 1 : 0; + } else { + if (defined($current_target)) { + if (m/^#/) { + # Check if target has commands to execute + if (m/^#\s*(commands|recipe) to execute/) { + $EXPLICIT_TARGETS{$current_target} = 1; + } + } else { + # Target parsed. + $current_target = undef; + } + } + } + # "Not a target:" is always followed by + # a target name, so resetting this one + # here is safe. + $not_a_target = 0; + } + } elsif (m/^# Files$/) { + $processing_targets = 1; + } + } + close MAKE; + $RULES_PARSED = 1; + } + + return $EXPLICIT_TARGETS{$target}; +} + +sub extract_skipinfo { + my ($command) = @_; + + foreach my $dir (split(':', $ENV{PATH})) { + if (open (my $h, "<", "$dir/$command")) { + while (<$h>) { + if (m/PROMISE: DH NOOP( WITHOUT\s+(.*))?\s*$/) { + close $h; + return split(' ', $2) if defined($2); + return ('always-skip'); + } + } + close $h; + return; + } + } + return; +} + +sub _skipped_call_due_dpo { + my ($command, $dbo_flag) = @_; + my $me = Debian::Debhelper::Dh_Lib::_color(basename($0), 'bold'); + my $skipped = Debian::Debhelper::Dh_Lib::_color('command-omitted', 'yellow'); + print "${me}: ${skipped}: The call to \"${command}\" was omitted due to \"DEB_BUILD_OPTIONS=${dbo_flag}\"\n"; + return; +} + +sub should_skip_due_to_dpo { + my ($command, $to_be_invoked) = @_; + + # Indirection/reference for readability + my $commands_ref = \%Debian::Debhelper::DH::SequenceState::commands_skippable_via_deb_build_options; + + if (not $dh{'NO_ACT'} and exists($commands_ref->{$command})) { + my $flags_ref = $commands_ref->{$command}; + for my $flag (@{$flags_ref}) { + if (get_buildoption($flag)) { + _skipped_call_due_dpo($to_be_invoked, $flag) if defined($to_be_invoked); + return 1; + } + } + } + return 0; +} + +sub compute_starting_point_in_sequences { + my ($packages_ref, $full_sequence, $logged) = @_; + my %startpoint; + if (compat(9)) { + foreach my $package (@{$packages_ref}) { + my @log = load_log($package, $logged); + # Find the last logged command that is in the sequence, and + # continue with the next command after it. If no logged + # command is in the sequence, we're starting at the beginning.. + $startpoint{$package} = 0; + COMMAND: + foreach my $command (reverse(@log)) { + foreach my $i (0 .. $#{$full_sequence}) { + if ($command eq $full_sequence->[$i]) { + $startpoint{$package} = $i + 1; + last COMMAND; + } + } + } + } + } else { + foreach my $package (@{$packages_ref}) { + $startpoint{$package} = 0; + } + } + return %startpoint; +} + + +sub compute_selected_addons { + my ($sequence_name, @addon_requests_from_args) = @_; + my (@enabled_addons, %disabled_addons, %enabled); + my @addon_requests; + my $sequence_type = sequence_type($sequence_name); + + my %addon_constraints = %{ Debian::Debhelper::Dh_Lib::bd_dh_sequences() }; + + # Inject elf-tools early as other addons rely on their presence and it historically + # has been considered a part of the "core" sequence. + if (exists($addon_constraints{'elf-tools'})) { + # Explicitly requested; respect that + push(@addon_requests, '+elf-tools'); + } elsif (compat(12, 1)) { + # In compat 12 and earlier, we only inject the sequence if there are arch + # packages present and the sequence requires it. + if (getpackages('arch') and $sequence_type ne SEQUENCE_TYPE_INDEP_ONLY) { + push(@addon_requests, '+elf-tools'); + } + } else { + # In compat 13, we always inject the addon if not explicitly requested and + # then flag it as arch_only + push(@addon_requests, '+elf-tools'); + $addon_constraints{'elf-tools'} = SEQUENCE_TYPE_ARCH_ONLY if not exists($addon_constraints{'elf-tools'}); + } + + # Order is important; DH_EXTRA_ADDONS must come before everything + # else; then comes built-in and finally argument provided add-ons + # requests. + push(@addon_requests, map { "+${_}" } split(",", $ENV{DH_EXTRA_ADDONS})) + if $ENV{DH_EXTRA_ADDONS}; + if (not compat(9, 1)) { + # Enable autoreconf'ing by default in compat 10 or later. + push(@addon_requests, '+autoreconf'); + + # Enable systemd support by default in compat 10 or later. + # - compat 11 injects the dh_installsystemd tool directly in the + # sequence instead of using a --with sequence. + push(@addon_requests, '+systemd') if compat(10, 1); + push(@addon_requests, '+build-stamp'); + } + for my $addon_name (sort(keys(%addon_constraints))) { + my $addon_type = $addon_constraints{$addon_name}; + + # Special-case for the "clean" target to avoid B-D-I dependencies in that for conditional add-ons + next if $sequence_name eq 'clean' and $addon_type ne SEQUENCE_TYPE_BOTH; + if ($addon_type eq 'both' or $sequence_type eq 'both' or $addon_type eq $sequence_type) { + push(@addon_requests, "+${addon_name}"); + } + } + + push(@addon_requests, @addon_requests_from_args); + + # Removing disabled add-ons are expensive (O(N) per time), so we + # attempt to make removals in bulk. Note that we have to be order + # preserving (due to #885580), so there is a limit to how "smart" + # we can be. + my $flush_disable_cache = sub { + @enabled_addons = grep { not exists($disabled_addons{$_}) } @enabled_addons; + for my $addon (keys(%disabled_addons)) { + delete($enabled{$addon}); + } + %disabled_addons = (); + }; + + for my $request (@addon_requests) { + if ($request =~ m/^[+-]root[-_]sequence$/) { + error("Invalid request to skip the sequence \"root-sequence\": It cannot be disabled") + if $request =~ m/^-/; + error("Invalid request to load the sequence \"root-sequence\": Do not reference it directly"); + } + if ($request =~ s/^[+]//) { + $flush_disable_cache->() if %disabled_addons; + push(@enabled_addons, $request) if not $enabled{$request}++; + } elsif ($request =~ s/^-//) { + $disabled_addons{$request} = 1; + } else { + error("Internal error: Invalid add-on request: $request (Missing +/- prefix)"); + } + } + + $flush_disable_cache->() if %disabled_addons; + return map { + { + 'name' => $_, + 'addon-type' => $addon_constraints{$_} // SEQUENCE_TYPE_BOTH, + } + } @enabled_addons; +} + + +sub load_sequence_addon { + my ($addon_name, $addon_type) = @_; + require Debian::Debhelper::DH::AddonAPI; + my $mod="Debian::Debhelper::Sequence::${addon_name}"; + $mod=~s/-/_/g; + local $Debian::Debhelper::DH::AddonAPI::DH_INTERNAL_ADDON_NAME = $addon_name; + local $Debian::Debhelper::DH::AddonAPI::DH_INTERNAL_ADDON_TYPE = $addon_type; + eval "package Debian::Debhelper::DH::AddonAPI; use $mod"; + if ($@) { + error("unable to load addon ${addon_name}: $@"); + } +} + +sub check_for_obsolete_commands { + my ($full_sequence) = @_; + my ($found_obsolete_targets); + for my $command (@{$full_sequence}) { + if (exists($Debian::Debhelper::DH::SequenceState::obsolete_command{$command})) { + my $addon_name = $Debian::Debhelper::DH::SequenceState::obsolete_command{$command}; + error("The addon ${addon_name} claimed that $command was obsolete, but it is not!?"); + } + } + for my $command (sort(keys(%Debian::Debhelper::DH::SequenceState::obsolete_command))) { + for my $prefix (qw(execute_before_ execute_after_ override_)) { + for my $suffix ('', '-arch', '-indep') { + my $target = "${prefix}${command}${suffix}"; + if (defined(rules_explicit_target($target))) { + $found_obsolete_targets = 1; + warning("The target ${target} references a now obsolete command and will not be run!"); + } + } + } + } + if ($found_obsolete_targets and not compat(12)) { + error("Aborting due to left over override/hook targets for now removed commands."); + } + return; +} + +sub run_sequence_command_and_exit_on_failure { + my ($command, @options) = @_; + + # 3 space indent lines the command being run up under the + # sequence name after "dh ". + if (!$dh{QUIET}) { + print " ".escape_shell($command, @options)."\n"; + } + + return if $dh{NO_ACT}; + + my $ret=system { $command } $command, @options; + if ($ret >> 8 != 0) { + exit $ret >> 8; + } + if ($ret) { + exit 1; + } + return; +} + + +sub run_hook_target { + my ($target_stem, $min_compat_level, $command, $packages, @opts) = @_; + my @todo = @{$packages}; + foreach my $override_type (undef, "arch", "indep") { + @todo = _run_injected_rules_target($target_stem, $override_type, $min_compat_level, $command, \@todo, @opts); + } + return @todo; +} + +# Tries to run an override / hook target for a command. Returns the list of +# packages that it was unable to run the target for. +sub _run_injected_rules_target { + my ($target_stem, $override_type, $min_compat_level, $command, $packages, @options) = @_; + + my $rules_target = $target_stem . + (defined $override_type ? "-".$override_type : ""); + + $command //= $rules_target; # Ensure it is defined + + # Check which packages are of the right architecture for the + # override_type. + my (@todo, @rest); + my $has_explicit_target = rules_explicit_target($rules_target); + + if ($has_explicit_target and defined($min_compat_level) and compat($min_compat_level - 1)) { + error("Hook target ${rules_target} is only supported in compat ${min_compat_level} or later"); + } + + if (defined $override_type) { + foreach my $package (@{$packages}) { + my $isall=package_is_arch_all($package); + if (($override_type eq 'indep' && $isall) || + ($override_type eq 'arch' && !$isall)) { + push @todo, $package; + } else { + push @rest, $package; + push @options, "-N$package"; + } + } + } else { + @todo=@{$packages}; + } + + return @{$packages} unless defined $has_explicit_target; # no such override + return @rest if ! $has_explicit_target; # has empty override + return @rest unless @todo; # has override, but no packages to act on + return @rest if should_skip_due_to_dpo($command, "debian/rules $rules_target"); + + if (defined $override_type) { + # Ensure appropriate -a or -i option is passed when running + # an arch-specific override target. + my $opt=$override_type eq "arch" ? "-a" : "-i"; + push @options, $opt unless grep { $_ eq $opt } @options; + } + + # Discard any override log files before calling the override + # target + if (not compat(9)) { + my @files = glob('debian/*.debhelper.log'); + rm_files(@files) if @files; + } + # This passes the options through to commands called + # inside the target. + $ENV{DH_INTERNAL_OPTIONS}=join("\x1e", @options); + $ENV{DH_INTERNAL_OVERRIDE}=$command; + run_sequence_command_and_exit_on_failure("debian/rules", $rules_target); + delete $ENV{DH_INTERNAL_OPTIONS}; + delete $ENV{DH_INTERNAL_OVERRIDE}; + + # Update log for overridden command now that it has + # finished successfully. + # (But avoid logging for dh_clean since it removes + # the log earlier.) + if (! $dh{NO_ACT} && $command ne 'dh_clean' && compat(9)) { + write_log($command, @todo); + commit_override_log(@todo); + } + + # Override targets may introduce new helper files. Strictly + # speaking this *shouldn't* be necessary, but lets make no + # assumptions. + Debian::Debhelper::Dh_Lib::dh_clear_unsafe_cache(); + + return @rest; +} + + +# Options parsed to dh that may need to be passed on to helpers +sub parse_dh_cmd_options { + my (@argv) = @_; + + # Ref for readability + my $options_ref = \@Debian::Debhelper::DH::SequenceState::options; + + while (@argv) { + my $opt = shift(@argv); + if ($opt =~ /^--?(after|until|before|with|without)$/) { + shift(@argv); + next; + } elsif ($opt =~ /^--?(no-act|remaining|(after|until|before|with|without)=)/) { + next; + } elsif ($opt =~ /^-/) { + if (not @{$options_ref} and $opt eq '--parallel' or $opt eq '--no-parallel') { + my $max_parallel; + # Ignore the option if it is the default for the given + # compat level. + next if compat(9) and $opt eq '--no-parallel'; + next if not compat(9) and $opt eq '--parallel'; + # Having an non-empty "@options" hurts performance quite a + # bit. At the same time, we want to promote the use of + # --(no-)parallel, so "tweak" the options a bit if there + # is no reason to include this option. + $max_parallel = get_buildoption('parallel') // 1; + next if $max_parallel == 1; + } + if ($opt =~ m/^(--[^=]++)(?:=.*)?$/ or $opt =~ m/^(-[^-])(?:=.*)?$/) { + my $optname = $1; + if (length($optname) > 2 and (compat(12, 1) or $optname =~ m/^-[^-][^=]/)) { + # We cannot optimize bundled options but we can optimize a single + # short option with an explicit parameter (-B=F is ok, -BF is not) + # In compat 12 or earlier, we also punt on long options due to + # auto-abbreviation. + $Debian::Debhelper::DH::SequenceState::unoptimizable_option_bundle = 1 + } + $Debian::Debhelper::DH::SequenceState::seen_options{$optname} = 1; + } elsif ($opt =~ m/^-[^-][^-]/) { + # We cannot optimize bundled options but we can optimize a single + # short option with an explicit parameter (-B=F is ok, -BF is not) + $Debian::Debhelper::DH::SequenceState::unoptimizable_option_bundle = 1 + } else { + # Special case that disables NOOP cli-options() as well + $Debian::Debhelper::DH::SequenceState::unoptimizable_user_option = 1; + } + push(@{$options_ref}, "-O" . $opt); + } elsif (@{$options_ref}) { + if ($options_ref->[$#{$options_ref}] =~ /^-O--/) { + $options_ref->[$#{$options_ref}] .= '=' . $opt; + } else { + # Special case that disables NOOP cli-options() as well + $Debian::Debhelper::DH::SequenceState::unoptimizable_user_option = 1; + $options_ref->[$#{$options_ref}] .= $opt; + } + } else { + error("Unknown parameter: $opt"); + } + } + return; +} + + +sub run_through_command_sequence { + my ($full_sequence, $startpoint, $logged, $options, $all_packages, $arch_packages, $indep_packages) = @_; + + my $command_opts = \%Debian::Debhelper::DH::SequenceState::command_opts; + my $stoppoint = $#{$full_sequence}; + + # Now run the commands in the sequence. + foreach my $i (0 .. $stoppoint) { + my $command = $full_sequence->[$i]; + + # Figure out which packages need to run this command. + my (@todo, @opts); + my @filtered_packages = _active_packages_for_command($command, $all_packages, $arch_packages, $indep_packages); + + foreach my $package (@filtered_packages) { + if (($startpoint->{$package}//0) > $i || + $logged->{$package}{$full_sequence->[$i]}) { + push(@opts, "-N$package"); + } + else { + push(@todo, $package); + } + } + next unless @todo; + push(@opts, @{$options}); + + my $rules_target = extract_rules_target_name($command); + error("Internal error: $command is a rules target, but it is not supported to be!?") if defined($rules_target); + + if (my $stamp_file = _stamp_target($command)) { + my %seen; + print " create-stamp " . escape_shell($stamp_file) . "\n"; + + next if $dh{NO_ACT}; + open(my $fd, '+>>', $stamp_file) or error("open($stamp_file, rw) failed: $!"); + # Seek to the beginning + seek($fd, 0, 0) or error("seek($stamp_file) failed: $!"); + while (my $line = <$fd>) { + chomp($line); + $seen{$line} = 1; + } + for my $pkg (grep {not exists($seen{$_})} @todo) { + print {$fd} "$pkg\n"; + } + close($fd) or error("close($stamp_file) failed: $!"); + next; + } + + my @full_todo = @todo; + run_hook_target("execute_before_${command}", 10, $command, \@full_todo, @opts); + + # Check for override targets in debian/rules, and run instead of + # the usual command. (The non-arch-specific override is tried first, + # for simplest semantics; mixing it with arch-specific overrides + # makes little sense.) + @todo = run_hook_target("override_${command}", undef, $command, \@full_todo, @opts); + + if (@todo and not _can_skip_command($command, @todo)) { + # No need to run the command for any packages handled by the + # override targets. + my %todo = map {$_ => 1} @todo; + foreach my $package (@full_todo) { + if (!$todo{$package}) { + push @opts, "-N$package"; + } + } + if (not should_skip_due_to_dpo($command, Debian::Debhelper::Dh_Lib::_format_cmdline($command, @opts))) { + my @cmd_options; + # Include additional command options if any + push(@cmd_options, @{$command_opts->{$command}}) + if exists($command_opts->{$command}); + push(@cmd_options, @opts); + run_sequence_command_and_exit_on_failure($command, @cmd_options); + } + } + + run_hook_target("execute_after_${command}", 10, $command, \@full_todo, @opts); + } +} + + +sub _stamp_target { + my ($command) = @_; + if ($command =~ s/^create-stamp\s+//) { + return $command; + } + return; +} + +{ + my %skipinfo; + sub _can_skip_command { + my ($command, @packages) = @_; + + return 0 if $dh{NO_ACT} and not $ENV{DH_INTERNAL_TEST_CAN_SKIP}; + + return 0 if $Debian::Debhelper::DH::SequenceState::unoptimizable_user_option || + (exists $ENV{DH_OPTIONS} && length $ENV{DH_OPTIONS}); + + return 0 if exists($Debian::Debhelper::DH::SequenceState::command_opts{$command}) + and @{$Debian::Debhelper::DH::SequenceState::command_opts{$command}}; + + if (! defined $skipinfo{$command}) { + $skipinfo{$command}=[extract_skipinfo($command)]; + } + my @skipinfo=@{$skipinfo{$command}}; + return 0 unless @skipinfo; + return 1 if scalar(@skipinfo) == 1 and $skipinfo[0] eq 'always-skip'; + my ($all_pkgs, $had_cli_options); + + foreach my $skipinfo (@skipinfo) { + my $type = 'pkgfile'; + my $need = $skipinfo; + if ($skipinfo=~/^([a-zA-Z0-9-_]+)\((.*)\)$/) { + ($type, $need) = ($1, $2); + } + if ($type eq 'tmp') { + foreach my $package (@packages) { + my $tmp = tmpdir($package); + return 0 if -e "$tmp/$need"; + } + } elsif ($type eq 'pkgfile' or $type eq 'pkgfile-logged') { + my $pkgs; + if ($type eq 'pkgfile') { + $pkgs = \@packages; + } else { + $all_pkgs //= [ getpackages() ]; + $pkgs = $all_pkgs; + } + # Use the secret bulk check call + return 0 if pkgfile($pkgs, $need) ne ''; + } elsif ($type eq 'cli-options') { + $had_cli_options = 1; + # If cli-options is empty, we know the helper does not + # react to any thing and can always be skipped. + next if $need =~ m/^\s*$/; + # Long options are subject to abbreviations so it is + # very difficult to implement this optimization with + # long options. + return 0 if $Debian::Debhelper::DH::SequenceState::unoptimizable_option_bundle; + $need =~ s/(?:^|\s)BUILDSYSTEM(?:\s|$)/${\UNSKIPPABLE_CLI_OPTIONS_BUILD_SYSTEM}/; + my @behavior_options = split(qr/\Q|\E/, $need); + for my $opt (@behavior_options) { + return 0 if exists($Debian::Debhelper::DH::SequenceState::seen_options{$opt}); + } + } elsif ($type eq 'buildsystem') { + require Debian::Debhelper::Dh_Buildsystems; + my $system = Debian::Debhelper::Dh_Buildsystems::load_buildsystem(undef, $need); + return 0 if defined($system); + } elsif ($type eq 'internal') { + if ($need eq 'bug#950723') { + $all_pkgs //= [ getpackages() ]; + push(@{$all_pkgs}, map { "${_}@"} getpackages()); + push(@packages, map { "${_}@"} @packages); + } elsif ($need eq 'rrr') { + my $req = Debian::Debhelper::Dh_Lib::root_requirements(); + return 0 if $req ne 'none'; + } else { + warning('Broken internal NOOP hint; should not happen unless someone is using implementation details'); + error("Unknown internal NOOP type hint in ${command}: ${need}"); + } + } else { + # Unknown hint - make no assumptions + return 0; + } + } + return 0 if not $had_cli_options and %Debian::Debhelper::DH::SequenceState::seen_options; + return 1; + } +} + +sub _active_packages_for_command { + my ($command, $all_packages, $arch_packages, $indep_packages) = @_; + my $command_opts_ref = $Debian::Debhelper::DH::SequenceState::command_opts{$command}; + my $selection = $all_packages; + if (grep { $_ eq '-i'} @{$command_opts_ref}) { + if (grep { $_ ne '-a'} @{$command_opts_ref}) { + $selection = $indep_packages; + } + } elsif (grep { $_ eq '-a'} @{$command_opts_ref}) { + $selection = $arch_packages; + } + return @{$selection}; +} + +1; -- cgit v1.2.3