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