dupload 2.9.1ubuntu1 / usr / bin / dupload

#!/usr/bin/perl
#
# dupload - utility to upload Debian packages
#
# Copyright © 1996, 1997 Heiko Schlittermann
# Copyright © 1999 Stephane Bortzmeyer
# Copyright © 1999, 2002, 2003 Josip Rodin <joy-packages@debian.org>
# Copyright © 2005, 2006, 2008, 2011 Frank Lichtenheld <djpig@debian.org>
# Copyright © 2017 Guillem Jover <guillem@debian.org>
#
# 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.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.
#
# see dupload(1) for help.

use strict;
use warnings;

use IO::Handle;
use List::Util qw(any);
use Cwd;
use Getopt::Long;
use File::Basename;
use File::Copy;
use Net::FTP;

#
# More or less configurable constants.
#

my $version = '2.9.1ubuntu1';
my $progname = basename($0);
my $user = getlogin || $ENV{LOGNAME} || $ENV{USER};
my $myhost = qx(hostname --fqdn);
chomp $myhost;
my $cwd = cwd();

# For somewhat more verbose output from the ftp module.
my $debug = 0;
# Fo it, even when already done.
my $force = 0;
# Keep going, even if checksum errors.
my $keep = 0;
# Do not talk too much.
my $quiet = 0;

# Specifies an alternative configuration file to read.
# For backwards compatibility, an empty string means to load ./dupload.conf,
# which is a security risk that we will warn about as deprecated.
my $configfile = undef;

# Target host.
my $host = undef;
# Transfer method.
my $method = 'ftp';
# Default login.
my $login = 'anonymous';
# Default password.
my $passwd = "$user\@$myhost";
# Extra options for rsync or scp.
my $options = q{};

my $sendmail = '/usr/sbin/sendmail';

#
# Global variables
#

# The files we will have to read from.
my @changes;
# The packages we skipped.
my @skipped;
# The files we installed (for postupload processing).
my @all_the_files;
# The packages we installed (for postupload processing).
my @all_the_debs;
# All binary packages we installed (for postupload processing).
my %all_packages;
my $copiedfiles;
# If do-nothing.
my $dry;
my $mailonly;

# Variables per host.
my $fqdn;
my $ftp;
my $dinstall_runs;
my $passive;
my $nomail;
my $archive;
my $noarchive;
my %preupload;
my %postupload;
my $result;
my $incoming;
my $queuedir;
my $mailto;
my $mailtx;
my $cc;
my $visiblename;
my $visibleuser;
my $fullname;
my $dochmode;
my $filemode;

# Variables per job.
my %files;
my %package;
my %version;
my %arch;
my %dir;
my %changes;
my %log;
my %announce;
my %extra;

#
# Prototypes
#

# Reads the config file(s).
sub configure(@);
# Rstablishs the ftp connection.
sub ftp_open($$$);
# Print the available info (for a given host).
sub info($);
# Bail out.
sub fatal(@);
# Read a password.
sub getpass();
# Warn (to STDERR if quiet, to STDOUT else).
sub w(@);
# Print (suppress if quiet, to STDOUT else).
sub p(@);
sub announce_if_necessary($);
# Runs an external program and return its exit status.
sub run($$);

# Some tests on constants.
$user or fatal("Who am I? (cannot get user identity)\n");
$myhost or fatal("Who am I? (cannot get hostname)\n");
$cwd or fatal("Where am I? (cannot get current directory)\n");

unless (-x $sendmail) {
    $nomail = 1;
    w("mail options disabled, cannot run '$sendmail': $!\n");
}

#
# Main
#

$config::default_host = undef;
$config::no_parentheses_to_fullname = undef;
$config::postupload = undef;
$config::preupload = undef;

configure('/etc/dupload.conf', $ENV{HOME} && "$ENV{HOME}/.dupload.conf");

our $opt_Version;
our $opt_configfile;
our $opt_debug;
our $opt_force;
our $opt_help;
our $opt_keep;
our $opt_mailonly;
our $opt_no;
our $opt_noarchive;
our $opt_nomail;
our $opt_print;
our $opt_quiet;
our $opt_to;
our $opt_version;

