#!/usr/bin/perl -w
use strict;

# $Id: debget,v 1.15 2001/02/14 05:04:07 roderick Exp $
#
# Roderick Schertler <roderick@argon.org>

# Copyright (C) 1998 Roderick Schertler
#
# 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.
#
# For a copy of the GNU General Public License write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

# A full spec is a list ref:
#
#    [host, initial-directory, directory, RE]
#
# This specifies that files in host:initial-directory/directory which
# match the RE are to be downloaded.  These are coalesced by host and
# initial-directory leaving specs, which are just the final two elements.

# XXX
#    - download the *.dsc, then skip downloading files which are already
#      present locally
#    - add --clean (see CVS diffs for original documentation)
#    - don't install all produced packages if she gave binary package
#      names to download
#    - check out apt-cache

use Getopt::Long	();
use Net::FTP		();
use Proc::WaitStat	qw(waitstat waitstat_die);

(my $Me = $0) =~ s-.*/--;
my $Exit = 0;
my # new line required for makemaker
    $VERSION = '1.3';

use vars qw(%O);
%O = (
    'arch'		=> undef,
    'binary'		=> 0,
    'build'		=> undef,
    'debug'		=> 0,
    'dir'		=> 'debian',
    'dist'		=> 'unstable',
    'host'		=> 'ftp.debian.org',
    'install'		=> undef,
    'no'		=> 0,
    'no-config'		=> 0,
    'no-download-re'	=> [],
    'no-download-tar'	=> 0,
    'no-dscverify'	=> 0,
    'no-user-config'	=> 0,
    'non-us-dir'	=> 'debian-non-US',
    'non-us-host'	=> 'non-us.debian.org',
    'root-build'	=> undef,
    'root-install'	=> undef,
    'source'		=> 1,
    'unpack'		=> undef,
    'verbose'		=> 0,
);

my @Option_spec = (
    'arch=s',
    'binary|b!',
    'B'			=> sub { $O{'binary'} = 0 },
    'build!',
    'debug!',
    'dir=s',
    'dist|d=s',
    'help!',		# can't die from here because the code is eval()led
    'host|h=s',
    'install|i!',
    'no|n!',
    'no-config|f!',
    'no-download-re=s@',
    'no-download-tar!',
    'no-dscverify!',
    'no-user-config|F!',
    'non-us-dir=s',
    'non-us-host|H=s',
    'root-build|r=s',
    'root-install|R=s',
    'source|s!',
    'S'			=> sub { $O{'source'} = 0 },
    'unpack|u!',
    'verbose|v!',
    'version'		=> sub { print "$Me version $VERSION\n"; exit },
);

# Booleans with single-letter aliases need special handling to avoid a
# bogus warning from Getopt::Long.  Move the single-letter version to
# its own spec.

for (my $i = 0; $i <= $#Option_spec; $i++) {
    next if ref $Option_spec[$i];
    if ($Option_spec[$i] =~ s/(.*)\|(\w)!$/$1!/) {
	push @Option_spec, $2 => \$O{$1};
    }
}

my $Usage = <<EOF;
usage: $Me [switch]... { package | section/package | file.dsc | file.deb }...

switches:
    	--arch arch		installation architecture, default from dpkg
    -b, --binary		download binary packages
    -B, --nobinary		don\'t download binary packages (default)
    -u, --build			build binary packages from source
				packages and .dsc files (implies --unpack)
        --debug			turn debugging on
        --dir dir		path to debian directory, default $O{'dir'}
    -d, --dist dist		distribution, default $O{'dist'}
        --help			show this and then die
    -h, --host host		FTP host, default $O{'host'}
    -i, --install		install binary packages (implies --build)
    -n, --no			don\'t download anything
    -f, --no-config		don\'t read any config files
	--no-download-re re	don\'t download files which match regexp re
	--no-download-tar	don\'t download *.tar.gz files
    	--no-dscverify		don\'t run dscverify before unpacking
    -F, --no-user-config	don\'t read the user\'s config file
        --non-us-dir dir	path to non-US directory, default $O{'non-us-dir'}
    -H, --non-us-host host	non-US FTP host, default $O{'non-us-host'}
    -r, --root-build cmd	use cmd to become root to build (see docs)
    -R, --root-install cmd	use cmd to become root to install (see docs)
    -s, --source		download source packages (default)
    -S, --nosource		don\'t download source packages
	--unpack		unpack source packages and .dsc files
    -v, --verbose		be verbose
        --version		print the version and exit

