chiark - git - mdw - dpkg/blob - dselect/methods/ftp/setup.pl

   1 #!/usr/bin/perl
   2 #
   3 # Copyright © 1996 Andy Guy <awpguy@acs.ucalgary.ca>
   4 # Copyright © 1998 Martin Schulze <joey@infodrom.north.de>
   5 # Copyright © 1999, 2009 Raphaël Hertzog <hertzog@debian.org>
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; version 2 of the License.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  18
  19 use strict;
  20 use warnings;
  21
  22 eval q{
  23     pop @INC if $INC[-1] eq '.';
  24     use Net::FTP;
  25 };
  26 if ($@) {
  27     warn "Please install the 'perl' package if you want to use the\n" .
  28          "FTP access method of dselect.\n\n";
  29     exit 1;
  30 }
  31 use Dselect::Ftp;
  32
  33 # deal with arguments
  34 my $vardir = $ARGV[0];
  35 my $method = $ARGV[1];
  36 my $option = $ARGV[2];
  37
  38 if ($option eq 'manual') {
  39     print "Manual package installation.\n";
  40     exit 0;
  41 }
  42 #print "vardir: $vardir, method: $method, option: $option\n";
  43
  44 #Defaults
  45 my $arch = qx(dpkg --print-architecture);
  46 $arch='i386' if $?;
  47 chomp $arch;
  48
  49 my $logname = qx(whoami);
  50 chomp $logname;
  51 my $host = qx(cat /etc/mailname || dnsdomainname);
  52 chomp $host;
  53
  54 $CONFIG{dldir} = 'debian';
  55 $CONFIG{use_auth_proxy} = 0;
  56 $CONFIG{proxyhost} = '';
  57 $CONFIG{proxylogname} = $logname;
  58 $CONFIG{proxypassword} = '';
  59
  60 my $methdir = "$vardir/methods/ftp";
  61 my $exit = 0;
  62 my $problem = 0;
  63
  64 if (-f "$methdir/vars") {
  65   read_config("$methdir/vars");
  66 }
  67
  68 chdir "$methdir";
  69 if (! -d 'debian') {
  70     mkdir 'debian', 0755;
  71 }
  72 # get info from user
  73
  74 $| = 1;
  75
  76 print <<"EOM";
  77
  78 You must supply an ftp site, use of passive mode, username, password,
  79 path to the debian directory,list of distributions you are interested
  80 in and place to download the binary package files to (relative to
  81 /var/lib/dpkg/methods/ftp). You can add as much sites as you like. Later
  82 entries will always override older ones.
  83
  84 Supply "?" as a password to be asked each time you connect.
  85
  86 Eg:      ftp site: ftp.debian.org
  87           passive: y
  88          username: anonymous
  89          password: $logname\@$host
  90           ftp dir: /debian
  91     distributions: dists/stable/main dists/stable/contrib
  92      download dir: debian
  93
  94 If you want to install package from non-US consider adding a second ftp site
  95 with "debian-non-US" as debian directory and "dists/stable/non-US" as
  96 distribution.
  97
  98 You may have to use an authenticated FTP proxy in order to reach the
  99 FTP site:
 100
 101 Eg:  use auth proxy: y
 102               proxy: proxy.isp.com
 103       proxy account: $CONFIG{proxylogname}
 104      proxy password: ?
 105 EOM
 106
 107 if (! $CONFIG{done}) {
 108   view_mirrors() if (yesno('y', 'Would you like to see a list of ftp mirrors'));
 109   add_site();
 110 }
 111 edit_config($methdir);
 112
 113 my $ftp;
 114 sub download() {
 115  foreach (@{$CONFIG{site}}) {
 116
 117     $ftp = do_connect ($_->[0], # Ftp server
 118                        $_->[4], # username
 119                        $_->[5], # password
 120                        $_->[1], # ftp dir
 121                        $_->[3], # passive
 122                        $CONFIG{use_auth_proxy},
 123                        $CONFIG{proxyhost},
 124                        $CONFIG{proxylogname},
 125                        $CONFIG{proxypassword});
 126
 127     my @dists = @{$_->[2]};
 128
 129     foreach my $dist (@dists) {
 130         my $dir = "$dist/binary-$arch";
 131         print "Checking $dir...\n";
 132 #       if (!$ftp->pasv()) { print $ftp->message . "\n"; die 'error'; }
 133         my @dirlst = $ftp->ls("$dir/");
 134         my $got_pkgfile = 0;
 135
 136         foreach my $line (@dirlst) {
 137             if($line =~ /Packages/) {
 138                 $got_pkgfile=1;
 139             }
 140         }
 141         if( !$got_pkgfile) {
 142             print "Warning: Could not find a Packages file in $dir\n",
 143             "This may not be a problem if the directory is a symbolic link\n";
 144             $problem=1;
 145         }
 146     }
 147     print "Closing ftp connection...\n";
 148     $ftp->quit();
 149   }
 150 }
 151
 152 # download stuff (protect from ^C)
 153 print "\nUsing FTP to check directories...(stop with ^C)\n\n";
 154 eval {
 155     local $SIG{INT} = sub {
 156         die "interrupted!\n";
 157     };
 158     download();
 159 };
 160 if($@) {
 161     $ftp->quit();
 162     print 'FTP ERROR - ';
 163     if ($@ eq 'connect') {
 164         print "config was untested\n";
 165     } else {
 166         print "$@\n";
 167     }
 168     $exit = 1;
 169 };
 170
 171 # output new vars file
 172 $CONFIG{done} = 1;
 173 store_config("$methdir/vars");
 174 chmod  0600, "$methdir/vars";
 175
 176 if($exit || $problem) {
 177     print "Press <enter> to continue\n";
 178     <STDIN>;
 179 }
 180
 181 exit $exit;