$Getopt::Long::ignorecase = 0;
GetOptions qw(
    configfile:s
    debug:i
    force
    help
    keep
    mailonly
    no
    noarchive
    nomail
    print
    quiet
    to=s
    version
    Version
) or fatal("Bad Options\n");

# Handle deprecated configfile option.
$configfile = $opt_configfile // $configfile;
if (defined $configfile and length $configfile == 0) {
    w("--configfile without a filename is a security risk and is deprecated\n");
    $configfile = './dupload.conf';
}
configure($configfile) if defined $configfile;

$dry = defined $opt_no;
$mailonly = defined $opt_mailonly;
$dry = 1 if $mailonly;
$debug = $opt_debug || $debug;
$keep = $opt_keep || $keep;
$host = $opt_to || $config::default_host;
$force = $opt_force || $force;
$nomail = $opt_nomail || 0;
$quiet = $opt_quiet;

# Only info or version?
if ($opt_print) {
    info($opt_to);
    exit 0;
}
if ($opt_Version or $opt_version) {
    p("$progname version: $version\n");
    exit 0;
}

if ($opt_help) {
    p(
"Usage: $progname [<options>...] [<changes-file|directory>...]\n" .
"\n" .
"Options:\n" .
"  -t, --to <nickname>      Upload to <nickname>'s host.\n" .
"  -f, --force              Upload even if a previous upload is present.\n" .
"  -k, --keep               Keep going, ignore packages with wrong checksums\n" .
"      --no                 Dry run.\n" .
"      --nomail             Suppress mail announcment for this run.\n" .
"      --mailonly           Dry run, except that mail announcment is sent.\n" .
"      --noarchive          Mark the mail announcment to not be archived.\n" .
"  -p, --print              Print the configuration file.\n" .
"  -c, --configfile         Read dupload.conf from the current directory.\n" .
"  -q, --quiet              Enable quiet mode.\n" .
"  -d, --debug [<level>]    Enable debug output from the FTP module.\n" .
"      --help               Print this help message.\n" .
"  -V, --Version            Print program version.\n"
    );
    exit 0;
}

# Get the configuration for that host global, job independent information.

$host or fatal("Need host to upload to.  (See --to option or the default_host configuration variable)\n");