Use section/package (eg, base/dpkg or non-free/games/quake2) for packages
which aren\'t in the available file, or for which $Me guesses the section
wrong.

See the man page or \`perldoc $Me\' for the full documentation.
EOF

sub xwarndie_mess {
    my @mess = ("$Me: ", @_);
    $mess[$#mess] =~ s/:$/: $!\n/;	# XXX loses if it's really /:\n/
    return @mess;
}

sub xdie {
    die xwarndie_mess @_;
}

sub xwarn {
    if (@_ && $_[0] eq '-noerror') {
	shift;
    }
    else {
	$Exit ||= 1;
    }
    warn xwarndie_mess @_;
}

sub usage {
    xwarn @_ if @_;
    die $Usage;
}

sub debug {
    print "debug: ", @_, "\n" if $O{'debug'};
}

sub verbose {
    print @_, "\n" if $O{'verbose'};
}

sub show_invocation {
    my ($s, @a) = @_;
    debug "$s(" . join(', ', map { defined $_ ? $_ : '(undef)' } @a) . ")";
}

sub show_return {
    my ($s, @a) = @_;
    debug "$s() returning "
	    . join(', ', map { defined $_ ? $_ : '(undef)' } @a);
    return @a;
}

# Uniqify the give list refs, based on stringwise list contents joined
# by \0.

sub uniq_lref {
    my @l = @_;
    my %seen;

    return grep { !$seen{join "\0", @$_}++ } @l;
}

sub find_prog {
    my ($msg, @prog) = @_;

    my $path = defined $ENV{PATH} ? $ENV{PATH} : ':/bin:/usr/bin';
    for my $prog (@prog) {
	for my $dir (split /:/, $path, -1) {
	    $dir = '.' if $dir eq '';
	    $dir = '' if $dir eq '/';
	    return $prog if -x "$dir/$prog" && -f _;
	}
    }
    xdie "can't find a program $msg, tried: @prog\n";
}

sub dirents {
    my $dir = shift;
    local *DIR;

    opendir DIR, $dir
	or xdie "can't opendir $dir:";
    my @ents = grep { $_ ne '.' && $_ ne '..' } readdir DIR;
    closedir DIR
	or xdie "error running closedir on $dir:";
    return @ents;
}

sub net_warndie_mess {
    my $cmd = shift;
    my $text = join '', @_;
    my $code = $cmd->code;
    my $message = $cmd->message;
    chomp $message;
    return "$text ($code $message)\n";
}

sub net_warn {
    xwarn net_warndie_mess @_;
}

sub net_die {
    xdie net_warndie_mess @_;
}

# Getopt::Long has some really awful defaults.  This function loads it
# then configures it to use more sane settings.

sub getopt;
sub configure_getopt {
    Getopt::Long->import(2.11);
    *getopt = \&Getopt::Long::GetOptions;

    # I'm setting this environment variable lest he sneaks more bad
    # defaults into the module.
    local $ENV{POSIXLY_CORRECT} = 1;
    Getopt::Long::config qw(
	default
	no_autoabbrev
	no_getopt_compat
	require_order
	bundling
	no_ignorecase
    );
}

sub do_file {
    my $file = shift;
    debug "do $file";
    # XXX Need to fix Perl to be able to detect if the file was
    # unreadable or the like.
    do $file;
    $@ and xdie "error in $file: $@";
}

# Return the host/dir that should be used for a file in DIST.

sub host_dir {
    my $sec1 = shift;
    return $sec1 =~ /^non-US/i
	    ? ($O{'non-us-host'}, $O{'non-us-dir'})
	    : ($O{'host'}, $O{'dir'});
}

# Return the installation architecture.

sub arch {
    if (!defined $O{'arch'}) {
	chomp($O{'arch'} = `dpkg --print-installation-architecture`);
	waitstat_die $?, 'dpkg';
	$O{'arch'} ne '' or xdie "dpkg didn't print the architecture";
    }
    return $O{'arch'};
}

# Return the directory in which to find files of the give TYPE
# (source/binary) for the given DISTRIBUTION, SECTION1 and SECTION2.

sub file_dir {
    my ($type, $dist, $sec1, $sec2) = @_;

    $sec2 = "/$sec2" if $sec2 ne '';

    if ($dist eq 'experimental') {
	return 'project/experimental';
    }

    if ($type eq 'source') {
	return "dists/$dist/$sec1/source$sec2";
    }

    if ($type eq 'binary') {
	my $arch = arch;
	return "dists/$dist/$sec1/binary-$arch$sec2";
    }

    xdie "invalid type `$type'";
}

