Merging upstream version 1.22.7.

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

2 files changed, 494 insertions, 0 deletions

diff --git a/scripts/Dpkg/BuildDriver.pm b/scripts/Dpkg/BuildDriver.pm
new file mode 100644
index 0000000..5a892ae
--- /dev/null
+++ b/scripts/Dpkg/BuildDriver.pm
@@ -0,0 +1,196 @@
+# Copyright © 2020-2024 Guillem Jover <guillem@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::BuildDriver - drive the build of a Debian package
+
+=head1 DESCRIPTION
+
+This class is used by dpkg-buildpackage to drive the build of a Debian
+package.
+
+B<Note>: This is a private module, its API can change at any time.
+
+=cut
+
+package Dpkg::BuildDriver 0.01;
+
+use strict;
+use warnings;
+
+use Dpkg ();
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+
+=head1 METHODS
+
+=over 4
+
+=item $bd = Dpkg::BuildDriver->new(%opts)
+
+Create a new Dpkg::BuildDriver object.
+It will load a build driver module as requested in the B<Build-Drivers> field
+in the $opts{ctrl} L<Dpkg::Control::Info> object or if not present,
+it will fall back to load the default B<debian-rules> driver.
+
+Supported or required options are:
+
+=over
+
+=item B<ctrl> (required)
+
+A L<Dpkg::Control::Info> object.
+
+=item B<root_cmd>
+
+A string with the gain-root-command to use when needing to execute a command
+with root-like rights.
+If needed and unset, it will default to L<fakeroot> if it is available or
+the module will error out.
+
+=item B<as_root>
+
+A boolean to force F<debian/rules> target calls as root-like, even if they
+would normally not require to be executed as root-like.
+This option is applied to all targets globally.
+
+B<Note>: This option is only relevant for drivers that use F<debian/rules>.
+
+=item B<debian_rules>
+
+An array containing the command to execute the F<debian/rules> file and any
+additional arguments.
+It defaults to B<debian/rules>.
+
+B<Note>: This option is only relevant for drivers that use F<debian/rules>.
+
+=item B<rrr_override>
+
+A string that overrides the B<Rules-Requires-Root> field value.
+
+B<Note>: This option is only relevant for drivers that use F<debian/rules>.
+
+=back
+
+=cut
+
+sub _load_driver {
+    my ($name, %opts) = @_;
+
+    # Normalize the driver name.
+    $name = join q{}, map { ucfirst lc } split /-/, $name;
+
+    my $driver;
+    eval qq{
+        require Dpkg::BuildDriver::$name;
+        \$driver = Dpkg::BuildDriver::$name->new(%opts);
+    };
+    error(g_('build driver %s is unknown: %s'), $name, $@) if $@;
+
+    return $driver;
+}
+
+sub new {
+    my ($this, %opts) = @_;
+    my $class = ref($this) || $this;
+
+    my $ctrl_src = $opts{ctrl}->get_source();
+    my $name = $ctrl_src->{'Build-Driver'} // 'debian-rules';
+    my $self = {
+        driver => _load_driver($name, %opts),
+    };
+    bless $self, $class;
+    return $self;
+}
+
+=item $bd->pre_check()
+
+Perform build driver specific checks, before anything else.
+
+This will run after the B<init> hook, and before C<dpkg-source --before-build>.
+
+B<Note>: This is an optional method that can be omitted from the driver
+implementation.
+
+=cut
+
+sub pre_check {
+    my $self = shift;
+
+    return unless $self->{driver}->can('pre_check');
+    return $self->{driver}->pre_check();
+}
+
+=item $bool = $bd->need_build_task($build_task, binary_task)
+
+Returns whether we need to use the build task.
+
+B<Note>: This method is needed as long as we support building as root-like.
+Once that is not needed this method will be deprecated.
+
+=cut
+
+sub need_build_task {
+    my ($self, $build_task, $binary_task) = @_;
+
+    return $self->{driver}->need_build_task($build_task, $binary_task);
+}
+
+=item $bd->run_build_task($build_task, $binary_task)
+
+Executes the build task for the build.
+
+B<Note>: This is an optional method needed as long as we support building as
+root-like.
+Once that is not needed this method will be deprecated.
+
+=cut
+
+sub run_build_task {
+    my ($self, $build_task, $binary_task) = @_;
+
+    $self->{driver}->run_build_task($build_task, $binary_task);
+
+    return;
+}
+
+=item $bd->run_task($task)
+
+Executes the given task for the build.
+
+=cut
+
+sub run_task {
+    my ($self, $task) = @_;
+
+    $self->{driver}->run_task($task);
+
+    return;
+}
+
+=back
+
+=head1 CHANGES
+
+=head2 Version 0.xx
+
+This is a private module.
+
+=cut
+
+1;
diff --git a/scripts/Dpkg/BuildDriver/DebianRules.pm b/scripts/Dpkg/BuildDriver/DebianRules.pm
new file mode 100644
index 0000000..ffc1987
--- /dev/null
+++ b/scripts/Dpkg/BuildDriver/DebianRules.pm
@@ -0,0 +1,298 @@
+# Copyright © 2020-2024 Guillem Jover <guillem@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::BuildDriver::DebianRules - build a Debian package using debian/rules
+
+=head1 DESCRIPTION
+
+This class is used by dpkg-buildpackage to drive the build of a Debian
+package, using F<debian/rules>.
+
+B<Note>: This is a private module, its API can change at any time.
+
+=cut
+
+package Dpkg::BuildDriver::DebianRules 0.01;
+
+use strict;
+use warnings;
+
+use Dpkg ();
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Path qw(find_command);
+use Dpkg::BuildTypes;
+use Dpkg::BuildAPI qw(get_build_api);
+
+=head1 METHODS
+
+=over 4
+
+=item $bd = Dpkg::BuildDriver::DebianRules->new(%opts)
+
+Create a new Dpkg::BuildDriver::DebianRules object.
+
+Supports or requires the same Dpkg::BuildDriver->new() options.
+
+=cut
+
+sub new {
+    my ($this, %opts) = @_;
+    my $class = ref($this) || $this;
+
+    my $self = {
+        ctrl => $opts{ctrl},
+        root_cmd => $opts{root_cmd},
+        as_root => $opts{as_root},
+        debian_rules => $opts{debian_rules},
+        rrr_override => $opts{rrr_override},
+    };
+    bless $self, $class;
+
+    my $rrr = $self->_parse_rules_requires_root();
+
+    $self->{rules_requires_root} = $rrr;
+
+    return $self;
+}
+
+sub _setup_rootcommand {
+    my $self = shift;
+
+    if ($< == 0) {
+        warning(g_('using a gain-root-command while being root'))
+            if @{$self->{root_cmd}};
+    } else {
+        push @{$self->{root_cmd}}, 'fakeroot'
+            unless @{$self->{root_cmd}};
+    }
+
+    if (@{$self->{root_cmd}} && ! find_command($self->{root_cmd}[0])) {
+        if ($self->{root_cmd}[0] eq 'fakeroot' && $< != 0) {
+            error(g_("fakeroot not found, either install the fakeroot\n" .
+                     'package, specify a command with the -r option, ' .
+                     'or run this as root'));
+        } else {
+            error(g_("gain-root-command '%s' not found"), $self->{root_cmd}[0]);
+        }
+    }
+}
+
+my %target_build = map { $_ => 1 } qw(
+    build
+    build-arch
+    build-indep
+);
+my %target_legacy_root = map { $_ => 1 } qw(
+    clean
+    binary
+    binary-arch
+    binary-indep
+);
+my %target_official =  map { $_ => 1 } qw(
+    clean
+    build
+    build-arch
+    build-indep
+    binary
+    binary-arch
+    binary-indep
+);
+
+# Check whether we are doing some kind of rootless build, and sanity check
+# the fields values.
+sub _parse_rules_requires_root {
+    my $self = shift;
+
+    my %rrr;
+    my $rrr;
+    my $rrr_default;
+    my $keywords_base;
+    my $keywords_impl;
+
+    if (get_build_api($self->{ctrl}) >= 1) {
+        $rrr_default = 'no';
+    } else {
+        $rrr_default = 'binary-targets';
+    }
+
+    my $ctrl_src = $self->{ctrl}->get_source();
+    $rrr = $self->{rrr_override} // $ctrl_src->{'Rules-Requires-Root'} // $rrr_default;
+
+    foreach my $keyword (split ' ', $rrr) {
+        if ($keyword =~ m{/}) {
+            if ($keyword =~ m{^dpkg/target/(.*)$}p and $target_official{$1}) {
+                error(g_('disallowed target in %s field keyword %s'),
+                      'Rules-Requires-Root', $keyword);
+            } elsif ($keyword ne 'dpkg/target-subcommand') {
+                error(g_('%s field keyword "%s" is unknown in dpkg namespace'),
+                      'Rules-Requires-Root', $keyword);
+            }
+            $keywords_impl++;
+        } else {
+            if ($keyword ne lc $keyword and
+                (lc $keyword eq 'no' or lc $keyword eq 'binary-targets')) {
+                error(g_('%s field keyword "%s" is uppercase; use "%s" instead'),
+                      'Rules-Requires-Root', $keyword, lc $keyword);
+            } elsif (lc $keyword eq 'yes') {
+                error(g_('%s field keyword "%s" is invalid; use "%s" instead'),
+                      'Rules-Requires-Root', $keyword, 'binary-targets');
+            } elsif ($keyword ne 'no' and $keyword ne 'binary-targets') {
+                warning(g_('%s field keyword "%s" is unknown'),
+                        'Rules-Requires-Root', $keyword);
+            }
+            $keywords_base++;
+        }
+
+        if ($rrr{$keyword}++) {
+            error(g_('field %s contains duplicate keyword %s'),
+                  'Rules-Requires-Root', $keyword);
+        }
+    }
+
+    if ($self->{as_root} || ! exists $rrr{no}) {
+        $self->_setup_rootcommand();
+    }
+
+    # Notify the children we do support R³.
+    $ENV{DEB_RULES_REQUIRES_ROOT} = join ' ', sort keys %rrr;
+
+    if ($keywords_base > 1 or $keywords_base and $keywords_impl) {
+        error(g_('%s field contains both global and implementation specific keywords'),
+              'Rules-Requires-Root');
+    } elsif ($keywords_impl) {
+        # Set only on <implementations-keywords>.
+        $ENV{DEB_GAIN_ROOT_CMD} = join ' ', @{$self->{root_cmd}};
+    } else {
+        # We should not provide the variable otherwise.
+        delete $ENV{DEB_GAIN_ROOT_CMD};
+    }
+
+    return \%rrr;
+}
+
+sub _rules_requires_root {
+    my ($self, $target) = @_;
+
+    return 1 if $self->{as_root};
+    return 1 if $self->{rules_requires_root}{"dpkg/target/$target"};
+    return 1 if $self->{rules_requires_root}{'binary-targets'} and $target_legacy_root{$target};
+    return 0;
+}
+
+sub _run_cmd {
+    my @cmd = @_;
+    printcmd(@cmd);
+    system @cmd and subprocerr("@cmd");
+}
+
+sub _run_rules_cond_root {
+    my ($self, $target) = @_;
+
+    my @cmd;
+    push @cmd, @{$self->{root_cmd}} if $self->_rules_requires_root($target);
+    push @cmd, @{$self->{debian_rules}}, $target;
+
+    _run_cmd(@cmd);
+}
+
+=item $bd->pre_check()
+
+Perform build driver specific checks, before anything else.
+
+This checks whether the F<debian/rules> file is executable,
+and if not then make it so.
+
+=cut
+
+sub pre_check {
+    my $self = shift;
+
+    if (@{$self->{debian_rules}} == 1 && ! -x $self->{debian_rules}[0]) {
+        warning(g_('%s is not executable; fixing that'),
+                $self->{debian_rules}[0]);
+        # No checks of failures, non fatal.
+        chmod 0755, $self->{debian_rules}[0];
+    }
+}
+
+=item $bool = $bd->need_build_task($build_task, $binary_task)
+
+Returns whether we need to use the build task.
+
+B<Note>: This method is needed as long as we support building as root-like.
+Once that is not needed this method will be deprecated.
+
+=cut
+
+sub need_build_task {
+    my ($self, $build_task, $binary_task) = @_;
+
+    # If we are building rootless, there is no need to call the build target
+    # independently as non-root.
+    return 0 if not $self->_rules_requires_root($binary_task);
+    return 1;
+}
+
+=item $bd->run_build_task($build_task, $binary_task)
+
+Executes the build task for the build.
+
+B<Note>: This method is needed as long as we support building as root-like.
+Once that is not needed this method will be deprecated.
+
+=cut
+
+sub run_build_task {
+    my ($self, $build_task, $binary_task) = @_;
+
+    # If we are building rootless, there is no need to call the build
+    # target independently as non-root.
+    if ($self->_rules_requires_root($binary_task)) {
+        _run_cmd(@{$self->{debian_rules}}, $build_task)
+    }
+
+    return;
+}
+
+=item $bd->run_task($task)
+
+Executes the given task for the build.
+
+=cut
+
+sub run_task {
+    my ($self, $task) = @_;
+
+    $self->_run_rules_cond_root($task);
+
+    return;
+}
+
+=back
+
+=head1 CHANGES
+
+=head2 Version 0.xx
+
+This is a private module.
+
+=cut
+
+1;