chiark - git - mdw - dpkg/blob - dselect/methods/Dselect/Ftp.pm

   1 # This program is free software; you can redistribute it and/or modify
   2 # it under the terms of the GNU General Public License as published by
   3 # the Free Software Foundation; version 2 of the License.
   4 #
   5 # This program is distributed in the hope that it will be useful,
   6 # but WITHOUT ANY WARRANTY; without even the implied warranty of
   7 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   8 # GNU General Public License for more details.
   9 #
  10 # You should have received a copy of the GNU General Public License
  11 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  12
  13 package Dselect::Ftp;
  14
  15 use strict;
  16 use warnings;
  17
  18 our $VERSION = '0.02';
  19 our @EXPORT = qw(
  20     %CONFIG
  21     yesno
  22     nb
  23     do_connect
  24     do_mdtm
  25     view_mirrors
  26     add_site
  27     edit_site
  28     edit_config
  29     read_config
  30     store_config
  31 );
  32
  33 use Exporter qw(import);
  34 use Carp;
  35 use Net::FTP;
  36 use Data::Dumper;
  37
  38 my %CONFIG;
  39
  40 sub nb {
  41   my $nb = shift;
  42   if ($nb > 1024**2) {
  43     return sprintf('%.2fM', $nb / 1024**2);
  44   } elsif ($nb > 1024) {
  45     return sprintf('%.2fk', $nb / 1024);
  46   } else {
  47     return sprintf('%.2fb', $nb);
  48   }
  49
  50 }
  51
  52 sub read_config {
  53   my $vars = shift;
  54   my ($code, $conf);
  55
  56   local($/);
  57   open(my $vars_fh, '<', $vars)
  58     or die "couldn't open '$vars': $!\n" .
  59            "Try to relaunch the 'Access' step in dselect, thanks.\n";
  60   $code = <$vars_fh>;
  61   close $vars_fh;
  62
  63   my $VAR1; ## no critic (Variables::ProhibitUnusedVariables)
  64   $conf = eval $code;
  65   die "couldn't eval $vars content: $@\n" if ($@);
  66   if (ref($conf) =~ /HASH/) {
  67     foreach (keys %{$conf}) {
  68       $CONFIG{$_} = $conf->{$_};
  69     }
  70   } else {
  71     print "Bad $vars file : removing it.\n";
  72     print "Please relaunch the 'Access' step in dselect. Thanks.\n";
  73     unlink $vars;
  74     exit 0;
  75   }
  76 }
  77
  78 sub store_config {
  79   my $vars = shift;
  80
  81   # Check that config is completed
  82   return if not $CONFIG{done};
  83
  84   open(my $vars_fh, '>', $vars)
  85     or die "couldn't open $vars in write mode: $!\n";
  86   print { $vars_fh } Dumper(\%CONFIG);
  87   close $vars_fh;
  88 }
  89
  90 sub view_mirrors {
  91   print <<'MIRRORS';
  92 Please see <http://ftp.debian.org/debian/README.mirrors.txt> for a current
  93 list of Debian mirror sites.
  94 MIRRORS
  95 }
  96
  97 sub edit_config {
  98   my $methdir = shift;
  99   my $i;
 100
 101   #Get a config for ftp sites
 102   while(1) {
 103     $i = 1;
 104     print "\n\nList of selected ftp sites :\n";
 105     foreach (@{$CONFIG{site}}) {
 106       print "$i. ftp://$_->[0]$_->[1] @{$_->[2]}\n";
 107       $i++;
 108     }
 109     print "\nEnter a command (a=add e=edit d=delete q=quit m=mirror list) \n";
 110     print 'eventually followed by a site number : ';
 111     chomp($_ = <STDIN>);
 112     /q/i && last;
 113     /a/i && add_site();
 114     /d\s*(\d+)/i &&
 115     do {
 116          splice(@{$CONFIG{site}}, $1 - 1, 1) if ($1 <= @{$CONFIG{site}});
 117          next;};
 118     /e\s*(\d+)/i &&
 119     do {
 120          edit_site($CONFIG{site}[$1 - 1]) if ($1 <= @{$CONFIG{site}});
 121          next; };
 122     /m/i && view_mirrors();
 123   }
 124
 125   print "\n";
 126   $CONFIG{use_auth_proxy} = yesno($CONFIG{use_auth_proxy} ? 'y' : 'n',
 127                                   'Go through an authenticated proxy');
 128
 129   if ($CONFIG{use_auth_proxy}) {
 130     print "\nEnter proxy hostname [$CONFIG{proxyhost}] : ";
 131     chomp($_ = <STDIN>);
 132     $CONFIG{proxyhost} = $_ || $CONFIG{proxyhost};
 133
 134     print "\nEnter proxy log name [$CONFIG{proxylogname}] : ";
 135     chomp($_ = <STDIN>);
 136     $CONFIG{proxylogname} = $_ || $CONFIG{proxylogname};
 137
 138     print "\nEnter proxy password [$CONFIG{proxypassword}] : ";
 139     chomp ($_ = <STDIN>);
 140     $CONFIG{proxypassword} = $_ || $CONFIG{proxypassword};
 141   }
 142
 143   print "\nEnter directory to download binary package files to\n";
 144   print "(relative to $methdir)\n";
 145   while(1) {
 146     print "[$CONFIG{dldir}] : ";
 147     chomp($_ = <STDIN>);
 148     s{/$}{};
 149     $CONFIG{dldir} = $_ if ($_);
 150     last if -d "$methdir/$CONFIG{dldir}";
 151     print "$methdir/$CONFIG{dldir} is not a directory !\n";
 152   }
 153 }
 154
 155 sub add_site {
 156   my $pas = 1;
 157   my $user = 'anonymous';
 158   my $email = qx(whoami);
 159   chomp $email;
 160   $email .= '@' . qx(cat /etc/mailname || dnsdomainname);
 161   chomp $email;
 162   my $dir = '/debian';
 163
 164   push (@{$CONFIG{site}}, [ '', $dir, [ 'dists/stable/main',
 165                                         'dists/stable/contrib',
 166                                         'dists/stable/non-free' ],
 167                                $pas, $user, $email ]);
 168   edit_site($CONFIG{site}[@{$CONFIG{site}} - 1]);
 169 }
 170
 171 sub edit_site {
 172   my $site = shift;
 173
 174   local($_);
 175
 176   print "\nEnter ftp site [$site->[0]] : ";
 177   chomp($_ = <STDIN>);
 178   $site->[0] = $_ || $site->[0];
 179
 180   print "\nUse passive mode [" . ($site->[3] ? 'y' : 'n') . '] : ';
 181   chomp($_ = <STDIN>);
 182   $site->[3] = (/y/i ? 1 : 0) if ($_);
 183
 184   print "\nEnter username [$site->[4]] : ";
 185   chomp($_ = <STDIN>);
 186   $site->[4] = $_ || $site->[4];
 187
 188   print <<'EOF';
 189
 190 If you're using anonymous ftp to retrieve files, enter your email
 191 address for use as a password. Otherwise enter your password,
 192 or "?" if you want dselect-ftp to prompt you each time.
 193
 194 EOF
 195
 196   print "Enter password [$site->[5]] : ";
 197   chomp($_ = <STDIN>);
 198   $site->[5] = $_ || $site->[5];
 199
 200   print "\nEnter debian directory [$site->[1]] : ";
 201   chomp($_ = <STDIN>);
 202   $site->[1] = $_ || $site->[1];
 203
 204   print "\nEnter space separated list of distributions to get\n";
 205   print "[@{$site->[2]}] : ";
 206   chomp($_ = <STDIN>);
 207   $site->[2] = [ split(/\s+/) ] if $_;
 208 }
 209
 210 sub yesno($$) {
 211   my ($d, $msg) = @_;
 212
 213   my ($res, $r);
 214   $r = -1;
 215   $r = 0 if $d eq 'n';
 216   $r = 1 if $d eq 'y';
 217   croak 'incorrect usage of yesno, stopped' if $r == -1;
 218   while (1) {
 219     print $msg, " [$d]: ";
 220     $res = <STDIN>;
 221     $res =~ /^[Yy]/ and return 1;
 222     $res =~ /^[Nn]/ and return 0;
 223     $res =~ /^[ \t]*$/ and return $r;
 224     print "Please enter one of the letters 'y' or 'n'\n";
 225   }
 226 }
 227
 228 ##############################
 229
 230 sub do_connect {
 231     my($ftpsite,$username,$pass,$ftpdir,$passive,
 232        $useproxy,$proxyhost,$proxylogname,$proxypassword) = @_;
 233
 234     my($rpass,$remotehost,$remoteuser,$ftp);
 235
 236   TRY_CONNECT:
 237     while(1) {
 238         my $exit = 0;
 239
 240         if ($useproxy) {
 241             $remotehost = $proxyhost;
 242             $remoteuser = $username . '@' . $ftpsite;
 243         } else {
 244             $remotehost = $ftpsite;
 245             $remoteuser = $username;
 246         }
 247         print "Connecting to $ftpsite...\n";
 248         $ftp = Net::FTP->new($remotehost, Passive => $passive);
 249         if(!$ftp || !$ftp->ok) {
 250           print "Failed to connect\n";
 251           $exit=1;
 252         }
 253         if (!$exit) {
 254 #    $ftp->debug(1);
 255             if ($useproxy) {
 256                 print "Login on $proxyhost...\n";
 257                 $ftp->_USER($proxylogname);
 258                 $ftp->_PASS($proxypassword);
 259             }
 260             print "Login as $username...\n";
 261             if ($pass eq '?') {
 262                     print 'Enter password for ftp: ';
 263                     system('stty', '-echo');
 264                     $rpass = <STDIN>;
 265                     chomp $rpass;
 266                     print "\n";
 267                     system('stty', 'echo');
 268             } else {
 269                     $rpass = $pass;
 270             }
 271             if(!$ftp->login($remoteuser, $rpass))
 272             { print $ftp->message() . "\n"; $exit=1; }
 273         }
 274         if (!$exit) {
 275             print "Setting transfer mode to binary...\n";
 276             if(!$ftp->binary()) { print $ftp->message . "\n"; $exit=1; }
 277         }
 278         if (!$exit) {
 279             print "Cd to '$ftpdir'...\n";
 280             if(!$ftp->cwd($ftpdir)) { print $ftp->message . "\n"; $exit=1; }
 281         }
 282
 283         if ($exit) {
 284             if (yesno ('y', 'Retry connection at once')) {
 285                 next TRY_CONNECT;
 286             } else {
 287                 die 'error';
 288             }
 289         }
 290
 291         last TRY_CONNECT;
 292     }
 293
 294 #    if(!$ftp->pasv()) { print $ftp->message . "\n"; die 'error'; }
 295
 296     return $ftp;
 297 }
 298
 299 ##############################
 300
 301 # assume server supports MDTM - will be adjusted if needed
 302 my $has_mdtm = 1;
 303
 304 my %months = ('Jan', 0,
 305               'Feb', 1,
 306               'Mar', 2,
 307               'Apr', 3,
 308               'May', 4,
 309               'Jun', 5,
 310               'Jul', 6,
 311               'Aug', 7,
 312               'Sep', 8,
 313               'Oct', 9,
 314               'Nov', 10,
 315               'Dec', 11);
 316
 317 my $ls_l_re = qr<
 318     ([^ ]+\ *){5}                       # Perms, Links, User, Group, Size
 319     [^ ]+                               # Blanks
 320     \ ([A-Z][a-z]{2})                   # Month name (abbreviated)
 321     \ ([0-9 ][0-9])                     # Day of month
 322     \ ([0-9 ][0-9][:0-9][0-9]{2})       # Filename
 323 >x;
 324
 325 sub do_mdtm {
 326     my ($ftp, $file) = @_;
 327     my ($time);
 328
 329     #if ($has_mdtm) {
 330         $time = $ftp->mdtm($file);
 331 #       my $code = $ftp->code();
 332 #       my $message = $ftp->message();
 333 #       print " [ $code: $message ] ";
 334         if ($ftp->code() == 502 || # MDTM not implemented
 335             $ftp->code() == 500) { # command not understood (SUN firewall)
 336             $has_mdtm = 0;
 337         } elsif (!$ftp->ok()) {
 338             return;
 339         }
 340     #}
 341
 342     if (! $has_mdtm) {
 343         require Time::Local;
 344
 345         my @files = $ftp->dir($file);
 346         if (($#files == -1) ||
 347             ($ftp->code == 550)) { # No such file or directory
 348             return;
 349         }
 350
 351 #       my $code = $ftp->code();
 352 #       my $message = $ftp->message();
 353 #       print " [ $code: $message ] ";
 354
 355 #       print "[$#files]";
 356
 357         # get the date components from the output of 'ls -l'
 358         if ($files[0] =~ $ls_l_re) {
 359
 360             my($month_name, $day, $year_or_time, $month, $hours, $minutes,
 361                $year);
 362
 363             # what we can read
 364             $month_name = $2;
 365             $day = 0 + $3;
 366             $year_or_time = $4;
 367
 368             # translate the month name into number
 369             $month = $months{$month_name};
 370
 371             # recognize time or year, and compute missing one
 372             if ($year_or_time =~ /([0-9]{2}):([0-9]{2})/) {
 373                 $hours = 0 + $1; $minutes = 0 + $2;
 374                 my @this_date = gmtime(time());
 375                 my $this_month = $this_date[4];
 376                 my $this_year = $this_date[5];
 377                 if ($month > $this_month) {
 378                     $year = $this_year - 1;
 379                 } else {
 380                     $year = $this_year;
 381                 }
 382             } elsif ($year_or_time =~ / [0-9]{4}/) {
 383                 $hours = 0; $minutes = 0;
 384                 $year = $year_or_time - 1900;
 385             } else {
 386                 die 'cannot parse year-or-time';
 387             }
 388
 389             # build a system time
 390             $time = Time::Local::timegm(0, $minutes, $hours, $day, $month, $year);
 391         } else {
 392             die 'regex match failed on LIST output';
 393         }
 394     }
 395
 396     return $time;
 397 }
 398
 399 1;
 400
 401 __END__