sub sectionless_dist {
    return $O{'dist'} eq 'experimental';
}

sub init {
    configure_getopt;

    # This is a bit of a hack.  I have to parse the command line to
    # learn whether -f or -F was given before I read the rc files, but I
    # want the command line to override the settings in the rc files.  I
    # had used globals for the configuration until I needed to do this.
    my @copy_key = qw(no-config no-user-config);
    # I have to use the real %O, because @Option_spec contains references
    # to it.  So, set up to restore the original values except for those
    # I'm checking right now.
    my %orig_o = %O;
    {
	local @ARGV = @ARGV;
	getopt \%O, @Option_spec;
    }
    my %new_o = %O;
    @O{keys %orig_o} = values %orig_o;	# use slice to retain old SVs
    @O{@copy_key} = @new_o{@copy_key};

    do_file '/etc/debget.rc'	unless $O{'no-config'};
    do_file "$ENV{HOME}/.debget.rc"
				unless $O{'no-config'} || $O{'no-user-config'};

    getopt \%O, @Option_spec or usage;
    usage if $O{'help'};
    $| = 1 if $O{'debug'};
}

# Return the actual package name, section code and source package for
# PACKAGE.  If USER_PACKAGE is given, it's the package the user named
# which actually led to this package.  If NO_ERROR is true, return
# nothing rather than dying if no answer can be found.
#
# Someday we will always be able to find the source package for a given
# binary.  With the info currently available this isn't the case because
# there's no sure way to know what section the source is in.

{
my %cache;

sub query_package;	# needed for paren-less recursive invocation

sub query_package {
    show_invocation 'query_package', @_;
    my ($package, $user_package, $no_error) = @_;
    my ($user_section);

    if ($package =~ s-(.*)/--) {
	$user_section = $1;
    }

    if (!$cache{$package}) {
	my ($sec, $source);

	# The user specified the section on the command line, use hers.
	if (defined $user_section) {
	    debug "using user-specified section";
	    $sec = $user_section;

	    # Recurse to get the source, but if it isn't there (it
	    # probably isn't, that's probably why she supplied the
	    # section) just assume it's the same.
	    $source = (query_package $package, $user_package, 1)[2];
	    $source = $package if !defined $source;
	}

	else {
	    verbose "dpkg --print-avail $package";
	    my $s = `dpkg --print-avail $package`;
	    waitstat_die $?, 'dpkg';

	    # First choice, get the section from the available info.
	    if ($s =~ /^Section\s*:\s*(\S+)/im) {
		$sec = $1;
	    }

	    # Under some circumstances the section field isn't present
	    # in the available record (probably from a control file
	    # without this info and the package not in the packages
	    # files most recently used to update the available file).
	    # In this case try to infer it from the file name.
	    #
	    # dists/stable/main/binary-i386/interpreters/perl_5.004.04-6.deb
	    elsif ($s =~ m#^Filename\s*:\s*
			       dists/[^/]+/([^/]+)/binary-[^/]+/([^/]+)#xim) {
		$sec = $1 eq 'main' ? $2 : "$1/$2";
	    }

	    # If this package wasn't explicitly named by the user (that
	    # is, it's the source for one that was), fall back to using
	    # the section for the package which actually was specified.
	    elsif (defined $user_package
		    and my @ret = query_package $user_package, undef, 1) {
		$ret[0] = $package;
		xwarn -noerror, "section for $package unknown,",
				" using $ret[1] (from $user_package)\n"
		    unless sectionless_dist;
		$cache{$package} = [@ret];
		return show_return 'query_package', @ret;
	    }

	    # Don't require a section for some dists.
	    elsif (sectionless_dist && !$no_error) {
		$sec = '';
		# Try to get the source, but if it isn't there just use
		# the package name.
		$source = (query_package $package, $user_package, 1)[2];
		$source = $package if !defined $source;
	    }

	    # Otherwise choke.  The user has to specify the section on
	    # the command line.
	    else {
		return show_return 'query_dpkg' if $no_error;
		xdie "section for $package",
			defined $user_package
			    ? " (source for $user_package)"
			    : "",
			" unknown, specify it",
			" (eg `base/dpkg' or `non-free/games/quake2')\n";
	    }

	    $source = $s =~ /^Source\s*:\s*(\S+)/im ? $1 : $package;
	}

	$cache{$package} = [$package, $sec, $source];
    }

    return show_return 'query_package', @{ $cache{$package} } ;
} }