{
    my $nick = $config::cfg{$host};
    $method = $nick->{method} || $method;
    $options = $nick->{options} || $options;
    $fqdn = $nick->{fqdn};
    $fqdn = $myhost if $method eq 'copy';
    $incoming = $nick->{incoming} or fatal("No Incoming dir\n");
    $queuedir = $nick->{queuedir};
    $mailto = $nick->{mailto};
    $mailtx = $nick->{mailtx} || $mailto;
    $cc = $nick->{cc};
    $dinstall_runs = $nick->{dinstall_runs};
    $passive = $nick->{passive};
    $dochmode = !exists $nick->{filemode} && defined $nick->{filemode};
    $filemode = ($nick->{filemode} // 0644) & 07777;

    if ($passive and ($method ne 'ftp')) {
        fatal("Passive mode is only for FTP ($host)");
    }
    if (not $fqdn) {
        fatal("Nothing known about host $host\n");
    }
    if (defined $nick->{archive}) {
        $archive = $nick->{archive};
    } else {
        $archive = 1;
    }

    foreach my $category (qw/changes sourcepackage package file deb/) {
        if (defined $nick->{preupload}{$category}) {
            $preupload{$category} = $nick->{preupload}{$category};
        } else {
            $preupload{$category} = $config::preupload{$category};
        }

        if (defined $nick->{postupload}{$category}) {
            $postupload{$category} = $nick->{postupload}{$category};
        } else {
            $postupload{$category} = $config::postupload{$category};
        }
    }

    if ($method eq 'ftp') {
        $login = $nick->{login} || $login;
    }
    if ($method eq 'scp' or $method eq 'scpb' or $method eq 'rsync') {
        $login = $nick->{login} || $user;
    }
    $visibleuser = $nick->{visibleuser} || $user;
    chomp $visibleuser;
    $visiblename = $nick->{visiblename} || '';
    chomp $visiblename;
    $fullname = $nick->{fullname} || '';

    # Do not accept passwords in configuration file, except for anonymous
    # logins.
    undef $passwd unless $login =~ /^anonymous|ftp$/;
    if ($nick->{password} && ($login =~ /^anonymous|ftp$/)) {
        $passwd = $nick->{password};
    }
}

# Command-line options have precedence over configuration files:

($mailto || $mailtx) or p("dupload note: no announcement will be sent.\n");

$noarchive = $opt_noarchive || (!$archive);

#
# Get the changes file names.
#

# Use current dir if no args.
@ARGV or push @ARGV, '.';

foreach my $pathname (@ARGV) {
    stat $pathname;

    if (! -r _) {
        fatal("Cannot read $pathname: $!\n");
    }
    if (-f _) {
        if ($pathname !~ /\.changes$/) {
            w("no .changes extension: $pathname\n");
        }
        unshift @changes, $pathname;
        next;
    }
    if (-d _) {
        my @f = glob "$pathname/*.changes";
        if (@f == 0) {
            w("no changes file in dir $pathname\n");
        }
        unshift @changes, @f;
        next;
    }
}

@changes or fatal("No changes file, so nothing to do.\n");

# Preupload code for changes files.
foreach my $change (@changes) {
    preupload_hook('changes', [ $change ]);
}

p("Uploading ($method) to $fqdn:$incoming");
p("and moving to $fqdn:$queuedir") if $queuedir;
p("\n");

*STDOUT->autoflush();

# Parse the changes files and update some hashes, indexed by the jobname:
#  %job - the files to be uploaded
#  %log - the logfile name
#  %dir - where the files are located
#  %announce -

PACKAGE: foreach my $change (@changes) {
    my $dir = dirname($change);
    my $cf = basename($change);
    my $job = basename($cf, '.changes');
    my ($package, $version, $arch) = (split /_/, $job, 3);
    my ($upstream, $debian) = (split /-/, $version, 2);
    my $log = "$job.upload";

    my (@files, @done, @extra);
    my (%mailto, %fields);

    chdir $dir or fatal("Cannot chdir to $dir: $!\n");

    $dir{$job} = $dir;
    $changes{$job} = $cf;
    $package{$job} = $package;
    $version{$job} = $version;

    # Preupload code for source package.
    preupload_hook('sourcepackage', [ basename($package) . " $version" ]);

    p("[ job $job from $cf");

    # Scan the log file (iff any) for the files we have already put to the
    # host and the announcements already done.
    if (-f $log) {
        open my $fh_log, '<', $log or fatal("Cannot read $log: $!\n");
        while (my $entry = <$fh_log>) {
            chomp $entry;

            if ($entry =~ /^u .*\s(?:${host}|${fqdn})\s/) {
                push @done, $entry;
            } elsif ($entry =~ /^a /) {
                push @done, $entry;
            } elsif ($entry =~ /\s(?:${host}|${fqdn})\s/) {
                push @done, "u $entry";
            }
            next;
        }
        close $fh_log;
    }

    # If the dinstall_runs variable is set, we do not want the announcement
    # emails, because dinstall will attend to that.
    $nomail = 1 if $dinstall_runs;

    # Scan the changes file for architecture, distribution code and the files
    # avoid duplicate mail addressees.
    open my $fh_changes, '<', $cf or fatal("Cannot read $cf: $!\n");
    my ($field);
    while (<$fh_changes>) {
        chomp;
        if (/^changes:\s*/i) {
            $fields{changes}++;
            $field = undef;
            next;
        }
        if (/^architecture:\s+/i) {
            chomp($arch{$job} = "$'");
            $field = undef;
            next;
        }
        if (/^distribution:\s+/i) {
            my $dist = " $'";

            if ($mailto and $dist =~ /\Wstable/i) {
                $mailto{$mailto}++;
            }
            if ($mailtx and $dist =~ /\Wunstable/i) {
                $mailto{$mailtx}++;
            }
            if ($mailtx and $dist =~ /\Wexperimental/i) {
                $mailto{$mailtx}++;
            }
            if ($dist =~ /\WUNRELEASED/) {
                fatal('distribution: UNRELEASED');
            }
            $field = undef;
            next;
        }
        if (/^(files|checksums-(?:sha1|sha256)):\s*$/i) {
            $field = lc $1;
            push @{$fields{$field}}, $' if $';
            next;
        }
        if (/^\s+/ and $field) {
            push @{$fields{$field}}, $' if $';
            next;
        };
        if (/^[\w.-]+:/) {
            $field = undef;
        }
    }
    foreach my $k (keys %mailto) {
        unless ($nomail) {
            p("\n  announce ($cf) to $k");
            if (any { /^a .*\s${k}\s/ } @done) {
                p(' already done');
            } else {
                $announce{$job} = join q{ }, $announce{$job}, $k;
                p(' will be sent');
            }
        }
    }

    # Search for extra announcement files.
    my @announce_names = (
        "${package}",
        "${package}_${upstream}",
        defined $debian ? "${package}_${upstream}-${debian}" : (),
    );
    foreach my $announce_filename (@announce_names) {
        $announce_filename .= '.announce';
        if (-r $announce_filename) {
            push @extra, $announce_filename;
        }
    }
    if (@extra) {
        p(", as well as\n  ", join ', ', @extra);
        $extra{$job} = [ @extra ];
    }

    my %checksums;
    foreach my $alg (qw(sha1 sha256)) {
        foreach (@{$fields{"checksums-$alg"}}) {
            chomp;
            my ($chksum, $size, $file) = split;

            $checksums{$file}{$alg} = $chksum;
            if (exists $checksums{$file}{size}
                and $checksums{$file}{size} != $size) {
                fatal("differing sizes for file $file: $size != $checksums{$file}{size}");
            }
            $checksums{$file}{size} = $size;
        }
    }
    foreach (@{$fields{files}}) {
        chomp;
        my ($chksum, $size, undef, undef, $file) = split;

        $checksums{$file}{md5} = $chksum;
        if (exists $checksums{$file}{size}
            and $checksums{$file}{size} != $size) {
            fatal("differing sizes for file $file: $size != $checksums{$file}{size}");
        }
        $checksums{$file}{size} = $size;
    }
    close $fh_changes;
    unless (%checksums && $fields{changes}) {
        p(": not a changes file ]\n");
        next PACKAGE;
    }

    # Test the md5sums.
    foreach my $file (keys %checksums) {
        p("\n $file");
        if ($checksums{$file}{size} != -s $file) {
            $keep or fatal("Size mismatch for $file\n");
            w("Size mismatch for $file, skipping $job\n");
            push @skipped, $cf;
            next PACKAGE;
        }
        p(', size ok');

        foreach my $alg (qw(md5 sha1 sha256)) {
            next unless $checksums{$file}{$alg};

            my $checksum;
            if (-r $file) {
                my $output = qx(${alg}sum $file);
                $checksum = (split q{ }, $output)[0];
            } else {
                print ": $!";
                $checksum = q{};
            }

            if ($checksums{$file}{$alg} ne $checksum) {
                $keep or fatal(uc $alg . "sum mismatch for $file\n");
                w(uc $alg . "sum mismatch for $file, skipping $job\n");
                push @skipped, $cf;
                next PACKAGE;
            }
            p(", ${alg}sum ok");
        }
        if (!$force && @done && any { /^u \Q${file}\E/ } @done) {
            p(", already done for $host");
        } else {
            push @files, $file;
        }
        next;
    }

    # The changes file itself.
    p("\n $cf ok");
    if (!$force && @done && any { /^u \Q${cf}\E/ } @done) {
        p(", already done for $host");
    } else {
        push @files, $cf;
    }

    if (@files) {
        $log{$job} = $log;
        $files{$job} = [ @files ];
    } else {
        $log{$job} = $log;
        announce_if_necessary($job);

        if (!$dry) {
            log_job($log{$job}, "s $changes{$job} $fqdn");
        } else {
            p("\n+ log successful upload\n");
        }
    }
    p(" ]\n");

    # Preupload code for all files and for '.deb'.
    foreach my $file (@files) {
        push @all_the_files, $file;

        preupload_hook('file', [ $file ]);

        if ($file =~ /\.deb$/) {
            push @all_the_debs, $file;
            my ($binary_package, $version, $garbage) = split /_/, $file;

            $binary_package = basename($binary_package);
            $all_packages{$binary_package} = $version;

            preupload_hook('package', [ $binary_package, $version ]);
            preupload_hook('deb', [ $file ]);
        }
    }
} continue {
    chdir $cwd or fatal("Cannot chdir back to $cwd\n");
}

chdir $cwd or fatal("Cannot chdir to $cwd: $!\n");

if (@skipped) {
    w("skipped: @skipped\n");
}
if (not %files) {
    p("Nothing to upload\n");
    exit 0;
}

if ($method eq 'ftp') {
    if (!$dry) {
        $passwd = getpass() unless defined $passwd;
    } else {
        p("+ getpass()\n");
    }
    p("Uploading (ftp) to $host ($fqdn)\n");
    if (!$dry) {
        ftp_open($fqdn, $login, $passwd);
        $ftp->cwd($incoming);
    } else {
        p("+ ftp_open($fqdn, $login, $passwd)\n");
        p("+ ftp::cwd($incoming\n");
    }
} elsif ($method eq 'scp' || $method eq 'scpb') {
    p("Uploading (scp) to $host ($fqdn)\n");
} elsif ($method eq 'rsync') {
    p("Uploading (rsync) to $host ($fqdn)\n");
} elsif ($method eq 'copy') {
    p("Uploading (copy) to $host ($fqdn)\n");
} else {
    fatal("Unknown upload method\n");
}

JOB: foreach my $job (keys %files) {
    my @files = @{$files{$job}};
    my $mode;
    my $batchmode;
    my $allfiles;
    $copiedfiles = qw{};

    my ($package, $version, $arch) = (split /_/, $job, 3);
    my ($upstream, $debian) = (split /-/, $version, 2);

    $incoming =~ s/_package_/$package/g;
    $incoming =~ s/_version_/$version/g;
    $incoming =~ s/_arch_/$arch/g;
    $incoming =~ s/_upstream_/$upstream/g;
    $incoming =~ s/_debian_/$debian/g;

    chdir $cwd or fatal("Cannot chdir to $cwd: $!\n");
    chdir $dir{$job} or fatal("Cannot chdir to $dir{$job}: $!\n");

    p("[ Uploading job $job");
    if (@files == 0) {
        p("\n nothing to do ]");
        next;
    }

    # For scpb only. A priori, the mode is right for every file.
    my $wrong_mode = 0;

    foreach my $file (@files) {
        my $size = -s $file;
        my $t;

        p(sprintf "\n $file %0.1f kB", $size / 1024);
        $t = time;

        if ($method eq 'ftp') {
            unless ($dry) {
                unless ($ftp->put($file, $file)) {
                    $result = $ftp->message();
                    $ftp->delete($file);
                    fatal("Cannot upload $file: $result");
                }
                $t = time - $t;
            } else {
                p("\n+ ftp::put($file)");
                $t = 1;
            }
        } elsif ($method eq 'scp') {
            $mode = (stat $file)[2] & 07777;
            unless ($dry) {
                system "scp -p -q $options $file $login\@$fqdn:$incoming";
                fatal("scp $file failed\n") if $?;
                $t = time - $t;
                # Small optimization.
                if ($dochmode && $mode != $filemode) {
                    system "ssh -x -l $login $fqdn chmod $filemode $incoming/$file";
                    fatal("ssh ... chmod $filemode failed\n") if $?;
                }
            } else {
                p("\n+ scp -p -q $options $file $login\@$fqdn:$incoming");
                if ($dochmode && $mode != $filemode) {
                    p("\n+ ssh -x -l $login $fqdn chmod $filemode $incoming/$file");
                }
                $t = 1;
            }
        } elsif ($method eq 'scpb') {
            $copiedfiles .= "$file ";
            $mode = (stat $file)[2] & 07777;
            # Small optimization.
            if ($dochmode && $mode != $filemode) {
                $wrong_mode = 1;
            }
            $t = 1;
            $batchmode = 1;
        } elsif ($method eq 'rsync') {
            $copiedfiles .= "$file ";
            $mode = (stat $file)[2] & 07777;
            # Small optimization.
            if ($dochmode && $mode != $filemode) {
                $wrong_mode = 1;
            }
            $t = 1;
            $batchmode = 1;
        } elsif ($method eq 'copy') {
            $mode = (stat $file)[2] & 07777;

            unless ($dry) {
                copy($file, $incoming)
                    or fatal("Cannot copy $file to $incoming: $!\n");
                $t = time - $t;
                # Small optimization.
                if ($dochmode && $mode != $filemode) {
                    chmod $filemode, "$incoming/$file"
                        or fatal("Cannot chmod $filemode $incoming/$file: $!\n");
                }
            } else {
                p("\n+ copy $file $incoming");
                if ($dochmode && $mode != $filemode) {
                    p("\n+ chmod $filemode $incoming/$file");
                }
                $t = 1;
            }
        }

        if ($queuedir) {
            p(', renaming');
            if ($method eq 'ftp') {
                unless ($dry) {
                    if (!$ftp->rename($file, "$queuedir/$file")) {
                        $result = $ftp->message();
                        $ftp->delete($file);
                        fatal("Cannot rename $file -> $queuedir/$file\n");
                    }
                } else {
                    p("\n+ ftp::rename($file, $queuedir/$file)");
                }
            } elsif ($method eq 'scp') {
                unless ($dry) {
                    system "ssh -x -l $login $fqdn \"mv $incoming/$file $queuedir/$file\"";
                    fatal("ssh -x -l $login $fqdn: mv failed\n") if $?;
                } else {
                    p("\n+ ssh -x -l $login $fqdn \"mv $incoming/$file $queuedir/$file\"");
                }
            } elsif ($method eq 'copy') {
                unless ($dry) {
                    move("$incoming/$file", "$queuedir/$file")
                        or fatal("Cannot move $file from $incoming to $queuedir: $!\n");
                } else {
                    p("\n+ move $incoming/$file $queuedir/$file");
                }
            }
        }

        p(', ok');

        unless ($batchmode) {
            # The batch methods do not produce the $t statistic.
            p(sprintf " (${t} s, %.2f kB/s)", $size / 1024 / ($t || 1));

            unless ($dry) {
                log_job($log{$job}, "u $file $fqdn");
            } else {
                p("\n+ log to $log{$job}\n");
            }
        }
    }

    # And now the batch mode uploads.
    my $subcmd;

    if ($method eq 'scpb') {
        $subcmd .= "chmod $filemode $copiedfiles;" if $wrong_mode;

        unless ($dry) {
            p("\n");
            system "scp $options $copiedfiles $login\@$fqdn:$incoming";
            if ($?) {
                unlink $log{$job};
                fatal("scp $copiedfiles failed\n");
            }
        } else {
            p("\n+ scp $options $copiedfiles $login\@$fqdn:$incoming");
        }
        $allfiles = $copiedfiles;
    } elsif ($method eq 'rsync') {
        my $rsync_opts = $options;
        $rsync_opts .= " --chmod=F$filemode" if $wrong_mode;

        unless ($dry) {
            p("\n");
            system "rsync --partial -Ltzve ssh $rsync_opts -x $copiedfiles $login" . "@" . "$fqdn:$incoming";
            if ($?) {
                unlink $log{$job};
                fatal("rsync $copiedfiles failed\n");
            }
        } else {
            p("\n+ rsync --partial -Ltzve ssh $rsync_opts -x $copiedfiles $login" . "@" . "$fqdn:$incoming");
        }
        $allfiles = $copiedfiles;
    }

    if ($batchmode) {
        if (defined $queuedir and length $queuedir > 0) {
            $subcmd .= "mv $copiedfiles $queuedir;";
        }
        if (defined $subcmd) {
            my $cmd = "ssh -x -l $login $fqdn 'cd $incoming;$subcmd'";

            unless ($dry) {
                system $cmd;
                fatal("$cmd failed\n") if $?;
            } else {
                p("\n+ $cmd");
            }
        }

        unless ($dry) {
            log_job($log{$job}, map { "u $_ $fqdn" } split / /, $allfiles);
        } else {
            p("\n+ log to $log{$job}\n");
        }
        $batchmode = 0;
    }

    announce_if_necessary($job);
    unless ($dry) {
        log_job($log{$job}, "s $changes{$job} $fqdn");
    } else {
        p("\n+ log successful upload\n");
    }
    p(" ]\n");
}

if ($method eq 'ftp') {
    unless ($dry) {
        $ftp->close();
    } else {
        p("\n+ ftp::close\n");
    }
}

# Postupload code for changes files.
unless ($dry) {
    foreach my $change (@changes) {
        postupload_hook('changes', [ $change ]);

        my ($package, $version, $arch) = (split /_/, $change, 3);
        postupload_hook('sourcepackage', [ basename($package), $version ]);
    }

    foreach my $file (@all_the_files) {
        postupload_hook('file', [ $file ]);
    }

    foreach my $file (@all_the_debs) {
        postupload_hook('deb', [ $file ]);
    }

    foreach my $package (keys %all_packages) {
        postupload_hook('package', [ $package, $all_packages{$package} ]);
    }
}

@skipped and w("skipped: @skipped\n");

exit 0;

### SUBS

# Prepare and possibly send the mail announcement.
sub announce_if_necessary($)
{
    my ($job) = @_;
    my ($opt_fullname) = " -F '($fullname)'";
    my ($msg);

    return if not $announce{$job} or $nomail;

    $opt_fullname = " -F '$fullname'" if $config::no_parentheses_to_fullname;
    $fullname =~ s/\'/''/;
    my $sendmail_cmd = "$sendmail -f $visibleuser" .
                       ($visiblename ? "\@$visiblename" : q{}) .
                       ($fullname ? $opt_fullname : q{}) .
                       " $announce{$job}";

    $msg = "announcing to $announce{$job}";
    if ($cc) {
        $sendmail_cmd .= q{ } . $cc;
        $msg .= " and $cc";
    }
    p($msg . "\n");

    my $fh_mail;
    if (not $dry or $mailonly) {
        open $fh_mail, '|', $sendmail_cmd or fatal("Cannot pipe to $sendmail $!\n");
    } else {
        p("\n+ announce to $announce{$job} using command '$sendmail_cmd'\n");
        open $fh_mail, '>&', *STDOUT or fatal("Cannot redirect to stdout\n");
    }

    print { $fh_mail } <<"MAIL";
X-dupload: $version
To: $announce{$job}
MAIL
    $cc and print { $fh_mail } <<"MAIL";
Cc: $cc
MAIL
    $noarchive and print { $fh_mail } <<'MAIL';
X-No-Archive: yes
MAIL

    print { $fh_mail } <<"MAIL";
Subject: Uploaded $package{$job} $version{$job} ($arch{$job}) to $host

MAIL
    foreach my $announce (@{$extra{$job}}) {
        my $line;

        my $fh_announce;
        if (not open $fh_announce, '<', $announce) {
            w("Cannot open extra announce $announce: $!\n");
            next;
        }
        p " ($announce";
        while ($line = <$fh_announce>) {
            print { $fh_mail } $line;
        }
        close $fh_announce;
        p(' ok)');
    }

    open my $fh_changes, '<', $changes{$job} or fatal("Cannot open $changes{$job} $!\n");
    while (<$fh_changes>) {
        print $fh_mail;
    }
    close $fh_changes;

    close $fh_mail;
    if ($?) {
        p(', failed');
    } else {
        p(', ok');
    }

    if (!$dry) {
        log_job($log{$job}, "a $changes{$job} $announce{$job}");
    } else {
        p("\n+ log announcement\n");
    }

    return;
}

# Open the FTP connection.
sub ftp_open($$$)
{
    my ($remote, $user, $pass) = @_;
    my ($ftp_port, $retry_call, $attempts) = (21, 1, 1);
    my ($request_passive) = 0;

    if ($user =~ /@/ or $passive) {
        $request_passive = 1;
        p("+ FTP passive mode selected\n");
    }

    # It may seems complicated, but it is to be sure that the environment
    # variable FTP_PASSIVE works (which needs no Passive argument).
    if ($request_passive) {
        $ftp = Net::FTP->new("$fqdn", Passive => $request_passive);
    } else {
        $ftp = Net::FTP->new("$fqdn");
    }
    if (!$ftp) {
        fatal($@);
    }
    $ftp->debug($debug);

    $ftp->login($user, $pass)
        or fatal("Login as $user failed\n");
    $ftp->type('I')
        or fatal("Cannot set binary type\n");

    return;
}

# Display known host information.
sub info($)
{
    my ($host) = @_;

    foreach my $nick ($host || keys %config::cfg) {
        my $r = $config::cfg{$nick};
        print <<"INFO";
nick name     : $nick
real name     : $r->{fqdn}
login         : $r->{login}
incoming      : $r->{incoming}
queuedir      : $r->{queuedir}
mail to       : $r->{mailto}
mail to x     : $r->{mailtx}
cc            : $r->{cc}
passive FTP   : $r->{passive}
dinstall runs : $r->{dinstall_runs}
archive mail  : $r->{archive}

INFO
    }

    return;
}

# Read the dupload configuration files.
sub configure(@)
{
    my @conffiles = @_;

    my @read = ();
    foreach my $file (@conffiles) {
        stat $file;

        -r _ or next;
        -s _ or next;
        do $file or fatal("$@\n");
        push @read, $file;
    }
    @read or fatal("No configuration files\n");

    return;
}

# Prompt for the FTP password.
sub getpass()
{
    system 'stty -echo cbreak </dev/tty';
    $? and fatal('stty');
    print "\a${login}\@${fqdn}'s ftp account password: ";
    my $pass = <STDIN>;
    chomp $pass;
    print "\n";
    system 'stty echo -cbreak </dev/tty';
    $? and fatal('stty');
    return $pass;
}

{

my $nl;

# Print to STDOUT if !$quiet.
sub p(@)
{
    return if $quiet;
    $nl = $_[-1] =~ /\n$/;
    print { *STDOUT } @_;
    return;
}

# Warn to STDOUT if !$quiet, or to STDERR if $quiet.
sub w(@)
{
    if ($quiet) {
        print { *STDERR } "$progname: warning: ", @_;
    } else {
        $nl = $_[-1] =~ /\n$/;
        unshift @_, "$progname: warning: ";
        unshift @_, "\n" if !$nl;
        print { *STDOUT } @_;
    }
    return;
}

}

# Log events for a job, by appending the localtime and a new line to each
# passed line to log.
sub log_job
{
    my ($logfile, @logdata) = @_;

    my $fh;
    if (not open $fh, '>>', $logfile) {
        w("cannot open logfile $logfile: $!\n");
        return;
    }
    foreach my $line (@logdata) {
        print { $fh } $line . q{ } . localtime . "\n";
    }
    close $fh;

    return;
}

# Emit a fatal error and die.
sub fatal(@)
{
    my ($pack, $file, $line) = caller;

    print { *STDERR } "\n";
    die "$progname: error: @_ at $file line $line\n";
}

sub run($$)
{
    my ($command, $args) = @_;
    my (@args) = @{$args};
    my ($result);

    foreach my $i (1 .. @args) {
        $args[$i - 1] =~ s{/}{\\/}g;

        # Substitute %1 by the first argument, etc.
        $command =~ s/\%$i/$args[$i - 1]/g;
    }
    system "$command";
    $result = $? >> 8;
    return !$result;
}

sub preupload_hook
{
    my ($name, $args) = @_;

    return unless $preupload{$name};

    if (not run($preupload{$name}, $args)) {
        fatal("Pre-upload \'$preupload{$name}\' failed for @{$args}\n  ");
    }

    return;
}

sub postupload_hook
{
    my ($name, $args) = @_;

    return unless $postupload{$name};

    if (not run($postupload{$name}, $args)) {
        fatal("Post-upload \'$postupload{$name}\' failed for @{$args}\n  ");
    }

    return;
}

# vim:set sts=4 sw=4 et: