scripts/debcheckout.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # debcheckout: checkout the development repository of a Debian package
   4 # Copyright (C) 2007-2009  Stefano Zacchiroli <zack@debian.org>
   5 #
   6 # This program is free software: you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation, either version 3 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18 #
  19
  20 # Created: Tue, 14 Aug 2007 10:20:55 +0200
  21 # Last-Modified: $Date$
  22
  23 =head1 NAME
  24
  25 debcheckout - checkout the development repository of a Debian package
  26
  27 =head1 SYNOPSIS
  28
  29 =over
  30
  31 =item B<debcheckout> [I<OPTIONS>] I<PACKAGE> [I<DESTDIR>]
  32
  33 =item B<debcheckout> [I<OPTIONS>] I<REPOSITORY_URL> [I<DESTDIR>]
  34
  35 =item B<debcheckout> B<--help>
  36
  37 =back
  38
  39 =head1 DESCRIPTION
  40
  41 B<debcheckout> retrieves the information about the Version Control System used
  42 to maintain a given Debian package (the I<PACKAGE> argument), and then checks
  43 out the latest (potentially unreleased) version of the package from its
  44 repository.  By default the repository is checked out to the I<PACKAGE>
  45 directory; this can be overridden by providing the I<DESTDIR> argument.
  46
  47 The information about where the repository is available is expected to be found
  48 in B<Vcs-*> fields available in the source package record. For example, the vim
  49 package exposes such information with a field like S<Vcs-Git:
  50 git://git.debian.org/git/pkg-vim/vim.git>, you can see it by grepping through
  51 C<apt-cache showsrc vim>.
  52
  53 If more than one source package record containing B<Vcs-*> fields is available,
  54 B<debcheckout> will select the record with the highest version number.
  55 Alternatively, a particular version may be selected from those available by
  56 specifying the package name as I<PACKAGE>=I<VERSION>.
  57
  58 If you already know the URL of a given repository you can invoke
  59 debcheckout directly on it, but you will probably need to pass the
  60 appropriate B<-t> flag. That is, some heuristics are in use to guess
  61 the repository type from the URL; if they fail, you might want to
  62 override the guessed type using B<-t>.
  63
  64 The currently supported version control systems are: arch, bzr, cvs,
  65 darcs, git, hg, svn.
  66
  67 =head1 OPTIONS
  68
  69 B<GENERAL OPTIONS>
  70
  71 =over
  72
  73 =item B<-a>, B<--auth>
  74
  75 Work in authenticated mode; this means that for known repositories (mainly those
  76 hosted on S<http://alioth.debian.org>) URL rewriting is attempted before
  77 checking out, to ensure that the repository can be committed to. For example,
  78 for subversion repositories hosted on alioth this means that
  79 S<svn+ssh://svn.debian.org/...> will be used instead of
  80 S<svn://svn.debian.org/...>.
  81
  82 =item B<-d>, B<--details>
  83
  84 Only print a list of detailed information about the package
  85 repository, without checking it out; the output format is a list of
  86 fields, each field being a pair of TAB-separated field name and field
  87 value. The actual fields depend on the repository type. This action
  88 might require a network connection to the remote repository.
  89
  90 Also see B<-p>. This option and B<-p> are mutually exclusive.
  91
  92 =item B<-h>, B<--help>
  93
  94 Print a detailed help message and exit.
  95
  96 =item B<-p>, B<--print>
  97
  98 Only print a summary about package repository information, without
  99 checking it out; the output format is TAB-separated with two fields:
 100 repository type, repository URL. This action works offline, it only
 101 uses "static" information as known by APT's cache.
 102
 103 Also see B<-d>. This option and B<-d> are mutually exclusive.
 104
 105 =item B<-t> I<TYPE>, B<--type> I<TYPE>
 106
 107 Override the repository type (which defaults to some heuristics based
 108 on the URL or, in case of heuristic failure, the fallback "svn");
 109 should be one of the currently supported repository types.
 110
 111 =item B<-u> I<USERNAME>, B<--user> I<USERNAME>
 112
 113 Specify the login name to be used in authenticated mode (see B<-a>). This option
 114 implies B<-a>: you don't need to specify both.
 115
 116 =item B<-f>, B<--file>
 117
 118 Specify that the named file should be extracted from the repository and placed
 119 in the destination directory. May be used more than once to extract mutliple
 120 files.
 121
 122 =back
 123
 124 B<VCS-SPECIFIC OPTIONS>
 125
 126 I<GIT-SPECIFIC OPTIONS>
 127
 128 =over
 129
 130 =item B<--git-track> I<BRANCHES>
 131
 132 Specify a list of remote branches which will be set up for tracking
 133 (as in S<git branch --track>, see git-branch(1)) after the remote
 134 GIT repository has been cloned. The list should be given as a
 135 space-separated list of branch names.
 136
 137 As a shorthand, the string "*" can be given to require tracking of all
 138 remote branches.
 139
 140 =back
 141
 142 =head1 CONFIGURATION VARIABLES
 143
 144 The two configuration files F</etc/devscripts.conf> and
 145 F<~/.devscripts> are sourced by a shell in that order to set
 146 configuration variables. Command line options can be used to override
 147 configuration file settings. Environment variable settings are ignored
 148 for this purpose. The currently recognised variables are:
 149
 150 =over
 151
 152 =item B<DEBCHECKOUT_AUTH_URLS>
 153
 154 This variable should be a space separated list of Perl regular
 155 expressions and replacement texts, which must come in pairs: REGEXP
 156 TEXT REGEXP TEXT ... and so on. Each pair denotes a substitution which
 157 is applied to repository URLs if other built-in means of building URLs
 158 for authenticated mode (see B<-a>) have failed.
 159
 160 References to matching substrings in the replacement texts are
 161 allowed as usual in Perl by the means of $1, $2, ... and so on.
 162
 163 This setting can be used to enable authenticated mode for most repositories
 164 out there.  Note that the Debian repositories on S<alioth.debian.org>
 165 (S<$vcs.debian.org>) are implicitly defined.
 166
 167 Here is a sample snippet suitable for the configuration files:
 168
 169  DEBCHECKOUT_AUTH_URLS='
 170   ^\w+://(svn\.example\.com)/(.*)    svn+ssh://$1/srv/svn/$2
 171   ^\w+://(git\.example\.com)/(.*)    git+ssh://$1/home/git/$2
 172  '
 173
 174 Note that whitespace is not allowed in either regexps or
 175 replacement texts. Also, given that configuration files are sourced by
 176 a shell, you probably want to use single quotes around the value of
 177 this variable.
 178
 179 =back
 180
 181 =head1 SEE ALSO
 182
 183 apt-cache(8), Section 6.2.5 of the Debian Developer's Reference (for
 184 more information about Vcs-* fields): S<http://www.debian.org/doc/developers-reference/best-pkging-practices.html#bpp-vcs>
 185
 186 =head1 AUTHOR
 187
 188 debcheckout and this manpage have been written by Stefano Zacchiroli
 189 <zack@debian.org>
 190
 191 =cut
 192
 193 use feature 'switch';
 194 use strict;
 195 use warnings;
 196 use Getopt::Long;
 197 use Pod::Usage;
 198 use File::Basename;
 199 use File::Copy qw/copy/;
 200 use File::Temp qw/tempdir/;
 201 use Cwd;
 202 use lib '/usr/share/devscripts';
 203 use Devscripts::Versort;
 204
 205 my @files = ();   # files to checkout
 206
 207 # <snippet from="bts.pl">
 208 # <!-- TODO we really need to factor out in a Perl module the
 209 #      configuration file parsing code -->
 210 my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
 211 my %config_vars = (
 212     'DEBCHECKOUT_AUTH_URLS' => '',
 213     );
 214 my %config_default = %config_vars;
 215 my $shell_cmd;
 216 # Set defaults
 217 foreach my $var (keys %config_vars) {
 218     $shell_cmd .= qq[$var="$config_vars{$var}";\n];
 219 }
 220 $shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
 221 $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
 222 # Read back values
 223 foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
 224 my $shell_out = `/bin/bash -c '$shell_cmd'`;
 225 @config_vars{keys %config_vars} = split /\n/, $shell_out, -1;
 226 # </snippet>
 227
 228 my $lwp_broken;
 229 my $ua;
 230
 231 sub have_lwp() {
 232     return ($lwp_broken ? 0 : 1) if defined $lwp_broken;
 233     eval {
 234         require LWP;
 235         require LWP::UserAgent;
 236     };
 237
 238     if ($@) {
 239         if ($@ =~ m%^Can\'t locate LWP%) {
 240             $lwp_broken="the libwww-perl package is not installed";
 241         } else {
 242             $lwp_broken="couldn't load LWP::UserAgent: $@";
 243         }
 244     }
 245     else { $lwp_broken=''; }
 246     return $lwp_broken ? 0 : 1;
 247 }
 248
 249 sub init_agent {
 250     $ua = new LWP::UserAgent;  # we create a global UserAgent object
 251     $ua->agent("LWP::UserAgent/Devscripts");
 252     $ua->env_proxy;
 253 }
 254
 255 sub recurs_mkdir {
 256     my ($dir) = @_;
 257     my @temp = split /\//, $dir;
 258     my $createdir = "";
 259     foreach my $piece (@temp) {
 260         if (! length $createdir and ! length $piece) {
 261             $createdir = "/";
 262         } elsif (length $createdir and $createdir ne "/") {
 263             $createdir .= "/";
 264         }
 265         $createdir .= "$piece";
 266         if (! -d $createdir) {
 267             mkdir($createdir) or return 0;
 268         }
 269     }
 270     return 1;
 271 }
 272
 273 # Find the repository URL (and type) for a given package name, parsing Vcs-*
 274 # fields.
 275 sub find_repo($$) {
 276     my ($pkg, $desired_ver) = @_;
 277     my @repo = (0, "");
 278     my $found = 0;
 279     my $version = "";
 280     my $type = "";
 281     my $url = "";
 282     my @repos = ();
 283
 284     open(APT, "apt-cache showsrc $pkg |");
 285     while (my $line = <APT>) {
 286         $found = 1;
 287         chomp($line);
 288         if ($line =~ /^(x-)?vcs-(\w+):\s*(.*)$/i) {
 289             next if lc($2) eq "browser";
 290             ($type, $url) = (lc($2), $3);
 291         } elsif ($line =~ /^Version:\s*(.*)$/i) {
 292             $version = $1;
 293         } elsif ($line =~ /^$/) {
 294             push (@repos, [$version, $type, $url])
 295                 if ($version and $type and $url and
 296                     ($desired_ver eq "" or $desired_ver eq $version));
 297             $version = "";
 298             $type = "";
 299             $url = "";
 300         }
 301     }
 302     close(APT);
 303     die "unknown package '$pkg'\n" unless $found;
 304
 305     if (@repos) {
 306         @repos = Devscripts::Versort::versort(@repos);
 307         @repo = ($repos[0][1], $repos[0][2])
 308     }
 309     return @repo;
 310 }
 311
 312 # Find the browse URL for a given package name, parsing Vcs-* fields.
 313 sub find_browse($$) {
 314     my ($pkg, $desired_ver) = @_;
 315     my $browse = "";
 316     my $found = 0;
 317     my $version = "";
 318     my @browses;
 319
 320     open(APT, "apt-cache showsrc $pkg |");
 321     while (my $line = <APT>) {
 322         $found = 1;
 323         chomp($line);
 324         if ($line =~ /^(x-)?vcs-(\w+):\s*(.*)$/i) {
 325             if (lc($2) eq "browser") {
 326                 $browse = $3;
 327             }
 328         } elsif ($line =~ /^Version:\s*(.*)$/i) {
 329             $version = $1;
 330         } elsif ($line =~ /^$/) {
 331             push(@browses, [$version, $browse])
 332                 if $version and $browse and
 333                 ($desired_ver eq "" or $desired_ver eq $version);
 334             $version = "";
 335             $browse = "";
 336         }
 337     }
 338     close(APT);
 339     die "unknown package '$pkg'\n" unless $found;
 340     if (@browses) {
 341         @browses = Devscripts::Versort::versort(@browses);
 342         $browse = $browses[0][1];
 343     }
 344     return $browse;
 345 }
 346
 347 # Patch the cmdline invocation of a VCS to ensure the repository is checkout to
 348 # a given target directory.
 349 sub set_destdir(@$$) {
 350     my ($repo_type, $destdir, @cmd) = @_;
 351     $destdir =~ s|^-d\s*||;
 352
 353     given ($repo_type) {
 354         when ("cvs") {
 355             my $module = pop @cmd;
 356             push @cmd, ("-d", $destdir, $module);
 357         }
 358         when (/^(bzr|darcs|git|hg|svn)$/) {
 359             push @cmd, $destdir;
 360         }
 361         default {
 362             die "sorry, don't know how to set the destination directory for $repo_type repositories (patches welcome!)\n";
 363         }
 364     }
 365     return @cmd;
 366 }
 367
 368 # try patching a repository URL to enable authenticated mode, *relying
 369 # only on user defined rules*
 370 sub user_set_auth($$) {
 371     my ($repo_type, $url) = @_;
 372     my @rules = split ' ', $config_vars{'DEBCHECKOUT_AUTH_URLS'};
 373     while (my $pat = shift @rules) {    # read pairs for s/$pat/$subst/
 374         my $subst = shift @rules
 375             or die "Configuration error for DEBCHECKOUT_AUTH_URLS: regexp and replacement texts must come in pairs. See debcheckout(1).\n";
 376         $url =~ s/$pat/qq("$subst")/ee; # ZACK: my worst Perl line ever
 377     }
 378     return $url;
 379 }
 380
 381 # Patch a given repository URL to ensure that the checked out out repository
 382 # can be committed to. Only works for well known repositories (mainly Alioth's).
 383 sub set_auth($$$$) {
 384     my ($repo_type, $url, $user, $dont_act) = @_;
 385
 386     my $old_url = $url;
 387
 388     $user .= "@" if length $user;
 389     my $user_local = $user;
 390     $user_local =~ s|(.*)(@)|$1|;
 391     my $user_url = $url;
 392
 393     given ($repo_type) {
 394         when ("bzr") {
 395             $url =~ s|^[\w+]+://(bzr\.debian\.org)/(.*)|bzr+ssh://$user$1/bzr/$2|;
 396             $url =~ s[^\w+://(?:(bazaar|code)\.)?(launchpad\.net/.*)][bzr+ssh://${user}bazaar.$2];
 397         }
 398         when ("darcs")  {
 399             if ($url =~ m|(~)|) {
 400                 $user_url =~ s|^\w+://(darcs\.debian\.org)/(~)(.*?)/.*|$3|;
 401                 die "the local user '$user_local' doesn't own the personal repository '$url'\n"
 402                     if $user_local ne $user_url and !$dont_act;
 403                 $url =~ s|^\w+://(darcs\.debian\.org)/(~)(.*?)/(.*)|$user$1:~/public_darcs/$4|;
 404             } else {
 405                 $url =~ s|^\w+://(darcs\.debian\.org)/(.*)|$user$1:/$2|;
 406             }
 407         }
 408         when ("git") {
 409             if ($url =~ m%(/users/|~)%) {
 410                 $user_url =~ s|^\w+://(git\.debian\.org)/git/users/(.*?)/.*|$2|;
 411                 $user_url =~ s|^\w+://(git\.debian\.org)/~(.*?)/.*|$2|;
 412
 413                 die "the local user '$user_local' doesn't own the personal repository '$url'\n"
 414                     if $user_local ne $user_url and !$dont_act;
 415                 $url =~ s|^\w+://(git\.debian\.org)/git/users/.*?/(.*)|git+ssh://$user$1/~/public_git/$2|;
 416                 $url =~ s|^\w+://(git\.debian\.org)/~.*?/(.*)|git+ssh://$user$1/~/public_git/$2|;
 417             } else {
 418                 $url =~ s|^\w+://(git\.debian\.org)/(?:git/)?(.*)|git+ssh://$user$1/git/$2|;
 419             }
 420         }
 421         # "hg ssh://" needs an extra slash so paths are not based in the user's $HOME
 422         when ("hg") {
 423             $url =~ s|^\w+://(hg\.debian\.org/)|ssh://$user$1/|;
 424         }
 425         when ("svn") {
 426             $url =~ s|^\w+://(svn\.debian\.org)/(.*)|svn+ssh://$user$1/svn/$2|;
 427         }
 428         default {
 429             die "sorry, don't know how to enable authentication for $repo_type repositories (patches welcome!)\n";
 430         }
 431     }
 432     if ($url eq $old_url) { # last attempt: try with user-defined rules
 433         $url = user_set_auth($repo_type, $url);
 434     }
 435     die "can't use authenticated mode on repository '$url' since it is not a known repository (e.g. alioth)\n"
 436         if $url eq $old_url;
 437     return $url;
 438 }
 439
 440 # Hack around specific, known deficiencies in repositories that don't follow
 441 # standard behavior.
 442 sub munge_url($$)
 443 {
 444     my ($repo_type, $repo_url) = @_;
 445
 446     given ($repo_type) {
 447         when ('bzr') {
 448             # bzr.d.o explicitly doesn't run a smart server.  Need to use nosmart
 449             $repo_url =~ s|^http://(bzr\.debian\.org)/(.*)|nosmart+http://$1/$2|;
 450         }
 451     }
 452     return $repo_url;
 453 }
 454
 455 # Checkout a given repository in a given destination directory.
 456 sub checkout_repo($$$) {
 457     my ($repo_type, $repo_url, $destdir) = @_;
 458     my @cmd;
 459
 460     given ($repo_type) {
 461         when ("arch") { @cmd = ("tla", "grab", $repo_url); }  # XXX ???
 462         when ("bzr") { @cmd = ("bzr", "branch", $repo_url); }
 463         when ("cvs") {
 464             $repo_url =~ s|^-d\s*||;
 465             my ($root, $module) = split /\s+/, $repo_url;
 466             $module ||= '';
 467             @cmd = ("cvs", "-d", $root, "checkout", $module);
 468         }
 469         when ("darcs") { @cmd = ("darcs", "get", $repo_url); }
 470         when ("git") { @cmd = ("git", "clone", $repo_url); }
 471         when ("hg") { @cmd = ("hg", "clone", $repo_url); }
 472         when ("svn") { @cmd = ("svn", "co", $repo_url); }
 473         default { die "unsupported version control system '$repo_type'.\n"; }
 474     }
 475     @cmd = set_destdir($repo_type, $destdir, @cmd) if length $destdir;
 476     print "@cmd ...\n";
 477     system @cmd;
 478     my $rc = $? >> 8;
 479     return $rc;
 480 }
 481
 482 # Checkout a given set of files from a given repository in a given
 483 # destination directory.
 484 sub checkout_files($$$$) {
 485     my ($repo_type, $repo_url, $destdir, $browse_url) = @_;
 486     my @cmd;
 487     my $tempdir;
 488
 489     foreach my $file (@files) {
 490         my $fetched = 0;
 491
 492         # Cheap'n'dirty escaping
 493         # We should possibly depend on URI::Escape, but this should do...
 494         my $escaped_file = $file;
 495         $escaped_file =~ s|\+|%2B|g;
 496
 497         my $dir;
 498         if (defined $destdir and length $destdir) {
 499             $dir = "$destdir/";
 500         } else {
 501             $dir = "./";
 502         }
 503         $dir .= dirname($file);
 504
 505         if (! recurs_mkdir($dir)) {
 506             print STDERR "Failed to create directory $dir\n";
 507             return 1;
 508         }
 509
 510         given ($repo_type) {
 511             when ("arch") {
 512                 # If we've already retrieved a copy of the repository,
 513                 # reuse it
 514                 if (!length($tempdir)) {
 515                     if (!($tempdir = tempdir( "debcheckoutXXXX", TMPDIR => 1, CLEANUP => 1 ))) {
 516                         print STDERR
 517                             "Failed to create temporary directory . $!\n";
 518                         return 1;
 519                     }
 520
 521                     my $oldcwd = getcwd();
 522                     chdir $tempdir;
 523                     @cmd = ("tla", "grab", $repo_url);
 524                     print "@cmd ...\n";
 525                     my $rc = system(@cmd);
 526                     chdir $oldcwd;
 527                     return ($rc >> 8) if $rc != 0;
 528                 }
 529
 530                 if (!copy("$tempdir/$file", $dir)) {
 531                     print STDERR "Failed to copy $file to $dir: $!\n";
 532                     return 1;
 533                 }
 534             }
 535             when ("cvs") {
 536                 if (!length($tempdir)) {
 537                     if (!($tempdir = tempdir( "debcheckoutXXXX", TMPDIR => 1, CLEANUP => 1 ))) {
 538                         print STDERR
 539                             "Failed to create temporary directory . $!\n";
 540                         return 1;
 541                     }
 542                 }
 543                 $repo_url =~ s|^-d\s*||;
 544                 my ($root, $module) = split /\s+/, $repo_url;
 545                 # If an explicit module name isn't present, use the last
 546                 # component of the URL
 547                 if (!length($module)) {
 548                     $module = $repo_url;
 549                     $module =~ s%^.*/(.*?)$%$1%;
 550                 }
 551                 $module .= "/$file";
 552                 $module =~ s%//%/%g;
 553
 554                 my $oldcwd = getcwd();
 555                 chdir $tempdir;
 556                 @cmd = ("cvs", "-d", $root, "export", "-r", "HEAD", "-f",
 557                         $module);
 558                 print "\n@cmd ...\n";
 559                 system @cmd;
 560                 if (($? >> 8) != 0) {
 561                     chdir $oldcwd;
 562                     return ($? >> 8);
 563                 } else {
 564                     chdir $oldcwd;
 565                     if (copy("$tempdir/$module", $dir)) {
 566                         print "Copied to $destdir/$file\n";
 567                     } else {
 568                         print STDERR "Failed to copy $file to $dir: $!\n";
 569                         return 1;
 570                     }
 571                 }
 572             }
 573             when (/(svn|bzr)/) {
 574                 @cmd = ($repo_type, "cat", "$repo_url/$file");
 575                 print "@cmd > $dir/" . basename($file) . " ... \n";
 576                 if (! open CAT, '-|', @cmd) {
 577                     print STDERR "Failed to execute @cmd $!\n";
 578                     return 1;
 579                 }
 580                 local $/;
 581                 my $content = <CAT>;
 582                 close CAT;
 583                 if (! open OUTPUT, ">", $dir . "/" . basename($file)) {
 584                     print STDERR "Failed to create output file "
 585                         . basename($file) ." $!\n";
 586                     return 1;
 587                 }
 588                 print OUTPUT $content;
 589                 close OUTPUT;
 590             }
 591             when (/(darcs|hg)/) {
 592                 # Subtly different but close enough
 593                 if (have_lwp) {
 594                     print "Attempting to retrieve $file via HTTP ...\n";
 595
 596                     my $file_url = $repo_type eq "darcs"
 597                         ? "$repo_url/$escaped_file"
 598                         : "$repo_url/raw-file/tip/$file";
 599                     init_agent() unless $ua;
 600                     my $request = HTTP::Request->new('GET', "$file_url");
 601                     my $response = $ua->request($request);
 602                     if ($response->is_success) {
 603                         if (! open OUTPUT, ">", $dir . "/" . basename($file)) {
 604                             print STDERR "Failed to create output file "
 605                                 . basename($file) . " $!\n";
 606                             return 1;
 607                         }
 608                         print "Writing to $dir/" . basename($file) . " ... \n";
 609                         print OUTPUT $response->content;
 610                         close OUTPUT;
 611                         $fetched = 1;
 612                     }
 613                 }
 614                 if ($fetched == 0) {
 615                     # If we've already retrieved a copy of the repository,
 616                     # reuse it
 617                     if (!length($tempdir)) {
 618                         if (!($tempdir = tempdir( "debcheckoutXXXX", TMPDIR => 1, CLEANUP => 1 ))) {
 619                             print STDERR
 620                                 "Failed to create temporary directory . $!\n";
 621                             return 1;
 622                         }
 623
 624                         # Can't get / clone in to a directory that already exists...
 625                         $tempdir .= "/repo";
 626                         if ($repo_type eq "darcs") {
 627                             @cmd = ("darcs", "get", $repo_url, $tempdir);
 628                         } else {
 629                             @cmd = ("hg", "clone", $repo_url, $tempdir);
 630                         }
 631                         print "@cmd ...\n";
 632                         my $rc = system(@cmd);
 633                         return ($rc >> 8) if $rc != 0;
 634                         print "\n";
 635                     }
 636                 }
 637                 if (copy "$tempdir/$file", $dir) {
 638                     print "Copied $file to $dir\n";
 639                 } else {
 640                     print STDERR "Failed to copy $file to $dir: $!\n";
 641                     return 1;
 642                 }
 643             }
 644             when ("git") {
 645                 # If there isn't a browse URL (either because the package
 646                 # doesn't ship one, or because we were called with a URL,
 647                 # try a common pattern for gitweb
 648                 if (!length($browse_url)) {
 649                     if ($repo_url =~ m%^\w+://([^/]+)/(?:git/)?(.*)$%) {
 650                         $browse_url = "http://$1/?p=$2";
 651                     }
 652                 }
 653                 if (have_lwp and $browse_url =~ /^http/) {
 654                     $escaped_file =~ s|/|%2F|g;
 655
 656                     print "Attempting to retrieve $file via HTTP ...\n";
 657
 658                     init_agent() unless $ua;
 659                     my $file_url = "$browse_url;a=blob_plain";
 660                     $file_url .= ";f=$escaped_file;hb=HEAD";
 661                     my $request = HTTP::Request->new('GET', $file_url);
 662                     my $response = $ua->request($request);
 663                     my $error = 0;
 664                     if (!$response->is_success) {
 665                         if ($browse_url =~ /\.git$/) {
 666                             print "Error retrieving file: "
 667                                 . $response->status_line . "\n";
 668                             $error = 1;
 669                         } else {
 670                             $browse_url .= ".git";
 671                             $file_url = "$browse_url;a=blob_plain";
 672                             $file_url .= ";f=$escaped_file;hb=HEAD";
 673                             $request = HTTP::Request->new('GET', $file_url);
 674                             $response = $ua->request($request);
 675                             if (!$response->is_success) {
 676                                 print "Error retrieving file: "
 677                                     . $response->status_line . "\n";
 678                                 $error = 1;
 679                             }
 680                         }
 681                     }
 682                     if (!$error) {
 683                         if (! open OUTPUT, ">", $dir . "/" . basename($file)) {
 684                             print STDERR "Failed to create output file "
 685                                 . basename($file) . " $!\n";
 686                             return 1;
 687                         }
 688                         print "Writing to $dir/" . basename($file) . " ... \n";
 689                         print OUTPUT $response->content;
 690                         close OUTPUT;
 691                         $fetched = 1;
 692                     }
 693                 }
 694                 if ($fetched == 0) {
 695                     # If we've already retrieved a copy of the repository,
 696                     # reuse it
 697                     if (!length($tempdir)) {
 698                         if (!($tempdir = tempdir( "debcheckoutXXXX", TMPDIR => 1, CLEANUP => 1 ))) {
 699                             print STDERR
 700                                 "Failed to create temporary directory . $!\n";
 701                             return 1;
 702                         }
 703                         # Since git won't clone in to a directory that
 704                         # already exists...
 705                         $tempdir .= "/repo";
 706                         # Can't shallow clone from an http:: URL
 707                         $repo_url =~ s/^http/git/;
 708                         @cmd = ("git", "clone", "--depth", "1", $repo_url,
 709                                 "$tempdir");
 710                         print "@cmd ...\n\n";
 711                         my $rc = system(@cmd);
 712                         return ($rc >> 8) if $rc != 0;
 713                         print "\n";
 714                     }
 715
 716                     my $oldcwd = getcwd();
 717                     chdir $tempdir;
 718
 719                     @cmd = ($repo_type, "show", "HEAD:$file");
 720                     print "@cmd ... > $dir/" . basename($file) . "\n";
 721                     if (! open CAT, '-|', @cmd) {
 722                         print STDERR "Failed to execute @cmd $!\n";
 723                         chdir $oldcwd;
 724                         return 1;
 725                     }
 726                     chdir $oldcwd;
 727                     local $/;
 728                     my $content = <CAT>;
 729                     close CAT;
 730                     if (! open OUTPUT, ">", $dir . "/" . basename($file)) {
 731                         print STDERR "Failed to create output file "
 732                             . basename($file) ." $!\n";
 733                         return 1;
 734                     }
 735                     print OUTPUT $content;
 736                     close OUTPUT;
 737                 }
 738             }
 739             default {
 740                 die "unsupported version control system '$repo_type'.\n";
 741             }
 742         }
 743     }
 744
 745     # If we've got this far, all the files were retrieved successfully
 746     return 0;
 747 }
 748
 749 # Print information about a repository and quit.
 750 sub print_repo($$) {
 751     my ($repo_type, $repo_url) = @_;
 752
 753     print "$repo_type\t$repo_url\n";
 754     exit(0);
 755 }
 756
 757 sub git_ls_remote($$) {
 758     my ($url, $prefix) = @_;
 759
 760     my $cmd = "git ls-remote '$url'";
 761     $cmd .= " '$prefix/*'" if length $prefix;
 762     open GIT, "$cmd |" or die "can't execute $cmd\n";
 763     my @refs;
 764     while (my $line = <GIT>) {
 765         chomp $line;
 766         my ($sha1, $name) = split /\s+/, $line;
 767         my $ref = $name;
 768         $ref = substr($ref, length($prefix) + 1) if length $prefix;
 769         push @refs, $ref;
 770     }
 771     close GIT;
 772     return @refs;
 773 }
 774
 775 # Given a GIT repository URL, extract its topgit info (if any), see
 776 # the "topgit" package for more information
 777 sub tg_info($) {
 778     my ($url) = @_;
 779
 780     my %info;
 781     $info{'topgit'} = 'no';
 782     $info{'top-bases'} = '';
 783     my @bases = git_ls_remote($url, 'refs/top-bases');
 784     if (@bases) {
 785         $info{'topgit'} = 'yes';
 786         $info{'top-bases'} = join ' ', @bases;
 787     }
 788     return(\%info);
 789 }
 790
 791 # Print details about a repository and quit.
 792 sub print_details($$) {
 793     my ($repo_type, $repo_url) = @_;
 794
 795     print "type\t$repo_type\n";
 796     print "url\t$repo_url\n";
 797     if ($repo_type eq "git") {
 798         my $tg_info = tg_info($repo_url);
 799         while (my ($k, $v) = each %$tg_info) {
 800             print "$k\t$v\n";
 801         }
 802     }
 803     exit(0);
 804 }
 805
 806 sub guess_repo_type($$) {
 807     my ($repo_url, $default) = @_;
 808     my $repo_type = $default;
 809     if ($repo_url =~ /^(git|svn)(\+ssh)?:/) {
 810         $repo_type = $1;
 811     } elsif ($repo_url =~ /^https?:\/\/(svn|git|hg|bzr|darcs)\.debian\.org/) {
 812         $repo_type = $1;
 813     }
 814     return $repo_type;
 815 }
 816
 817 # Does a given string match the lexical rules for package names?
 818 sub is_package($) {
 819     my ($arg) = @_;
 820
 821     return ($arg =~ /^[a-z0-9.+-]+$/);  # lexical rule for package names
 822 }
 823
 824 sub main() {
 825     my $auth = 0;                 # authenticated mode
 826     my $destdir = "";     # destination directory
 827     my $pkg = "";                 # package name
 828     my $version = "";       # package version
 829     my $print_mode = 0;   # print only mode
 830     my $details_mode = 0;         # details only mode
 831     my $repo_type = "svn";  # default repo typo, overridden by '-t'
 832     my $repo_url = "";    # repository URL
 833     my $user = "";        # login name (authenticated mode only)
 834     my $browse_url = "";    # online browsable repository URL
 835     my $git_track = "";     # list of remote GIT branches to --track
 836     GetOptions(
 837         "auth|a" => \$auth,
 838         "help|h" => sub { pod2usage({-exitval => 0, -verbose => 1}); },
 839         "print|p" => \$print_mode,
 840         "details|d" => \$details_mode,
 841         "type|t=s" => \$repo_type,
 842         "user|u=s" => \$user,
 843         "file|f=s" => sub { push(@files, $_[1]); },
 844         "git-track=s" => \$git_track,
 845         ) or pod2usage({-exitval => 3});
 846     pod2usage({-exitval => 3}) if ($#ARGV < 0 or $#ARGV > 1);
 847     pod2usage({-exitval => 3,
 848                -message =>
 849                    "-d and -p are mutually exclusive.\n", })
 850         if ($print_mode and $details_mode);
 851     my $dont_act = 1 if ($print_mode or $details_mode);
 852
 853     # -u|--user implies -a|--auth
 854     $auth = 1 if length $user;
 855
 856     $destdir = $ARGV[1] if $#ARGV > 0;
 857     ($pkg, $version) = split(/=/, $ARGV[0]);
 858     $version ||= "";
 859     if (not is_package($pkg)) {  # repo-url passed on the command line
 860         $repo_url = $ARGV[0];
 861         $repo_type = guess_repo_type($repo_url, $repo_type);
 862         $pkg = ""; $version = "";
 863     } else {  # package name passed on the command line
 864         ($repo_type, $repo_url) = find_repo($pkg, $version);
 865         unless ($repo_type) {
 866             my $vermsg = "";
 867             $vermsg = ", version $version" if length $version;
 868             print <<EOF;
 869 No repository found for package $pkg$vermsg.
 870
 871 A Vcs-* field is missing in its source record. See Debian Developer's
 872 Reference 6.2.5:
 873  `http://www.debian.org/doc/developers-reference/best-pkging-practices.html#bpp-vcs'
 874 If you know that the package is maintained via a version control
 875 system consider asking the maintainer to expose such information.
 876
 877 Nevertheless, you can get the sources of package $pkg
 878 from the Debian archive executing:
 879
 880  apt-get source $pkg
 881
 882 Note however that what you obtain will *not* be a local copy of
 883 some version control system: your changes will not be preserved
 884 and it will not be possible to commit them directly.
 885
 886 EOF
 887             exit(1);
 888         }
 889         $browse_url = find_browse($pkg, $version) if @files;
 890     }
 891
 892     $repo_url = munge_url($repo_type, $repo_url);
 893     $repo_url = set_auth($repo_type, $repo_url, $user, $dont_act)
 894         if $auth and not @files;
 895     print_repo($repo_type, $repo_url) if $print_mode;           # ... then quit
 896     print_details($repo_type, $repo_url) if $details_mode;      # ... then quit
 897     if (length $pkg) {
 898         print "declared $repo_type repository at $repo_url\n";
 899         $destdir = $pkg unless length $destdir;
 900     }
 901     my $rc;
 902     if (@files) {
 903         $rc = checkout_files($repo_type, $repo_url, $destdir, $browse_url);
 904     } else {
 905         $rc = checkout_repo($repo_type, $repo_url, $destdir);
 906     }   # XXX: there is no way to know for sure what is the destdir :-(
 907     die "checkout failed (the command above returned a non-zero exit code)\n"
 908         if $rc != 0;
 909
 910     # post-checkout actions
 911     if ($repo_type eq 'bzr' and $auth) {
 912         if (open B, '>>', "$destdir/.bzr/branch/branch.conf") {
 913             print B "\npush_location = $repo_url";
 914             close B;
 915         } else {
 916             print STDERR
 917                 "failed to open branch.conf to add push_location: $!\n";
 918         }
 919     } elsif ($repo_type eq 'git') {
 920         my $tg_info = tg_info($repo_url);
 921         my $wcdir = $destdir;
 922         # HACK: if $destdir is unknown, take last URL part and remove /.git$/
 923         $wcdir = (split m|\.|, (split m|/|, $repo_url)[-1])[0]
 924             unless length $wcdir;
 925         if ($$tg_info{'topgit'} eq 'yes') {
 926             print "TopGit detected, populating top-bases ...\n";
 927             system("cd $wcdir && tg remote --populate origin");
 928             $rc = $? >> 8;
 929             print STDERR "TopGit population failed\n" if $rc != 0;
 930         }
 931         system("cd $wcdir && git config user.name \"$ENV{'DEBFULLNAME'}\"")
 932             if (defined($ENV{'DEBFULLNAME'}));
 933         system("cd $wcdir && git config user.email \"$ENV{'DEBEMAIL'}\"")
 934             if (defined($ENV{'DEBEMAIL'}));
 935         if (length $git_track) {
 936             my @heads;
 937             if ($git_track eq '*') {
 938                 @heads = git_ls_remote($repo_url, 'refs/heads');
 939             } else {
 940                 @heads = split ' ', $git_track;
 941             }
 942             # Filter out any branches already populated via TopGit
 943             my @tgheads = split ' ', $$tg_info{'top-bases'};
 944             my $master = 'master';
 945             if (open(HEAD, "env GIT_DIR=\"$wcdir/.git\" git symbolic-ref HEAD |")) {
 946                 $master = <HEAD>;
 947                 chomp $master;
 948                 $master =~ s@refs/heads/@@;
 949             }
 950             close(HEAD);
 951             foreach my $head (@heads) {
 952                 next if $head eq $master;
 953                 next if grep { $head eq $_ } @tgheads;
 954                 my $cmd = "cd $wcdir";
 955                 $cmd .= " && git branch --track $head remotes/origin/$head";
 956                 system($cmd);
 957             }
 958         }
 959     } elsif ($repo_type eq 'hg') {
 960         my $username = '';
 961         $username .= " $ENV{'DEBFULLNAME'}" if (defined($ENV{'DEBFULLNAME'}));
 962         $username .= " <$ENV{'DEBEMAIL'}>" if (defined($ENV{'DEBEMAIL'}));
 963         if ($username) {
 964             if (open(HGRC, '>>', "$destdir/.hg/hgrc")) {
 965                 print HGRC "[ui]\nusername =$username\n";
 966                 close HGRC;
 967             } else {
 968                 print STDERR
 969                     "failed to open hgrc to set username: $!\n";
 970             }
 971         }
 972     }
 973     exit($rc);
 974 }
 975
 976 main();
 977