# Get the section code for PACKAGE and split it up into distribution,
# section and package, returning all three.  If USER_PACKAGE is given,
# it's the package the user named which actually led to this package.

sub package_section {
    show_invocation 'package_section', @_;
    my ($package, $user_package) = @_;
    my ($sec1, $sec2);

    ($package, $sec2) = query_package $package, $user_package;

    # non-US
    # non-US/non-free
    if ($sec2 =~ s#^non-US(/|$)##) {
    	# no subsections
	$sec1 = 'non-US/' . ($sec2 || 'main');
	$sec2 = '';
    }
    # games
    # non-free/graphics
    else {
	$sec1 = ($sec2 =~ s-(.*)/--) ? $1 : 'main';
    }

    return show_return 'package_section', $sec1, $sec2, $package;
}

# Return the source package for PACKAGE.  If USER_PACKAGE is given, it's
# the package the user named which actually led to this package.

sub package_source {
    show_invocation 'package_source', @_;
    my ($package, $user_package) = @_;

    my $source = (query_package $package, $user_package)[2];
    return show_return 'package_source', $source;
}

# Return the full file specs which should be downloaded for PACKAGE.

sub make_full_specs {
    my $orig_package = shift;
    my (@ret, $sec1, $sec2, $package);

    ($sec1, $sec2, $package) = package_section $orig_package;
    if ($O{'source'}) {
	my ($s1, $s2, $p) = package_section package_source($package),
					    $orig_package;
	push @ret, [host_dir($s1),
    	    	    file_dir('source', $O{'dist'}, $s1, $s2),
		    "^\Q$p\E_.*\\.(dsc|tar\\.gz|diff\\.gz)\$"];
    }
    if ($O{'binary'}) {
	my $arch = arch;
	push @ret, [host_dir($sec1),
    	    	    file_dir('binary', $O{'dist'}, $sec1, $sec2),
		    "^\Q$package\E_[^_]+(_(\Q$arch\E|all))?\\.deb\$"];
    }
    return @ret;
}

# Run nlst via FTP on directory DIR, return the file names (without
# directory).

{
my %cache;

sub ls {
    my ($ftp, $dir) = @_;

    if (!$cache{$ftp}{$dir}) {
	verbose "ls  $dir";
	my $rls = $ftp->ls($dir)
	    or net_die $ftp, "error running ls for $dir";
	# Some implementations return just the base names, some include
	# the directory.  Strip the directories if they're there.
	for (@$rls) {
	    s-.*/--;
	}
	$cache{$ftp}{$dir} = $rls;
    }
    return @{ $cache{$ftp}{$dir} };
} }

# Take an FTP connection and a SPEC and return the actual files which
# should be downloaded.

sub glob_spec {
    my ($ftp, $spec) = @_;
    my ($dir, $re) = @$spec;
    show_invocation 'glob_spec', $dir, $re;

    my @file = map { "$dir/$_" } grep { /$re/ } ls $ftp, $dir;
    if (!@file) {
	xwarn "no files in $dir match /$re/\n";
    }
    return @file;
}

# Return true if I'm allowed to download a file named FILE.

