mirror of
https://git.dpkg.org/git/dpkg/dupload.git
synced 2025-04-10 05:59:42 +00:00
133 lines
3.5 KiB
Perl
Executable File
133 lines
3.5 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
#
|
|
# Copyright © 2022-2025 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/>.
|
|
#
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use List::Util qw(none first);
|
|
use HTTP::Tiny;
|
|
use Dpkg::ErrorHandling;
|
|
use Dpkg::Control;
|
|
|
|
eval {
|
|
require YAML::XS;
|
|
1;
|
|
} or do {
|
|
warning('missing YAML::XS module, skipping transitions checks');
|
|
exit 0;
|
|
};
|
|
|
|
my $version = '2.x';
|
|
|
|
# XXX: There is another potential source of data for transitions checks
|
|
# for uploads that would get rejected anyway, but it is currently not
|
|
# widely used, revisit if this changes.
|
|
# Ref: https://ftp-master.debian.org/transitions.yaml
|
|
# Doc: https://lists.debian.org/debian-release/2008/04/msg00282.html
|
|
|
|
my $url_base = 'https://release.debian.org/transitions';
|
|
my $url_packages = "$url_base/export/packages.yaml";
|
|
my $url_ongoing = "$url_base/html";
|
|
|
|
my $changes_path = $ARGV[0];
|
|
|
|
my $changes = Dpkg::Control->new(type => CTRL_FILE_CHANGES);
|
|
$changes->load($changes_path);
|
|
my $source = $changes->{Source};
|
|
my @arches = split ' ', $changes->{Architecture};
|
|
my @dists = split ' ', $changes->{Distribution};
|
|
|
|
if (none { $_ eq 'source' } @arches) {
|
|
# Not a sourceful upload, ignore it.
|
|
exit 0;
|
|
}
|
|
|
|
my %dists = map { $_ => 1 } qw(
|
|
unstable
|
|
sid
|
|
);
|
|
if (none { exists $dists{$_} } @dists) {
|
|
# Not an unstable upload, ignore it.
|
|
exit 0;
|
|
}
|
|
|
|
print "Checking Debian transitions for $source...\n";
|
|
|
|
my $http = HTTP::Tiny->new(
|
|
agent => "dupload/$version",
|
|
verify_SSL => 1,
|
|
);
|
|
my $res = $http->get($url_packages);
|
|
if (not $res->{success}) {
|
|
warning("cannot fetch transitions information: $res->{reason}");
|
|
prompt();
|
|
}
|
|
|
|
my $yaml = YAML::XS::Load($res->{content});
|
|
|
|
my $entry = first { $_->{name} eq $source } @{$yaml};
|
|
|
|
my @ongoing;
|
|
@ongoing = grep { $_->[1] eq 'ongoing' } @{$entry->{list}} if $entry;
|
|
|
|
if (@ongoing > 0) {
|
|
my $ongoing = join "\n ", sort map {
|
|
"<$url_ongoing/$_->[0].html>"
|
|
} @ongoing;
|
|
print <<"WARN";
|
|
|
|
Warning: Source package $source is part of ongoing transitions:
|
|
|
|
$ongoing
|
|
|
|
If the upload does not solve issues caused by these transitions, then it
|
|
might disrupt them by adding delays or entangling them. For more information,
|
|
please read:
|
|
|
|
<https://wiki.debian.org/Teams/ReleaseTeam/TransitionUploadHook>
|
|
|
|
Note: If you are aware of this and do not want to be warned, you can disable
|
|
this hook from the configuration file, skip it with --skip-hooks or set the
|
|
one-off environment variable DUPLOAD_SKIP_HOOKS, or alternatively you can
|
|
reply to the following prompt.
|
|
|
|
WARN
|
|
prompt();
|
|
} else {
|
|
print " Ok, not found in any.\n";
|
|
}
|
|
|
|
sub prompt
|
|
{
|
|
my $accept = 'yes';
|
|
print "Continue anyway? ($accept/NO) ";
|
|
|
|
my $prompt = <STDIN>;
|
|
chomp $prompt;
|
|
|
|
if ($prompt eq $accept) {
|
|
print " Ok, continuing anyway with the upload.\n";
|
|
print "\n";
|
|
exit 0;
|
|
} else {
|
|
warn " Ok, aborting the upload.\n";
|
|
warn "\n";
|
|
exit 1;
|
|
}
|
|
}
|