scripts/dcontrol.pl

   1 #!/usr/bin/perl -w
   2 # vim:sw=4:sta:
   3
   4 #   dcontrol - Query Debian control files across releases and architectures
   5 #   Copyright (C) 2009 Christoph Berg <myon@debian.org>
   6 #
   7 #   This program is free software; you can redistribute it and/or modify
   8 #   it under the terms of the GNU General Public License as published by
   9 #   the Free Software Foundation; either version 2 of the License, or
  10 #   (at your option) any later version.
  11 #
  12 #   This program is distributed in the hope that it will be useful,
  13 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 #   GNU General Public License for more details.
  16 #
  17 #   You should have received a copy of the GNU General Public License
  18 #   along with this program; if not, write to the Free Software
  19 #   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  20
  21 use strict;
  22 use File::Basename;
  23 use Getopt::Long;
  24
  25 BEGIN {
  26     # Load the URI::Escape and LWP::UserAgent modules safely
  27     my $progname = basename($0,'.pl');
  28     eval { require URI::Escape; };
  29     if ($@) {
  30        if ($@ =~ /^Can\'t locate URI\/Escape\.pm/) {
  31            die "$progname: you must have the liburi-perl package installed\nto use this script\n";
  32        }
  33        die "$progname: problem loading the URI::Escape module:\n  $@\nHave you installed the liburi-perl package?\n";
  34     }
  35     import URI::Escape;
  36
  37     eval { require LWP::UserAgent; };
  38     if ($@) {
  39        my $progname = basename $0;
  40        if ($@ =~ /^Can\'t locate LWP/) {
  41            die "$progname: you must have the libwww-perl package installed\nto use this script\n";
  42        }
  43        die "$progname: problem loading the LWP::UserAgent module:\n  $@\nHave you installed the libwww-perl package?\n";
  44     }
  45     import LWP::UserAgent;
  46 }
  47
  48 # global variables
  49
  50 my $progname = basename($0,'.pl');  # the '.pl' is for when we're debugging
  51 my $modified_conf_msg;
  52 my $dcontrol_url;
  53 my $opt;
  54
  55 my $ua = LWP::UserAgent->new(agent => "$progname ###VERSION###");
  56
  57 # functions
  58
  59 sub usage {
  60     print <<"EOT";
  61 Usage: $progname [-sd] package[modifiers] [...]
  62
  63 Query package and source control files for all Debian distributions.
  64
  65 Options:
  66     -s --show-suite  Add headers for distribution the control file is from
  67     -d --debug       Print URL queried
  68
  69 Modifiers:
  70     =version         Exact version match
  71     \@architecture    Query this architecture
  72     /[archive:][suite][/component]
  73                      Restrict to archive (debian, debian-backports,
  74                      debian-security, debian-volatile), suite (always
  75                      codenames, with the exception of experimental), and/or
  76                      component (main, updates/main, ...). Use // if the suite
  77                      name contains slashes.
  78
  79 By default, all versions, suites, and architectures are queried.
  80 Use \@source for source packages. \@binary returns no source packages.
  81 Refer to $dcontrol_url for currently supported values.
  82
  83 Default settings modified by devscripts configuration files:
  84 $modified_conf_msg
  85 EOT
  86 }
  87
  88 sub version {
  89     print <<"EOF";
  90 This is $progname, from the Debian devscripts package, version ###VERSION###
  91 This code is copyright 2009 by Christoph Berg <myon\@debian.org>.
  92 All rights reserved.
  93 This program comes with ABSOLUTELY NO WARRANTY.
  94 You are free to redistribute this code under the terms of the
  95 GNU General Public License, version 2 or later.
  96 EOF
  97 }
  98
  99 sub apt_get {
 100     my ($arg) = @_;
 101     unless ($arg =~ /^([\w.+-]+)/) {
 102         die "$arg does not start with a valid package name\n";
 103     }
 104     my $url = "$dcontrol_url?package=" . uri_escape($1);
 105     if ($arg =~ /=([\w~:.+-]+)/) {
 106         $url .= "&version=" . uri_escape($1);
 107     }
 108     if ($arg =~ /@([\w.-]+)/) {
 109         $url .= "&architecture=$1";
 110     }
 111     if ($arg =~ m!/([\w-]*):([\w/-]*)//([\w/-]*)!) {
 112         $url .= "&archive=$1&suite=$2&component=$3";
 113     } elsif ($arg =~ m!/([\w/-]*)//([\w/-]*)!) {
 114         $url .= "&suite=$1&component=$2";
 115     } elsif ($arg =~ m!/([\w-]*):([\w-]*)/([\w/-]*)!) {
 116         $url .= "&archive=$1&suite=$2&component=$3";
 117     } elsif ($arg =~ m!/([\w-]*):([\w-]*)!) {
 118         $url .= "&archive=$1&suite=$2";
 119     } elsif ($arg =~ m!/([\w-]*)/([\w/-]*)!) {
 120         $url .= "&suite=$1&component=$2";
 121     } elsif ($arg =~ m!/([\w\/-]+)!) {
 122         $url .= "&suite=$1";
 123     }
 124     if ($opt->{'show-suite'}) {
 125         $url .= "&annotate=yes";
 126     }
 127     print "$url\n" if $opt->{debug};
 128     my $response = $ua->get ($url);
 129     if ($response->is_success) {
 130         print $response->content . "\n";
 131     } else {
 132         die $response->status_line;
 133     }
 134 }
 135
 136 # main program
 137
 138 if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
 139     $modified_conf_msg = "  (no configuration files read)";
 140     shift;
 141 } else {
 142     my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
 143     my %config_vars = (
 144                        'DCONTROL_URL' => 'http://qa.debian.org/cgi-bin/dcontrol',
 145                        );
 146     my %config_default = %config_vars;
 147
 148     my $shell_cmd;
 149     # Set defaults
 150     foreach my $var (keys %config_vars) {
 151         $shell_cmd .= "$var='$config_vars{$var}';\n";
 152     }
 153     $shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
 154     $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
 155     # Read back values
 156     foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
 157     my $shell_out = `/bin/bash -c '$shell_cmd'`;
 158     @config_vars{keys %config_vars} = split /\n/, $shell_out, -1;
 159
 160     foreach my $var (sort keys %config_vars) {
 161         if ($config_vars{$var} ne $config_default{$var}) {
 162             $modified_conf_msg .= "  $var=$config_vars{$var}\n";
 163         }
 164     }
 165     $modified_conf_msg ||= "  (none)\n";
 166     chomp $modified_conf_msg;
 167
 168     $dcontrol_url = $config_vars{'DCONTROL_URL'};
 169 }
 170
 171 # handle options
 172 Getopt::Long::Configure('bundling');
 173 GetOptions(
 174     "d|debug"      =>  \$opt->{'debug'},
 175     "s|show-suite" =>  \$opt->{'show-suite'},
 176     "h|help"       =>  \$opt->{'help'},
 177     "V|version"    =>  \$opt->{'version'},
 178 )
 179     or die "$progname: unrecognised option. Run $progname --help for more details.\n";
 180
 181 if ($opt->{'help'}) { usage(); exit 0; }
 182 if ($opt->{'version'}) { version(); exit 0; }
 183 if ($opt->{'no-conf'}) {
 184     die "$progname: --no-conf is only acceptable as the first command-line option!\n";
 185 }
 186
 187 if (! @ARGV) {
 188     usage();
 189     exit 1;
 190 }
 191
 192 # handle arguments
 193 while (my $arg = shift @ARGV) {
 194     apt_get ($arg);
 195 }
 196
 197 =pod
 198
 199 =head1 NAME
 200
 201 dcontrol -- Query package and source control files for all Debian distributions
 202
 203 =head1 SYNOPSIS
 204
 205 =over
 206
 207 =item B<dcontrol> [I<options>] I<package>[I<modifiers>] [I<...>]
 208
 209 =back
 210
 211 =head1 DESCRIPTION
 212
 213 B<dcontrol> queries a remote database of Debian binary and source package
 214 control files. It can be thought of as an B<apt-cache> webservice that also
 215 operates for distributions and architectures different from the local machine.
 216
 217 =head1 MODIFIERS
 218
 219 Like B<apt-cache>, packages can be suffixed by modifiers:
 220
 221 =over 4
 222
 223 =item B<=>I<version>
 224
 225 Exact version match
 226
 227 =item B<@>I<architecture>
 228
 229 Query this only architecture. Use B<@source> for source packages,
 230 B<@binary> excludes source packages.
 231
 232 =item B</>[I<archive>B<:>][I<suite>][B</>I<component>]
 233
 234 Restrict to I<archive> (debian, debian-backports, debian-security,
 235 debian-volatile), I<suite> (always codenames, with the exception of
 236 experimental), and/or I<component> (main, updates/main, ...). Use two slashes
 237 (B<//>) to separate suite and component if the suite name contains slashes.
 238 (Component can be left empty.)
 239
 240 =back
 241
 242 By default, all versions, suites, and architectures are queried. Refer to
 243 B<http://qa.debian.org/cgi-bin/dcontrol> for currently supported values.
 244
 245 =head1 OPTIONS
 246
 247 =over 4
 248
 249 =item B<-s>, B<--show-suites>
 250
 251 Add headers showing which distribution the control file is from.
 252
 253 =item B<-d>, B<--debug>
 254
 255 Print URL queried.
 256
 257 =item B<-h>, B<--help>
 258
 259 Show a help message.
 260
 261 =item B<-V>, B<--version>
 262
 263 Show version information.
 264
 265 =back
 266
 267 =head1 CONFIGURATION VARIABLES
 268
 269 The two configuration files F</etc/devscripts.conf> and
 270 F<~/.devscripts> are sourced by a shell in that order to set
 271 configuration variables.  Command line options can be used to override
 272 configuration file settings.  Environment variable settings are
 273 ignored for this purpose.  The currently recognised variable is:
 274
 275 =over 4
 276
 277 =item DCONTROL_URL
 278
 279 URL to query. Default is B<http://qa.debian.org/cgi-bin/dcontrol>.
 280
 281 =back
 282
 283 =head1 AUTHOR
 284
 285 This program is Copyright (C) 2009 by Christoph Berg <myon@debian.org>.
 286
 287 This program is licensed under the terms of the GPL, either version 2
 288 of the License, or (at your option) any later version.
 289
 290 =head1 SEE ALSO
 291
 292 B<apt-cache>(1).