sub allow_download {
    my ($file) = @_;

    return 0 if $file =~ /\.tar\.gz$/ && $O{'no-download-tar'};
    for (@{ $O{'no-download-re'} }) {
	return 0 if $file =~ /$_/;
    }
    return 1;
}

# Connect to HOST, chdir to DIR and retrieve the files required by SPECs.

sub do_ftp {
    my ($host, $dir, @spec) = @_;
    my ($ftp, @got);

    verbose "connect to $host";
    $ftp = Net::FTP->new($host, Debug => $O{'debug'})
	or xdie "can't connect to $host: $@\n";
    $ftp->login		or net_die $ftp, "error logging in to $host";
    $ftp->binary	or net_die $ftp, "error setting binary mode";
    verbose "chdir $dir";
    $ftp->cwd($dir)	or net_die $ftp, "error doing cd to $dir";

    for (@spec) {
	for my $file (glob_spec $ftp, $_) {
	    if (!allow_download $file) {
		print "# skip download of $file\n" if $O{'verbose'};
		next;
	    }
	    print "get " if $O{'verbose'};
	    print "$file\n";
	    next if $O{'no'};
	    if ($ftp->get($file)) {
		push @got, $file;
		$got[-1] =~ s-.*/--;
    	    }
	    else {
		net_warn $ftp, "error getting $file";
	    }
	}
    }

    verbose "disconnect from $host";
    $ftp->quit or net_warn $ftp, "error closing FTP session to $host";
    return @got;
}

# Run the given COMMAND like system(), but don't output the stdout
# unless verbose mode is on.

sub run {
    my @cmd = @_;
    my ($ret);

    if (!$O{'verbose'}) {
	open SAVEOUT, '>&STDOUT' or xdie "can't dup stdout:"
	    unless defined fileno SAVEOUT;
	open STDOUT, '>/dev/null' or xdie "can't write to /dev/null:";
    }

    $ret = system @cmd;

    open STDOUT, '>&SAVEOUT' or xdie "can't redup stdout:"
	if !$O{'verbose'};

    return $ret;
}

# Using SUPROG run the given COMMAND, with special handling for an
# SUPROG of su.

sub root_run {
    my ($su, @cmd) = @_;
    my (@arg);

    # This is more complicated than it needs to be because of GNU's
    # accursed argument reordering.  If you have an argument to the
    # command which looks like a switch GNU's su will act on it unless
    # you use -- to stop option processing or set $POSIXLY_CORRECT.  I
    # don't want to set $POSIXLY_CORRECT because that will affect the
    # behavior of the command run.  Using -- on its own doesn't work
    # because the su which comes with the shadow tools (packaged as
    # secure-su) doesn't do real option processing and doesn't recognize
    # it.
    #
    # So, I have this.  I put the -- there and then remove it myself if
    # necessary.  With GNU su the "" arg ends up in $0.  With secure-su
    # the -- ends up in $0 and the "" in $1, and I shift it out of $1.

    @arg = ('root', '-c', '[ -z "$1" ] && shift; exec "$@"', '--', '')
	if $su eq 'su';

    run $su, @arg, @cmd;
}

# Unpack the given DSC_FILE, returning the name of the directory created
# if all went well.

sub dscunpack {
    my $dsc = shift;
    my ($dir, $skipping);

    if (!$O{'no-dscverify'}) {
	verbose "dscverify $dsc";
	run 'dscverify', $dsc;
	if ($?) {
	    xwarn "non-zero exit (", waitstat $?, ") verifying $dsc,",
	    	    " skipping it\n";
	    if (!eval { find_prog 'x', 'dscverify' }
		    || ! -f '/usr/share/keyrings/debian-keyring.gpg') {
		xwarn "install the devscripts and debian-keyring packages",
		    	" or specify --no-dscverify\n";
	    }
	    return;
	}
    }

    $dir = $dsc;
    $dir =~ s/\.dsc$//;
    $dir =~ s/(_.*?)-[^\-]+/$1/;
    $dir =~ s/_/-/;
    print "$dir\n" unless $O{'verbose'};

    # I won't actually be skipping anything unless I'm going to build or
    # install.
    $skipping = $O{'build'} || $O{'install'};

    verbose "unpack $dsc";
    run 'dpkg-source', '-x', $dsc;
    if ($?) {
	xwarn "non-zero exit (", waitstat $?, ") from dpkg-source",
	    	" unpacking $dsc", $skipping ? ", skipping it" : '', "\n";
	return;
    }

    unless (-d $dir) {
	xwarn "directory $dir wasn't created by dpkg-source unpacking $dsc",
    	    	$skipping ? ", skipping it" : '', "\n";
	return;
    }

    return $dir;
}

