API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Feb 9th, 2016
125
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Perl 26.33 KB | None | 0 0
raw download clone embed print report
  1. massaraksh@newborn ~ $ cat /usr/bin/dupload
  2. #! /usr/bin/perl
  3. #
  4. # dupload - utility to upload Debian packages
  5. #
  6. # Copyright (C) 1996, 1997 Heiko Schlittermann
  7. # Copyright (C) 1999 Stephane Bortzmeyer
  8. # Licensed under the GNU GPL v2.
  9. #
  10. # see dupload(1) for help.
  11.  
  12. #BEGIN {
  13. #   $ENV{PERL_INC} # for my tests only
  14. #       and unshift @INC, $ENV{PERL_INC};
  15. #   unshift @INC, "";
  16. #}
  17.  
  18. use strict;
  19. use 5.003; # Because of the prototypes
  20. use Cwd;
  21. use Getopt::Long;
  22. use File::Basename;
  23. use Net::FTP;
  24. use English;
  25.  
  26. # more or less configurable constants
  27. my $version = "2.6";
  28. my $progname = basename($0);
  29. my $user = getlogin() || $ENV{LOGNAME} || $ENV{USER};
  30. my $myhost = `hostname --fqdn`; chomp $myhost;
  31. my $cwd = cwd();
  32.  
  33. my $debug = 0;  # for somewhat more verbose output from the ftp module
  34. my $force = 0;  # do it, even when already done
  35. my $keep = 0;   # keep going, even if checksum errors
  36. my $quiet = 0;  # don't talk too much
  37. my $configfile = 0; # By default, we do NOT read ./dupload.conf, for
  38.             # security resons
  39.  
  40. my $host = undef;               # target host
  41. my $method = "ftp";             # transfer method
  42. my $login = "anonymous";        # default login
  43. my $passwd = "$user\@$myhost";  # ...
  44. my $options = "";   # extra options for rsync or scp
  45.  
  46. my $sendmail = "/usr/sbin/sendmail";
  47.  
  48. # global Variables
  49. my (@changes,   # the files we'll have to read from
  50.     @skipped,   # the packages we skipped
  51.     @all_the_files,     # ... we installed (for postupload processing)
  52.     @all_the_debs,      # ... we installed (for postupload processing)
  53.     %all_packages,      # All Debian binary packages we installed
  54.                         # (for postupload processing)
  55.     $copiedfiles,
  56.     $dry,       # if do-nothing
  57.     $mailonly,
  58.     $fqdn,      # per host
  59.     $server,
  60.     $dinstall_runs,
  61.     $nonus,
  62.     $passive,
  63.     $nomail, $archive, $noarchive,
  64.     %preupload, %postupload,
  65.     $result,
  66.     $incoming, $queuedir,   # ...
  67.     $mailto, $mailtx, $cc,  # ...
  68.     $visiblename, $visibleuser,
  69.     $fullname,
  70.     %files, %package, %version, %arch,  # per job
  71.     %dir, %changes, %log, %announce,    # ...
  72.     %extra,
  73.     $suspicious_but_proceed,
  74. );
  75.  
  76. ### Prototypes
  77. sub configure(@);   # reads the config file(s)
  78. sub ftp_open($$$);  # establishs the ftp connection
  79. sub info($);        # print the available info (for a given host)
  80. sub fatal(@);       # bail out
  81. sub getpass();      # read password
  82. sub w(@);       # warn (to STDERR if quiet, to STDOUT else)
  83. sub p(@);       # print (suppress if quiet, to STDOUT else)
  84. sub announce_if_necessary($);
  85. sub run ($$);      # Runs an external program and return its exit status
  86.  
  87. # some tests on constants
  88. $user or fatal("Who am I? (can't get user identity)\n");
  89. $myhost or fatal("Who am I? (can't get hostname)\n");
  90. $cwd or fatal("Where am I? (can't get current directory)\n");
  91.  
  92. unless (-x $sendmail) {
  93.   $nomail = 1;
  94.   w "mail options disabled, can't run `$sendmail': $!\n";
  95. }
  96.  
  97. ### Main
  98. configure(
  99.     "/etc/dupload.conf",
  100.     $ENV{HOME} && "$ENV{HOME}/.dupload.conf");
  101.  
  102. $Getopt::Long::ignorecase = 0;
  103. GetOptions qw(
  104.     debug:i
  105.     help
  106.     force keep configfile no nomail noarchive
  107.     mailonly
  108.     to=s print
  109.        quiet Version version
  110. ) or fatal("Bad Options\n");
  111.  
  112. $configfile = $::opt_configfile || $configfile;
  113. configure("./dupload.conf") if $configfile;
  114.  
  115. $dry = defined($::opt_no);
  116. $mailonly = defined($::opt_mailonly);
  117. if ($mailonly) {
  118.     $dry = 1;
  119. }
  120. $debug = $::opt_debug || $debug;
  121. $keep = $::opt_keep || $keep;
  122. $host = $::opt_to || $config::default_host;
  123. $force = $::opt_force || $force;
  124. $nomail = $::opt_nomail || 0;
  125. $quiet = $::opt_quiet;
  126.  
  127. # only info or version?
  128. info($host), exit 0 if $::opt_print;
  129. p("$progname version: $version\n"), exit 0 if
  130.     ($::opt_Version or $::opt_version);
  131.  
  132. if ($::opt_help) {
  133.     p ("Usage: $progname --to HOST FILE.changes ...\n" .
  134.        "\tUploads the files listed in the above '.changes' to the\n".
  135.        "\thost HOST.\n" .
  136.        "\tSee dupload(1) for details.\n");
  137.     exit 0;
  138. }
  139.  
  140. # get the configuration for that host
  141. # global, job independent information
  142.  
  143. $host or fatal("Need host to upload to.  (See --to option or the default_host configuration variable)\n");
  144.  
  145. {
  146.   my $nick = $config::cfg{$host};
  147.   $method = $nick->{method} || $method;
  148.   $options = $nick->{options} || $options;
  149.   $fqdn = $nick->{fqdn} or fatal("Nothing known about host $host\n");
  150.   $incoming = $nick->{incoming} or fatal("No Incoming dir\n");
  151.   $queuedir = $nick->{queuedir};
  152.   $mailto = $nick->{mailto};
  153.   $mailtx = $nick->{mailtx} || $mailto;
  154.   $cc = $nick->{cc};
  155.   $dinstall_runs = $nick->{dinstall_runs};
  156.   $nonus = $nick->{nonus};
  157.   $passive = $nick->{passive};
  158.   if ($passive and ($method ne "ftp")) {
  159.       fatal ("Passive mode is only for FTP ($host)");
  160.   }
  161.   if (defined ($nick->{archive})) {
  162.       $archive = $nick->{archive};
  163.   }
  164.   else {
  165.       $archive = 1;
  166.   }
  167.   foreach my $category (qw/changes sourcepackage package file deb/) {
  168.       if (defined ($nick->{preupload}{$category})) {
  169.       $preupload{$category} = $nick->{preupload}{$category};
  170.       }
  171.       else {
  172.       $preupload{$category} = $config::preupload{$category};
  173.       }
  174.       if (defined ($nick->{postupload}{$category})) {
  175.           $postupload{$category} = $nick->{postupload}{$category};
  176.       }
  177.       else {
  178.           $postupload{$category} = $config::postupload{$category};
  179.       }
  180.   }
  181.  
  182.   $login = $nick->{login} || $login if $method eq "ftp";
  183.   $login = $nick->{login} || $user if ($method eq "scp" || $method eq "scpb" || $method eq "rsync");
  184.   $visibleuser = $nick->{visibleuser} || $user; chomp($visibleuser);
  185.   $visiblename = $nick->{visiblename} || ''; chomp($visiblename);
  186.   $fullname = $nick->{fullname} || '';
  187.   # Do not accept passwords in configuration file,
  188.   # except for anonymous logins.
  189.   undef $passwd unless $login =~ /^anonymous|ftp$/;
  190.   if ($nick->{password} && ($login =~ /^anonymous|ftp$/)) {
  191.       $passwd = $nick->{password};
  192.   }
  193. }
  194.  
  195. # Command-line options have precedence over configuration files:
  196.  
  197. ($mailto || $mailtx) or p "dupload note: no announcement will be sent.\n";
  198.  
  199. $noarchive = $::opt_noarchive || (! $archive);
  200.  
  201. # get the changes file names
  202. @ARGV or push @ARGV, ".";   # use currend dir if no args
  203. foreach (@ARGV) {
  204.     my @f = undef;
  205.     -r $_ or fatal("Can't read $_: $!\n");
  206.     -f _ and do {
  207.         /\.changes$/ or w("no .changes extension: $_\n");
  208.         unshift(@changes, $_);
  209.         next;
  210.     };
  211.     -d _ and do {
  212.         @f = <$_/*.changes> or w("no changes file in dir $_\n");
  213.         unshift @changes, @f;
  214.         next;
  215.     };
  216. }
  217.  
  218. @changes or die("No changes file, so nothing to do.\n");
  219.  
  220. # preupload code for changes files
  221. foreach my $change (@changes) {
  222.     if ($preupload{'changes'}) {
  223.         my ($result) = run $preupload{'changes'}, [$change];
  224.         if (! $result) {
  225.             fatal "Pre-upload \'$preupload{'changes'}\' failed for $change\n  ";
  226.         }
  227.     }
  228. }
  229.  
  230. p("Uploading ($method) to $fqdn:$incoming");
  231. p("and moving to $fqdn:$queuedir") if $queuedir;
  232. p("\n");
  233.  
  234. select((select(STDOUT), $| = 1)[0]);
  235.  
  236. # parse the changes files and update some
  237. # hashs, indexed by the jobname:
  238. #  %job - the files to be uploaded
  239. #  %log - the logfile name
  240. #  %dir - where the files are located
  241. #  %announce -
  242.  
  243. PACKAGE: foreach my $change (@changes) {
  244.     my $dir = dirname($change);
  245.     my $cf = basename($change);
  246.     my $job = basename($cf, ".changes");
  247.     my ($package, $version, $arch) = (split("_", $job, 3));
  248.     my ($upstream, $debian) = (split("-", $version, 2));
  249.     my $log = "$job.upload";
  250.  
  251.     my %md5;
  252.     my (@files, @done, @extra);
  253.     my (%mailto, %fields);
  254.  
  255.     chdir $dir or fatal("Can't chdir to $dir: $!\n");
  256.  
  257.     $dir{$job} = $dir;
  258.     $changes{$job} = $cf;
  259.     $package{$job} = $package;
  260.     $version{$job} = $version;
  261.  
  262.     # preupload code for source package
  263.     if ($preupload{'sourcepackage'}) {
  264.         my ($result) = run $preupload{'sourcepackage'},
  265.                    [basename($package) . " $version"];
  266.         if (! $result) {
  267.         fatal "Pre-upload \'$preupload{'sourcepackage'}\' " .
  268.             "failed for " . basename($package) . " $version\n  ";
  269.         }
  270.     }
  271.  
  272.     p "[ job $job from $cf";
  273.  
  274.     # scan the log file (iff any) for
  275.     # the files we've already put to the host
  276.     # and the announcements already done
  277.     if (-f $log) {
  278.         open(L, "<$log") or fatal("Can't read $log: $!\n");
  279.         while (<L>) {
  280.             chomp;
  281.             if (/^. /) {
  282.                 /^u .*\s(${host}|${fqdn})\s/ and push(@done, $_),  next;
  283.                 /^a / and push(@done, $_), next;
  284.             } else {
  285.                 /\s(${host}|${fqdn})\s/ and push @done, "u $_";
  286.             }
  287.             next;
  288.         }
  289.         close(L);
  290.     }
  291.  
  292.     # if the dinstall_runs variable is set, we don't want the
  293.     # announcement emails, because dinstall will attend to that.
  294.     if ($dinstall_runs) {
  295.         $nomail = 1;
  296.     }
  297.  
  298.     # scan the changes file for architecture,
  299.     # distribution code and the files
  300.     # avoid duplicate mail addressees
  301.     open(C, "<$cf") or fatal("Can't read $cf: $!\n");
  302.     my ($field);
  303.     while (<C>) {
  304.         chomp;
  305.         /^changes:\s*/i and do {
  306.             $fields{changes}++;
  307.             $field = undef;
  308.             next;
  309.         };
  310.         /^architecture:\s+/i and do {
  311.             chomp($arch{$job} = "$'");
  312.             $field = undef;
  313.             next;
  314.         };
  315.         /^distribution:\s+/i and do { $_ = " $'";
  316.             /\Wstable/i and $mailto{$mailto}++;
  317.             /\Wunstable/i and $mailto{$mailtx}++;
  318.             /\Wexperimental/i and $mailto{$mailtx}++;
  319.             /\WUNRELEASED/ and fatal "distribution: UNRELEASED";
  320.             $field = undef;
  321.             next;
  322.         };
  323.         /^(files|checksums-(?:sha1|sha256)):\s*$/i and do {
  324.             $field = lc $1;
  325.             push @{$fields{$field}}, $' if $';
  326.             next;
  327.         };
  328.         /^\s+/ and $field and do {
  329.             push @{$fields{$field}}, $' if $';
  330.             next;
  331.         };
  332.         /^[\w.-]+:/ and do {
  333.             $field = undef;
  334.         };
  335.     }
  336.     foreach (keys %mailto) {
  337.         my $k = $_;  
  338.         unless ($nomail) {
  339.             p "\n  announce ($cf) to $k";
  340.             if (grep(/^a .*\s${k}\s/, @done)) {
  341.                 p " already done";
  342.             } else {
  343.                 $announce{$job} = join(" ", $announce{$job}, $_);
  344.                 p " will be sent";
  345.             }
  346.         }
  347.     }
  348.  
  349.     # search for extra announcement files
  350.     foreach ("${package}",
  351.             "${package}_${upstream}",
  352.             "${package}_${upstream}-${debian}") {
  353.         $_ .= ".announce";
  354.         -r $_ and push @extra, $_;
  355.     }
  356.     if (@extra) {
  357.         p ", as well as\n  ", join(", ", @extra);
  358.         $extra{$job} = [@extra];
  359.     }
  360.  
  361.     my %checksums;
  362.     foreach my $alg (qw(sha1 sha256)) {
  363.         foreach (@{$fields{"checksums-$alg"}}) {
  364.         chomp;
  365.         my ($chksum, $size, $file) = split;
  366.         $checksums{$file}{$alg} = $chksum;
  367.         if (exists $checksums{$file}{size}
  368.             and $checksums{$file}{size} != $size) {
  369.             fatal "differing sizes for file $file: $size != $checksums{$file}{size}";
  370.         }
  371.         $checksums{$file}{size} = $size;
  372.         }
  373.     }
  374.     foreach (@{$fields{files}}) {
  375.         chomp;
  376.         my ($chksum, $size, undef, undef, $file) = split;
  377.         $checksums{$file}{md5} = $chksum;
  378.         if (exists $checksums{$file}{size}
  379.         and $checksums{$file}{size} != $size) {
  380.         fatal "differing sizes for file $file: $size != $checksums{$file}{size}";
  381.         }
  382.         $checksums{$file}{size} = $size;
  383.     }
  384.     close(C);
  385.     %checksums && $fields{changes} or p(": not a changes file ]\n"), next PACKAGE;
  386.  
  387.     # test the md5sums
  388.     foreach my $file (keys %checksums) {
  389.         p "\n $file";
  390.         if ($checksums{$file}{size} != -s $file) {
  391.         $keep or fatal("Size mismatch for $file\n");
  392.         w("Size mismatch for $file, skipping $job\n");
  393.         push @skipped, $cf;
  394.         next PACKAGE;
  395.         }
  396.         p ", size ok";
  397.  
  398.         foreach my $alg (qw(md5 sha1 sha256)) {
  399.         next unless $checksums{$file}{$alg};
  400.  
  401.         if (-r $file) {
  402.             $_ = `${alg}sum $file`;
  403.             $_ = (split)[0];
  404.         } else {
  405.             print ": $!";
  406.             $_ = "";
  407.         }
  408.  
  409.         $checksums{$file}{$alg} eq $_ or do {
  410.             $keep or fatal(uc($alg)."sum mismatch for $file\n");
  411.             w(uc($alg)."sum mismatch for $file, skipping $job\n");
  412.             push @skipped, $cf;
  413.             next PACKAGE;
  414.         };
  415.         p ", ${alg}sum ok";
  416.         }
  417.         if (!$force && @done && grep(/^u \Q${file}\E/, @done)) {
  418.         p ", already done for $host";
  419.         } else {
  420.         push @files, $file;
  421.         }
  422.         next;
  423.     }
  424.  
  425.     # The changes file itself
  426.     p "\n $cf ok";
  427.     if (!$force && @done && grep(/^u \Q${cf}\E/, @done)) {
  428.         p ", already done for $host";
  429.     } else { push @files, $cf; }
  430.  
  431.     if (@files) {
  432.         $log{$job} = $log;
  433.         $files{$job} = [ @files ];
  434.         } else {
  435.         $log{$job} = $log;
  436.         announce_if_necessary($job);
  437.         if (!$dry) {
  438.         open(L, ">>$log{$job}")
  439.             or w("can't open logfile $log{$job}: $!\n");
  440.         print L "s $changes{$job} $fqdn " . localtime() . "\n";
  441.         close(L);
  442.         } else {
  443.         p "\n+ log successful upload\n";
  444.         }
  445.     }
  446.     p " ]\n";
  447.  
  448.     # preupload code for all files and for '.deb'
  449.     foreach my $file (@files) {
  450.         push @all_the_files, $file;
  451.         if ($preupload{'file'}) {
  452.             my ($result) = run $preupload{'file'}, [$file];
  453.             if (! $result) {
  454.                 fatal "Pre-upload \'$preupload{'file'}\' " .
  455.                       "failed for $file\n  ";
  456.             }
  457.         }
  458.         if ($file =~ /\.deb$/) {
  459.             # non-US sanity check
  460.             if ((`dpkg -I $file | grep '^ Section:'` =~ /non-US/i) &&
  461.                 ($fqdn !~ /(non-us|security).debian.org/i) && !$nonus) {
  462.                 if (!defined($suspicious_but_proceed) &&
  463.                                     $suspicious_but_proceed !~ /^y/i) {
  464.                     print "Looks like you're uploading non-US packages to a normal upload queue.\n";
  465.                     print "Are you sure you want to proceed? ";
  466.                     $suspicious_but_proceed = <STDIN>;
  467.                     die "Aborting upload.\n" unless $suspicious_but_proceed =~ /^y/i;
  468.                 }
  469.             }
  470.             push @all_the_debs, $file;
  471.             my ($binary_package, $version, $garbage) = split ('_', $file);
  472.             $binary_package = basename($binary_package);
  473.             $all_packages{$binary_package} = $version;
  474.             if ($preupload{'package'}) {
  475.                 my ($result) = run $preupload{'package'},
  476.                                    [$binary_package, $version];
  477.                 if (! $result) {
  478.                     fatal "Pre-upload \'$preupload{'dpackage'}\' " .
  479.                           "failed for $binary_package $version\n  ";
  480.                 }
  481.             }
  482.             if ($preupload{'deb'}) {
  483.                 my ($result) = run $preupload{'deb'}, [$file];
  484.                 if (! $result) {
  485.                     fatal "Pre-upload \'$preupload{'deb'}\' " .
  486.                           "failed for $file\n  ";
  487.                 }
  488.             }
  489.         }
  490.     }
  491.  
  492. } continue {
  493.     chdir $cwd or fatal("Can't chdir back to $cwd\n");
  494. }
  495.  
  496. chdir $cwd or fatal("Can't chdir to $cwd: $!\n");
  497.  
  498. @skipped and w("skipped: @skipped\n");
  499. %files or (p("Nothing to upload\n"), exit(0));
  500.  
  501. if ($method eq "ftp") {
  502.     if (!$dry) {
  503.         $passwd = getpass() unless defined $passwd;
  504.     } else {
  505.         p "+ getpass()\n";
  506.     }
  507.     p "Uploading (ftp) to $host ($fqdn)\n";
  508.     if (!$dry) {
  509.         ftp_open($fqdn, $login, $passwd);
  510.         $server->cwd($incoming);
  511.     } else {
  512.         p "+ ftp_open($fqdn, $login, $passwd)\n";
  513.         p "+ ftp::cwd($incoming\n";
  514.     }
  515. } elsif ($method eq "scp" || $method eq "scpb") {
  516.     p "Uploading (scp) to $host ($fqdn)\n";
  517. } elsif ($method eq "rsync") {
  518.     p "Uploading (rsync) to $host ($fqdn)\n";
  519. } else {
  520.     fatal("Unknown upload method\n");
  521. }
  522.  
  523. JOB: foreach (keys %files) {
  524.     my $job = $_;
  525.     my @files = @{$files{$job}};
  526.     my $mode;
  527.     my $batchmode;
  528.     my $allfiles;
  529.     $copiedfiles = "";
  530.  
  531.     my ($package, $version, $arch) = (split("_", $job, 3));
  532.     my ($upstream, $debian) = (split("-", $version, 2));
  533.  
  534.     $incoming =~ s/_package_/$package/g;
  535.     $incoming =~ s/_version_/$version/g;
  536.     $incoming =~ s/_arch_/$arch/g;
  537.     $incoming =~ s/_upstream_/$upstream/g;
  538.     $incoming =~ s/_debian_/$debian/g;
  539.  
  540.     chdir $cwd or fatal("Can't chdir to $cwd: $!\n");
  541.     chdir $dir{$job} or fatal("Can't chdir to $dir{$job}: $!\n");
  542.  
  543.     p "[ Uploading job $job";
  544.     @files or p ("\n nothing to do ]"), next;
  545.  
  546.     my $wrong_mode = 0; # For scpb only. A priori, the mode is right for every file
  547.     foreach (@files) {
  548.         my $file = $_;
  549.         my $size = -s;
  550.         my $t;
  551.  
  552.         p(sprintf "\n $file %0.1f kB", $size / 1024);
  553.         $t = time();
  554.         if ($method eq "ftp") {
  555.             unless ($dry) {
  556.                 unless ($server->put($file, $file)) {
  557.                                         $result = $server->message();
  558.                                         $server->delete($file) ;
  559.                     fatal("Can't upload $file: $result");
  560.                 }
  561.                 $t = time() - $t;
  562.             } else {
  563.                 p "\n+ ftp::put($file)";
  564.                 $t = 1;
  565.             }
  566.         } elsif ($method eq "scp") {
  567.                         $mode = (stat($file))[2];
  568.             unless ($dry) {
  569.                 system("scp -p -q $options $file $login\@$fqdn:$incoming");
  570.                 fatal("scp $file failed\n") if $?;
  571.                 $t = time() - $t;
  572.                                 # Small optimization
  573.                                 if ($mode != 33188) { # rw-r--r-- aka 0644
  574.                     system("ssh -x -l $login $fqdn chmod 0644 $incoming/$file");
  575.                     fatal("ssh ... chmod 0644 failed\n") if $?;
  576.                                 }
  577.             } else {
  578.                 p "\n+ scp -p -q $options $file $login\@$fqdn:$incoming";
  579.                                 if ($mode != 33188) { # rw-r--r-- aka 0644
  580.                                      p "\n+ ssh -x -l $login $fqdn chmod 0644 $incoming/$file";
  581.                                 }
  582.                 $t = 1;
  583.             }
  584.                 } elsif ($method eq "scpb") {
  585.                     $copiedfiles .= "$file ";
  586.             $mode = (stat($file))[2];
  587.             # Small optimization
  588.             if ($mode != 33188) { # rw-r--r-- aka 0644
  589.                $wrong_mode = 1;
  590.             }
  591.             $t = 1;
  592.             $batchmode = 1;
  593.                 } elsif ($method eq "rsync") {
  594.             $copiedfiles .= "$file ";
  595.             $mode = (stat($file))[2];
  596.             # Small optimization
  597.             if ($mode != 33188) { # rw-r--r-- aka 0644
  598.                $wrong_mode = 1;
  599.             }
  600.             $t = 1;
  601.             $batchmode = 1;
  602.         }
  603.  
  604.         if ($queuedir) {
  605.             p", renaming";
  606.             if ($method eq "ftp") {
  607.                 unless ($dry) {
  608.                     $server->rename($file, $queuedir . $file)
  609.                         or
  610.                                                 $result=$server->message(),
  611.                                                 $server->delete($file),
  612.                         fatal("Can't rename $file -> $queuedir$file\n");
  613.                 } else {
  614.                     p "\n+ ftp::rename($file, $queuedir$file)";
  615.                 }
  616.             } elsif ($method eq "scp") {
  617.                 unless ($dry) {
  618.                     system("ssh -x -l $login $fqdn \"mv $incoming$file $queuedir$file\"");
  619.                     fatal("ssh -x -l $login $fqdn: mv failed\n") if $?;
  620.                 } else {
  621.                     p "\n+ ssh -x -l $login $fqdn \"mv $incoming$file $queuedir$file\"";
  622.                 }
  623.             }
  624.         }
  625.  
  626.         p ", ok";
  627. # the batch methods don't produce the $t statistic, so filter on that
  628.         p (sprintf " (${t} s, %.2f kB/s)", $size / 1024 / ($t || 1)) unless ($batchmode);
  629.  
  630.         unless ($batchmode) {
  631.             unless ($dry) {
  632.                 open(L, ">>$log{$job}") or w "Can't open $log{$job}: $!\n";
  633.                 print L "u $file $fqdn " . localtime() . "\n";
  634.                 close(L);
  635.             } else {
  636.                 p "\n+ log to $log{$job}\n";
  637.             }
  638.         }
  639.     }
  640. # and now the batch mode uploads
  641.     my $needcmd = 0;
  642.     my $cmd = "ssh -x -l $login $fqdn 'cd $incoming;";
  643.     if ($wrong_mode) {
  644.         $cmd .= "chmod 0644 $copiedfiles;";
  645.         $needcmd = 1;
  646.     }
  647.     if (length($queuedir) > 0) {
  648.         $cmd .= "mv $copiedfiles $queuedir;";
  649.         $needcmd = 1;
  650.     }
  651.     $cmd .= "'";
  652.     if ($method eq "scpb") {
  653.         unless ($dry) {
  654.             p "\n";
  655.             system("scp $options $copiedfiles $login\@$fqdn:$incoming");
  656.             if ($?) {
  657.                 unlink $log{$job};
  658.                 fatal("scp $copiedfiles failed\n");
  659.             }
  660.             if ($needcmd) {
  661.                 system($cmd);
  662.             }
  663.             fatal("$cmd failed\n") if $?;
  664.         } else {
  665.             p "\n+ scp $options $copiedfiles $login\@$fqdn:$incoming";
  666.             p "\n+ $cmd";
  667.         }
  668.         $allfiles = $copiedfiles;
  669.         }
  670.  
  671.     if ($method eq "rsync") {
  672.         unless ($dry) {
  673.             p "\n";
  674.             system("rsync --partial -zave ssh $options -x $copiedfiles $login" . "@" . "$fqdn:$incoming");
  675.             if ($?) {
  676.                 unlink $log{$job};
  677.                 fatal("rsync $copiedfiles failed\n");
  678.             }
  679.             if ($needcmd) {
  680.                 system($cmd);
  681.             }
  682.             fatal("$cmd failed\n") if $?;
  683.         } else {
  684.             p "\n+ rsync --partial -zave ssh $options -x $copiedfiles $login" . "@" . "$fqdn:$incoming";
  685.             p "\n+ $cmd";
  686.         }
  687.         $allfiles = $copiedfiles;
  688.     }
  689.     if ($batchmode) {
  690.         unless ($dry) {
  691.             open(L, ">>$log{$job}") or w "Can't open $log{$job}: $!\n";
  692.             foreach (split(/ /, $allfiles)) {
  693.                 print L "u $_ $fqdn " . localtime() . "\n";
  694.             }
  695.             close(L);
  696.         } else {
  697.             p "\n+ log to $log{$job}\n";
  698.         }
  699.         $batchmode = 0;
  700.     }
  701.  
  702.         announce_if_necessary($job);
  703.         unless ($dry) {
  704.             open(L, ">>$log{$job}")
  705.                 or w("can't open logfile $log{$job}: $!\n");
  706.             print L "s $changes{$job} $fqdn " . localtime() . "\n";
  707.             close(L);
  708.         } else {
  709.             p "\n+ log successful upload\n";
  710.         }
  711.     p " ]\n";
  712.  
  713. }
  714.  
  715. if ($method eq "ftp") {
  716.   unless ($dry) {
  717.     $server->close();
  718.   } else {
  719.     p "\n+ ftp::close\n";
  720.   }
  721. }
  722.  
  723. # postupload code for changes files
  724. unless ($dry) {
  725.     foreach my $change (@changes) {
  726.     if ($postupload{'changes'}) {
  727.         my ($result) = run $postupload{'changes'}, [$change];
  728.         if (! $result) {
  729.         fatal "Post-upload \'$postupload{'changes'}\' " .
  730.             "failed for $change\n  ";
  731.         }
  732.     }
  733.     my ($package, $version, $arch) = (split("_", $_, 3));
  734.     if ($postupload{'sourcepackage'}) {
  735.         my ($result) = run $postupload{'sourcepackage'},
  736.                            [basename($package), $version];
  737.         if (! $result) {
  738.         fatal "Post-upload \'$postupload{'sourcepackage'}\' " .
  739.             "failed for " . basename($package) . " $version\n  ";
  740.         }
  741.     }
  742.     }
  743.     foreach my $file (@all_the_files) {
  744.     if ($postupload{'file'}) {
  745.         my ($result) = run $postupload{'file'}, [$file];
  746.         if (! $result) {
  747.         fatal "Post-upload \'$postupload{'file'}\' " .
  748.             "failed for $file\n  ";
  749.         }
  750.     }
  751.     }
  752.     foreach my $file (@all_the_debs) { 
  753.     if ($postupload{'deb'}) {
  754.         my ($result) = run $postupload{'deb'}, [$file];
  755.         if (! $result) {
  756.         fatal "Post-upload \'$postupload{'deb'}\' " .
  757.             "failed for $file\n  ";
  758.         }
  759.     }
  760.     }
  761.     foreach my $package (keys (%all_packages)) {   
  762.     if ($postupload{'package'}) {
  763.         my ($result) = run $postupload{'package'},
  764.                                [$package, $all_packages{$package}];
  765.         if (! $result) {
  766.         fatal "Post-upload \'$postupload{'package'}\' " .
  767.             "failed for $package $all_packages{$package}\n  ";
  768.         }
  769.     }
  770.     }
  771. }
  772.  
  773. @skipped and w("skipped: @skipped\n");
  774.  
  775. exit 0;
  776.  
  777. ### SUBS
  778.  
  779. ###
  780. sub announce_if_necessary ($) {
  781.     my ($job) = @_[0];
  782.     my ($opt_fullname) = " -F '($fullname)'";
  783.     my ($msg);
  784.     if ($announce{$job} and (! $nomail)) {
  785.     if ($config::no_parentheses_to_fullname) {
  786.            $opt_fullname = " -F '$fullname'";
  787.     }
  788.     $fullname =~ s/\'/''/;
  789.     my $sendmail_cmd = "|$sendmail -f $visibleuser"
  790.         . ($visiblename  ? "\@$visiblename" : "")
  791.         . ($fullname  ? $opt_fullname : "")
  792.             . " $announce{$job}";
  793.     $msg = "announcing to $announce{$job}";
  794.     if ($cc) {
  795.         $sendmail_cmd .= " " . $cc;
  796.         $msg .= " and $cc";
  797.     }
  798.     p $msg . "\n";
  799.     if ((!$dry) or ($mailonly)) {
  800.         open(M, $sendmail_cmd) or fatal("Can't pipe to $sendmail $!\n");
  801.     } else {
  802.         p "\n+ announce to $announce{$job} using command ``$sendmail_cmd''\n";
  803.         open(M, ">&STDOUT");
  804.     }
  805.    
  806.     print M <<xxx;
  807. X-dupload: $version
  808. To: $announce{$job}
  809. xxx
  810.         $cc and print M <<xxx;
  811. Cc: $cc
  812. xxx
  813.         $noarchive and print M <<xxx;
  814. X-No-Archive: yes
  815. xxx
  816.                
  817.     print M <<xxx;
  818. Subject: Uploaded $package{$job} $version{$job} ($arch{$job}) to $host
  819.  
  820. xxx
  821.         foreach (@{$extra{$job}}) {
  822.         my $line;
  823.         open (A, "<$_")
  824.         or w("Can't open extra announce $_: $!\n"), next;
  825.         p " ($_";
  826.         while ($line = <A>) { print M  $line; }
  827.         close(A);
  828.         p(" ok)");
  829.     }
  830.    
  831.     open(C, "<$changes{$job}")
  832.         or fatal("Can't open $changes{$job} $!\n");
  833.     while (<C>) { print M; }
  834.     close(C);
  835.    
  836.     close(M);
  837.     if ($?) { p ", failed"; }
  838.     else { p ", ok"; }
  839.    
  840.     if (!$dry) {
  841.         open(L, ">>$log{$job}")
  842.         or w("can't open logfile $log{$job}: $!\n");
  843.         print L "a $changes{$job} $announce{$job} " . localtime() . "\n";
  844.         close(L);
  845.     } else {
  846.         p "\n+ log announcement\n";
  847.     }
  848.     }
  849. }
  850.  
  851. ### open the connection
  852. sub ftp_open($$$) {
  853.     my ($remote, $user, $pass) = @_;
  854.     my ($ftp_port, $retry_call, $attempts) = (21, 1, 1);
  855.     my ($request_passive) = 0;
  856.    
  857.     if (($user =~ /@/) or ($passive)) {
  858.         $request_passive = 1;
  859.         p "+ FTP passive mode selected\n";
  860.     }
  861.    
  862.     # It may seems complicated, but it is to be sure that the
  863.     # environment variable FTP_PASSIVE works (which needs no
  864.         # Passive argument).
  865.     if ($request_passive) {
  866.         $server = Net::FTP->new ("$fqdn", Passive => $request_passive);
  867.     }
  868.     else {
  869.         $server = Net::FTP->new ("$fqdn");
  870.     }
  871.     if (! $server) {
  872.         fatal ($@);
  873.     }
  874.     $server->debug($debug);
  875.  
  876.     $_ = $server->login($user, $pass)
  877.         or die("Login as $user failed\n");
  878.     $server->type('I')
  879.         or fatal("Can't set binary type\n");
  880. }
  881.  
  882. ### Display what whe know ...
  883. sub info($) {
  884.     my ($host) = @_;
  885.  
  886.     foreach ($host || keys %config::cfg) {
  887.         my $r = $config::cfg{$_};
  888.         print <<xxx;
  889. nick name     : $_
  890. real name     : $r->{fqdn}
  891. login         : $r->{login}
  892. incoming      : $r->{incoming}
  893. queuedir      : $r->{queuedir}
  894. mail to       : $r->{mailto}
  895. mail to x     : $r->{mailtx}
  896. cc            : $r->{cc}
  897. passive FTP   : $r->{passive}
  898. dinstall runs : $r->{dinstall_runs}
  899. archive mail  : $r->{archive}
  900. non-US        : $r->{nonus}
  901.  
  902. xxx
  903.     }
  904. }
  905.  
  906. ### Read the configuration
  907. sub configure(@) {
  908.     my @conffiles = @_;
  909.     my @read = ();
  910.     foreach (@conffiles) {
  911.         -r or next;
  912.         -s or next;
  913.         do $_ or fatal("$@\n");
  914.         push @read, $_;
  915.     }
  916.     @read or fatal("No configuration files\n");
  917. }
  918.  
  919. ### password
  920. sub getpass() {
  921.     system "stty -echo cbreak </dev/tty"; $? and fatal("stty");
  922.     print "\a${login}\@${fqdn}'s ftp account password: ";
  923.     chomp($_ = <STDIN>);
  924.     print "\n";
  925.     system "stty echo -cbreak </dev/tty"; $? and fatal("stty");
  926.     return $_;
  927. };
  928.  
  929. ###
  930. # output
  931. # p() prints to STDOUT if !$quiet
  932. # w()          ....             ,
  933. #     but to STDERR if $quiet
  934. # fatal() dies
  935.                                             {
  936. my $nl;
  937. sub p(@) {
  938.         return if $quiet;
  939.     $nl = $_[$#_] =~ /\n$/;
  940.     print STDOUT @_;
  941. }
  942.  
  943. sub w(@) {
  944.     if ($quiet) { print STDERR "$progname warning: ", @_; }
  945.     else {
  946.     $nl = $_[$#_] =~ /\n$/;
  947.     unshift @_, "$progname warning: ";
  948.     unshift @_, "\n" if !$nl;
  949.     print STDOUT @_;
  950.     }
  951. }
  952.  
  953. sub fatal(@) {
  954.     my ($pack,$file,$line);
  955.     ($pack,$file,$line) = caller();
  956.     (my $msg = "$progname fatal error: @_ at $file line $line\n") =~ tr/\0//d;
  957.     die $msg;
  958. }
  959.  
  960. sub run ($$) {
  961.     my ($command, $args) = @_;
  962.     my (@args) = @{$args};
  963.     my ($result);
  964.     my ($i);
  965.     foreach $i (0..$#args) {
  966.     $args[$i] =~ s#/#\\/#g;
  967.     my ($mycode) = "\$command =~ s/\%" . ($i+1) . "/$args[$i]/g;";
  968.     # Substitute %1 by the first argument, etc
  969.         $result = eval ($mycode);
  970.     if (! defined ($result)) {
  971.         fatal ("Cannot eval arguments substitution $mycode: $@");
  972.     }
  973.     }
  974.     system "$command";
  975.     $result = $CHILD_ERROR>>8;
  976.     return (! $result);
  977. }
  978.  
  979. }
  980.  
  981.  
  982. # ex:set ts=4 sw=4:
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!