"Fossies" - the Fresh Open Source Software Archive

Member "dpkg-1.19.7/dselect/methods/Dselect/Ftp.pm" (19 Apr 2019, 9766 Bytes) of package /linux/misc/dpkg_1.19.7.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Ftp.pm" see the Fossies "Dox" file reference documentation.

    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 (%opts) = @_;
  232 
  233     my($rpass,$remotehost,$remoteuser,$ftp);
  234 
  235   TRY_CONNECT:
  236     while(1) {
  237     my $exit = 0;
  238 
  239     if ($opts{useproxy}) {
  240         $remotehost = $opts{proxyhost};
  241         $remoteuser = $opts{username} . '@' . $opts{ftpsite};
  242     } else {
  243         $remotehost = $opts{ftpsite};
  244         $remoteuser = $opts{username};
  245     }
  246     print "Connecting to $opts{ftpsite}...\n";
  247     $ftp = Net::FTP->new($remotehost, Passive => $opts{passive});
  248     if(!$ftp || !$ftp->ok) {
  249       print "Failed to connect\n";
  250       $exit=1;
  251     }
  252     if (!$exit) {
  253 #    $ftp->debug(1);
  254         if ($opts{useproxy}) {
  255         print "Login on $opts{proxyhost}...\n";
  256         $ftp->_USER($opts{proxylogname});
  257         $ftp->_PASS($opts{proxypassword});
  258         }
  259         print "Login as $opts{username}...\n";
  260         if ($opts{password} eq '?') {
  261             print 'Enter password for ftp: ';
  262             system('stty', '-echo');
  263             $rpass = <STDIN>;
  264             chomp $rpass;
  265             print "\n";
  266             system('stty', 'echo');
  267         } else {
  268             $rpass = $opts{password};
  269         }
  270         if(!$ftp->login($remoteuser, $rpass))
  271         { print $ftp->message() . "\n"; $exit=1; }
  272     }
  273     if (!$exit) {
  274         print "Setting transfer mode to binary...\n";
  275         if(!$ftp->binary()) { print $ftp->message . "\n"; $exit=1; }
  276     }
  277     if (!$exit) {
  278         print "Cd to '$opts{ftpdir}'...\n";
  279         if (!$ftp->cwd($opts{ftpdir})) {
  280         print $ftp->message . "\n";
  281         $exit = 1;
  282         }
  283     }
  284 
  285     if ($exit) {
  286         if (yesno ('y', 'Retry connection at once')) {
  287         next TRY_CONNECT;
  288         } else {
  289         die 'error';
  290         }
  291     }
  292 
  293     last TRY_CONNECT;
  294     }
  295 
  296 #    if(!$ftp->pasv()) { print $ftp->message . "\n"; die 'error'; }
  297 
  298     return $ftp;
  299 }
  300 
  301 ##############################
  302 
  303 # assume server supports MDTM - will be adjusted if needed
  304 my $has_mdtm = 1;
  305 
  306 my %months = ('Jan', 0,
  307           'Feb', 1,
  308           'Mar', 2,
  309           'Apr', 3,
  310           'May', 4,
  311           'Jun', 5,
  312           'Jul', 6,
  313           'Aug', 7,
  314           'Sep', 8,
  315           'Oct', 9,
  316           'Nov', 10,
  317           'Dec', 11);
  318 
  319 my $ls_l_re = qr<
  320     ([^ ]+\ *){5}                       # Perms, Links, User, Group, Size
  321     [^ ]+                               # Blanks
  322     \ ([A-Z][a-z]{2})                   # Month name (abbreviated)
  323     \ ([0-9 ][0-9])                     # Day of month
  324     \ ([0-9 ][0-9][:0-9][0-9]{2})       # Filename
  325 >x;
  326 
  327 sub do_mdtm {
  328     my ($ftp, $file) = @_;
  329     my ($time);
  330 
  331     #if ($has_mdtm) {
  332     $time = $ftp->mdtm($file);
  333 #   my $code = $ftp->code();
  334 #   my $message = $ftp->message();
  335 #   print " [ $code: $message ] ";
  336     if ($ftp->code() == 502 || # MDTM not implemented
  337         $ftp->code() == 500) { # command not understood (SUN firewall)
  338         $has_mdtm = 0;
  339     } elsif (!$ftp->ok()) {
  340         return;
  341     }
  342     #}
  343 
  344     if (! $has_mdtm) {
  345     require Time::Local;
  346 
  347     my @files = $ftp->dir($file);
  348     if (($#files == -1) ||
  349         ($ftp->code == 550)) { # No such file or directory
  350         return;
  351     }
  352 
  353 #   my $code = $ftp->code();
  354 #   my $message = $ftp->message();
  355 #   print " [ $code: $message ] ";
  356 
  357 #   print "[$#files]";
  358 
  359     # get the date components from the output of 'ls -l'
  360     if ($files[0] =~ $ls_l_re) {
  361 
  362             my($month_name, $day, $year_or_time, $month, $hours, $minutes,
  363            $year);
  364 
  365         # what we can read
  366         $month_name = $2;
  367         $day = 0 + $3;
  368         $year_or_time = $4;
  369 
  370         # translate the month name into number
  371         $month = $months{$month_name};
  372 
  373         # recognize time or year, and compute missing one
  374         if ($year_or_time =~ /([0-9]{2}):([0-9]{2})/) {
  375         $hours = 0 + $1; $minutes = 0 + $2;
  376         my @this_date = gmtime(time());
  377         my $this_month = $this_date[4];
  378         my $this_year = $this_date[5];
  379         if ($month > $this_month) {
  380             $year = $this_year - 1;
  381         } else {
  382             $year = $this_year;
  383         }
  384         } elsif ($year_or_time =~ / [0-9]{4}/) {
  385         $hours = 0; $minutes = 0;
  386         $year = $year_or_time - 1900;
  387         } else {
  388         die 'cannot parse year-or-time';
  389         }
  390 
  391         # build a system time
  392         $time = Time::Local::timegm(0, $minutes, $hours, $day, $month, $year);
  393     } else {
  394         die 'regex match failed on LIST output';
  395     }
  396     }
  397 
  398     return $time;
  399 }
  400 
  401 1;
  402 
  403 __END__