# Build the package which is in DIRECTORY, returning the names of the
# generated binary packages if all went well.

sub build {
    my $dir = shift;
    my ($skipping, %before, @deb);

    verbose "$dir/debian/rules build";
    run 'sh', '-c', 'cd "$1" && debian/rules build', 'x', $dir;
    if ($?) {
	xwarn "non-zero exit (", waitstat $?, ") from `debian/rules build'",
	    	" in $dir, skipping it\n";
	return;
    }

    # Save the existing *.deb files and the age of each.
    %before = map { $_ => -M $_ } grep { /\.deb$/ } dirents '.';

    verbose "$dir/debian/rules binary";
    root_run $O{'root-build'},
	'sh', '-c', 'cd "$1" && debian/rules binary', 'x', $dir;
    if ($?) {
	xwarn "non-zero exit (", waitstat $?, ") from `debian/rules binary'",
	    	" in $dir via $O{'root-build'}",
	    	$O{'install'} ? ", skipping it" : '', "\n";
	return;
    }

    # Find either new or updated *.deb files.  XXX This is a race with other
    # processes working in this directory.
    @deb = grep { /\.deb$/ && (!$before{$_} || -M $_ < $before{$_}) }
	    dirents '.';
    if (!@deb) {
	xwarn "no *.deb files were produced by $dir\n";
	return;
    }

    print join "\n", @deb, '' unless $O{'verbose'};
    return @deb;
}

sub main {
    my (@dsc, @src, @deb, @full_spec);

    init;

    # Separate .dsc and .deb files from package names.  There's no way
    # to give a directory name and have that mean "build the package in
    # this directory" because there'd be an ambiguity (if you have a
    # directory with the same name as a package).
    for (@ARGV) {
	if (/\.dsc$/) {
	    push @dsc, $_;
	}
	elsif (/\.deb$/) {
	    push @deb, $_;
	}
	else {
	    push @full_spec, make_full_specs $_;
	}
    }

    # Automatically turn on --build/--install if .dsc/.deb were given.
    $O{'build'}		= 1 if @dsc	&& !defined $O{'build'};
    $O{'install'}	= 1 if @deb	&& !defined $O{'install'};

    # Automatically turn on prerequisites.
    $O{'build'}		= 1 if $O{'install'}	&& !defined $O{'build'};
    $O{'unpack'}	= 1 if $O{'build'}	&& !defined $O{'unpack'};

    # Look for the su-type commands if necessary, before starting
    # downloads.
    $O{'root-install'} = $O{'root-build'}
    	if defined $O{'root-build'} && !defined $O{'root-install'};
    $O{'root-build'} = find_prog 'to become root to build',
				    qw(fakeroot sudo super su)
	if $O{'build'} && !defined $O{'root-build'};
    $O{'root-install'} = find_prog 'to become root to install',
				    qw(sudo super su)
    	if $O{'install'} && !defined $O{'root-install'};

    # Make sure there's something to do.
    unless (@dsc || @deb) {
	$O{'source'} || $O{'binary'}
	    or xdie "neither source nor binary packages",
	    	    " are being downloaded\n";
	@ARGV or usage "no packages or files specified\n";
    }

    # Uniqify the full specs because, eg, multiple packages can come
    # from the same source.
    @full_spec = uniq_lref @full_spec;

    # Split the full specs up into specs grouped by host/directory.
    my %work;
    for (@full_spec) {
	my ($host, $dir, @spec) = @$_;
	push @{ $work{$host}{$dir} }, \@spec;
    }

    # For each host/directory pair, connect and download the given
    # specs.
    for my $host (sort keys %work) {
	for my $dir (sort keys %{ $work{$host} }) {
	    for (do_ftp $host, $dir, @{ $work{$host}{$dir} }) {
		if (/\.dsc$/) {
		    push @dsc, $_;
		}
		elsif (/\.deb$/) {
		    push @deb, $_;
		}
	    }
	}
    }

    if ($O{'unpack'} && @dsc) {
	for (@dsc) {
	    push @src, dscunpack $_;
	}
    }

    if ($O{'build'} && @src) {
	for (@src) {
	    push @deb, build $_;
	}
    }

    if ($O{'install'} && @deb) {
	root_run $O{'root-install'}, 'dpkg', '-i', @deb;
	if ($?) {
	    xwarn "non-zero exit (", waitstat $?,
		    ") running dpkg via $O{'root-install'} to install @deb\n";
	}
    }

    return 0;
}

