1#!/usr/bin/perl 2 3# transition-check: Check whether a given source package is involved 4# in a current transition for which uploads have been blocked by the 5# Debian release team 6# 7# Copyright 2008 Adam D. Barratt 8# 9# This program is free software; you can redistribute it and/or modify 10# it under the terms of the GNU General Public License as published by 11# the Free Software Foundation; either version 2 of the License, or 12# (at your option) any later version. 13# 14# This program is distributed in the hope that it will be useful, 15# but WITHOUT ANY WARRANTY; without even the implied warranty of 16# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17# GNU General Public License for more details. 18# 19# You should have received a copy of the GNU General Public License along 20# with this program; if not, write to the Free Software Foundation, Inc., 21# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 22 23=head1 NAME 24 25transition-check - check a package list for involvement in transitions 26 27=head1 SYNOPSIS 28 29B<transition-check> B<--help>|B<--version> 30 31B<transition-check> [B<-f>|B<--filename=>I<FILENAME>] [I<source package list>] 32 33=head1 DESCRIPTION 34 35B<transition-check> checks whether any of the listed source packages 36are involved in a transition for which uploads to unstable are currently 37blocked. 38 39If neither a filename nor a list of packages is supplied, B<transition-check> 40will use the source package name from I<debian/control>. 41 42=head1 OPTIONS 43 44=over 4 45 46=item B<-f>, B<--filename=>I<filename> 47 48Read a source package name from I<filename>, which should be a Debian 49package control file or I<.changes> file, and add that package to the list 50of packages to check. 51 52=back 53 54=head1 EXIT STATUS 55 56The exit status indicates whether any of the packages examined were found to 57be involved in a transition. 58 59=over 4 60 61=item 0Z<> 62 63Either B<--help> or B<--version> was used, or none of the packages examined 64was involved in a transition. 65 66=item 1Z<> 67 68At least one package examined is involved in a current transition. 69 70=back 71 72=head1 LICENSE 73 74This code is copyright by Adam D. Barratt <I<adam@adam-barratt.org.uk>>, 75all rights reserved. 76 77This program comes with ABSOLUTELY NO WARRANTY. 78You are free to redistribute this code under the terms of the GNU 79General Public License, version 2 or later. 80 81=head1 AUTHOR 82 83Adam D. Barratt <I<adam@adam-barratt.org.uk>> 84 85=cut 86 87use warnings; 88use strict; 89use Getopt::Long qw(:config bundling permute no_getopt_compat); 90use File::Basename; 91 92my $progname = basename($0); 93 94my ($opt_help, $opt_version, @opt_filename); 95 96GetOptions( 97 "help|h" => \$opt_help, 98 "version|v" => \$opt_version, 99 "filename|f=s" => sub { push(@opt_filename, $_[1]); }, 100 ) 101 or die 102"Usage: $progname [options] source_package_list\nRun $progname --help for more details\n"; 103 104if ($opt_help) { help(); exit 0; } 105if ($opt_version) { version(); exit 0; } 106 107my ($lwp_broken, $yaml_broken); 108my $ua; 109 110sub have_lwp() { 111 return ($lwp_broken ? 0 : 1) if defined $lwp_broken; 112 eval { 113 require LWP; 114 require LWP::UserAgent; 115 }; 116 117 if ($@) { 118 if ($@ =~ m%^Can\'t locate LWP%) { 119 $lwp_broken = "the libwww-perl package is not installed"; 120 } else { 121 $lwp_broken = "couldn't load LWP::UserAgent: $@"; 122 } 123 } else { 124 $lwp_broken = ''; 125 } 126 return $lwp_broken ? 0 : 1; 127} 128 129sub have_yaml() { 130 return ($yaml_broken ? 0 : 1) if defined $yaml_broken; 131 eval { require YAML::Syck; }; 132 133 if ($@) { 134 if ($@ =~ m%^Can\'t locate YAML%) { 135 $yaml_broken = "the libyaml-syck-perl package is not installed"; 136 } else { 137 $yaml_broken = "couldn't load YAML::Syck: $@"; 138 } 139 } else { 140 $yaml_broken = ''; 141 } 142 return $yaml_broken ? 0 : 1; 143} 144 145sub init_agent { 146 $ua = new LWP::UserAgent; # we create a global UserAgent object 147 $ua->agent("LWP::UserAgent/Devscripts"); 148 $ua->env_proxy; 149} 150 151if (@opt_filename or !@ARGV) { 152 @opt_filename = ("debian/control") unless @opt_filename; 153 154 foreach my $filename (@opt_filename) { 155 my $message; 156 157 if (!@ARGV) { 158 $message = "No package list supplied and unable"; 159 } else { 160 $message = "Unable"; 161 } 162 163 $message .= " to open $filename"; 164 open FILE, $filename or die "$progname: $message: $!\n"; 165 while (<FILE>) { 166 if (/^(?:Source): (.*)/) { 167 push(@ARGV, $1); 168 last; 169 } 170 } 171 172 close FILE; 173 } 174} 175 176die "$progname: Unable to retrieve transition information: $lwp_broken\n" 177 unless have_lwp; 178 179init_agent() unless $ua; 180my $request = HTTP::Request->new('GET', 181 'https://ftp-master.debian.org/transitions.yaml'); 182my $response = $ua->request($request); 183if (!$response->is_success) { 184 die "$progname: Failed to retrieve transitions list: $!\n"; 185} 186 187die "$progname: Unable to parse transition information: $yaml_broken\n" 188 unless have_yaml(); 189 190my $yaml = YAML::Syck::Load($response->content); 191my $packagelist = join("|", map { qq/\Q$_\E/ } @ARGV); 192my $found = 0; 193 194foreach my $transition (keys(%{$yaml})) { 195 my $data = $yaml->{$transition}; 196 197 my @affected = grep /^($packagelist)$/, @{ $data->{packages} }; 198 199 if (@affected) { 200 print "\n\n" if $found; 201 $found = 1; 202 print 203"The following packages are involved in the $transition transition:\n"; 204 print map { qq( - $_\n) } @affected; 205 206 print "\nDetails of this transition:\n" 207 . " - Reason: $data->{reason}\n" 208 . " - Release team contact: $data->{rm}\n"; 209 } 210} 211 212if (!$found) { 213 print "$progname: No packages examined are currently blocked\n"; 214} 215 216exit $found; 217 218sub help { 219 print <<"EOF"; 220Usage: $progname [options] source_package_list 221Valid options are: 222 --help, -h Display this message 223 --version, -v Display version and copyright info 224 --filename, -f Read source package information from the specified 225 filename (which should be a Debian package control 226 file or changes file) 227EOF 228} 229 230sub version { 231 print <<"EOF"; 232This is $progname, from the Debian devscripts package, version ###VERSION### 233Copyright (C) 2008 by Adam D. Barratt <adam\@adam-barratt.org.uk>, 234 235This program comes with ABSOLUTELY NO WARRANTY. 236You are free to redistribute this code under the terms of the 237GNU General Public License, version 2, or (at your option) any 238later version. 239EOF 240} 241 242