$Exit = main || $Exit;
$Exit = 1 if $Exit and not $Exit % 256;
exit $Exit;

__END__

=head1 NAME

debget - download source and binary Debian packages

=head1 SYNOPSIS

B<debget> [I<switch>]... { I<package> | I<section/package> | I<file>.dsc
| I<file>.deb }...

=head1 DESCRIPTION

B<debget> downloads source and binary Debian packages by name and
optionally unpacks, compiles and installs them.  The default behavior
is to download the source for packages, to unpack and build F<*.dsc>
files and to install F<*.deb> files.  For detailed defaults on FTP
server names and such run C<debget --help>.

B<debget> doesn't require a local copy of the F<Packages> files, instead it
lists directories on the FTP site to find out what versions are available.

Non-switch arguments are F<*.dsc> files, F<*.deb> files, and package
names or I<section/package>, eg B<base/dpkg> or B<non-free/games/quake2>.
There are two cases in which you've got to specify the section:

=over 4

=item -

Information about the package isn't in the local F<available> file (as
shown by C<dpkg --print-avail>), or the information there is wrong.

=item -

You're downloading a source package which doesn't generate a binary
package of the same name.  Normally B<debget> infers the correct
source package to download based on the C<dpkg --print-avail> output.
(Eg, if you say to download the source for B<perl-base>, it will
really download the B<perl> sources.)  This isn't possible if the
source package doesn't have an F<available> file entry (which is the
case when the source package doesn't generate a binary package of the
same name).  In this case B<debget> will use the section for the
package which you specified (B<perl-base> in this case).  If the
section for that package isn't available, or if it's not the same as
the section for the source package, you have to specify the section
yourself.

=back

To handle either of these cases, specify the package with the section
prepended, as it would appear in the F<available> file.  Eg, B<base/dpkg>
or B<non-free/games/quake2>.

=head1 OPTIONS

=over 4

=item B<--arch> I<arch>

Specify the installation architecture (used to find binary packages).
The default is the output of C<dpkg --print-installation-architecture>.

=item B<-b>, B<--binary>

Download binary packages.  The default is not to download them.

=item B<-B>, B<--nobinary>

Don't download binary packages.  This is the default.

=item B<-u>, B<--build>

Build downloaded source packages.  This implies B<--unpack>.  B<--build>
is turned off by default, but it is turned on if you specify any F<*.dsc>
or F<*.deb> files on the command line.

=item B<--debug>

Turn debugging on.

=item B<--dir> I<dir>

Specify the path to the top of the Debian hierarchy on the primary FTP
server.

=item B<-d> I<dist>, B<--dist> I<dist>

Specify the distribution from which to download packages.  The
default is B<unstable>.  You can use the name of any subdirectory
in the F<dists> directory in the Debian archive, or B<experimental>
(which is special-cased).

=item B<--help>

Show the usage message and die.

=item B<-h> I<host>, B<--host> I<host>

Specify the host name of the primary FTP server.

=item B<-i>, B<--install>

Install binary packages.  This turns on B<--unpack> and B<--build>, so
specifying it will cause B<debget> to install just about everything you
mention on the command line.  Packages will be downloaded, unpacked, built,
and installed, F<*.dsc> files will be unpacked, built, and installed, and
F<*.deb> files will be installed.

=item B<-n>, B<--no>

Go through the motions, but don't actually download any packages.

=item B<-f>, B<--no-config>

Don't process either /etc/debget.rc or ~/.debget.rc.

=item B<--no-download-re> I<re>

Don't download files whose name match the Perl regexp I<re>.  This
option can be specified multiple times.

=item B<--no-download-tar>

Don't download F<*.tar.gz> files.  This is normally used when downloading
sources, when specified you'll just fetch the F<*.diff.gz> and F<*.dsc>
files.

=item B<--no-dscverify>

Don't run B<dscverify> before unpacking sources.  B<dscverify> checks
that the F<.dsc> file is signed by a Debian developer and that the MD5
sums and file sizes given in it match the files about to be unpacked.
These are good things, so B<debget> will try to run B<dscverify> by
default.  The B<dscverify> program is in the F<devscripts> package.

=item B<-F>, B<--no-user-config>

Don't process ~/.debget.rc.

=item B<--non-us-dir> I<dir>

Specify the path to the top of the Debian hierarchy for non-US packages.

=item B<-H> I<host>, B<--non-us-host> I<host>

Specify the host name of the non-US FTP server.

=item B<-r> I<cmd>, B<--root-build> I<cmd>

Use I<cmd> to become root when building a package from source.  The
default is the first of F<fakeroot>, F<sudo>, F<super>, or F<su> which
is present on the system.

=item B<-R> I<cmd>, B<--root-install> I<cmd>

Use I<cmd> to become root when installing a package.  The default is
what you gave for B<--root-build> if you specified anything, otherwise
the first of F<sudo>, F<super>, or F<su> which is present on the system.

=item B<-s>, B<--source>

Download source packages.  This is the default.

=item B<-S>, B<--nosource>

Don't download source packages.  The default is to download them.

=item B<--unpack>

Unpack downloaded source packages.

=item B<-v>, B<--verbose>

Be verbose.

=item B<--version>

Print the version number and exit.

=back

=head1 CONFIGURATION FILES

The default behavior of B<debget> can be modified by the configuration
files F</etc/debget.rc> and F<~/.debget.rc> (unless modified by the
B<-f> or B<-F> switches).  These files are processed as Perl code.  They
can set these variables to control the program (with their corresponding
switches):

=over 4

=item C<$O{'arch'}>

B<--arch>

=item C<$O{'binary'}>

B<--binary>, boolean

=item C<{$O{'build'}>

B<--build>, boolean

=item C<$O{'debug'}>

B<--debug>, boolean

=item C<$O{'dir'}>

B<--dir>

=item C<$O{'dist'}>

B<--dist>

=item C<$O{'host'}>

B<--host>

=item C<$O{'install'}>

B<--install>, boolean

=item C<$O{'no'}>

B<--no>, boolean

=item C<$O{'no-config'}>

B<--no-config>, boolean

=item C<$O{'no-download-re'}>

B<--no-download-re>, array reference

=item C<$O{'no-download-tar'}>

B<--no-download-tar>, boolean

=item C<$O{'no-dscverify'}>

B<--no-dscverify>, boolean

=item C<$O{'no-user-config'}>

B<--no-user-config>, boolean

=item C<$O{'non-us-dir'}>

B<--non-us-dir>

=item C<$O{'non-us-host'}>

B<--non-us-host>

=item C<$O{'root-build'}>

B<--root-build>

=item C<$O{'root-install'}>

B<--root-install>

=item C<$O{'source'}>

B<--source>, boolean

=item C<$O{'unpack'}>

B<--unpack>, boolean

=item C<$O{'verbose'}>

B<--verbose>, boolean

=back

Here's an example configuration file:

    $O{'host'} = 'debian.terrabox.com';
    $O{'verbose'} = 1;

=head1 BUGS

If you specify B<--install> all produced binary packages will be
installed, even ones you didn't specify on the command line.  Eg, if
you run C<debget
--install ssh> it will install both F<ssh> and F<ssh-askpass>.

I'd like to add a B<--clean> switch which will make the program remove
intermediate files.

See F</usr/doc/debget/README.Debian> if your transfers are failing
because you need to use passive FTP or a proxy.

=head1 SEE ALSO

dselect(8), apt-get(8)

=head1 AUTHOR

Roderick Schertler <roderick@argon.org>

=cut
