"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/CPAN/FTP.pm" (10 Mar 2019, 42966 Bytes) of package /windows/misc/install-tl.zip:


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.

    1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
    2 # vim: ts=4 sts=4 sw=4:
    3 package CPAN::FTP;
    4 use strict;
    5 
    6 use Errno ();
    7 use Fcntl qw(:flock);
    8 use File::Basename qw(dirname);
    9 use File::Path qw(mkpath);
   10 use CPAN::FTP::netrc;
   11 use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
   12 
   13 @CPAN::FTP::ISA = qw(CPAN::Debug);
   14 
   15 use vars qw(
   16             $VERSION
   17 );
   18 $VERSION = "5.5011";
   19 
   20 sub _plus_append_open {
   21     my($fh, $file) = @_;
   22     my $parent_dir = dirname $file;
   23     mkpath $parent_dir;
   24     my($cnt);
   25     until (open $fh, "+>>$file") {
   26         next if $! == Errno::EAGAIN; # don't increment on EAGAIN
   27         $CPAN::Frontend->mydie("Could not open '$file' after 10000 tries: $!") if ++$cnt > 100000;
   28         sleep 0.0001;
   29         mkpath $parent_dir;
   30     }
   31 }
   32 
   33 #-> sub CPAN::FTP::ftp_statistics
   34 # if they want to rewrite, they need to pass in a filehandle
   35 sub _ftp_statistics {
   36     my($self,$fh) = @_;
   37     my $locktype = $fh ? LOCK_EX : LOCK_SH;
   38     # XXX On Windows flock() implements mandatory locking, so we can
   39     # XXX only use shared locking to still allow _yaml_load_file() to
   40     # XXX read from the file using a different filehandle.
   41     $locktype = LOCK_SH if $^O eq "MSWin32";
   42 
   43     $fh ||= FileHandle->new;
   44     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
   45     _plus_append_open($fh,$file);
   46     my $sleep = 1;
   47     my $waitstart;
   48     while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
   49         $waitstart ||= localtime();
   50         if ($sleep>3) {
   51             my $now = localtime();
   52             $CPAN::Frontend->mywarn("$now: waiting for read lock on '$file' (since $waitstart)\n");
   53         }
   54         sleep($sleep); # this sleep must not be overridden;
   55                        # Frontend->mysleep with AUTOMATED_TESTING has
   56                        # provoked complete lock contention on my NFS
   57         if ($sleep <= 6) {
   58             $sleep+=0.5;
   59         } else {
   60             # retry to get a fresh handle. If it is NFS and the handle is stale, we will never get an flock
   61             _plus_append_open($fh, $file);
   62         }
   63     }
   64     my $stats = eval { CPAN->_yaml_loadfile($file); };
   65     if ($@) {
   66         if (ref $@) {
   67             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
   68                 chomp $@;
   69                 $CPAN::Frontend->myprintonce("Warning (usually harmless): $@\n");
   70                 return;
   71             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
   72                 my $time = time;
   73                 my $to = "$file.$time";
   74                 $CPAN::Frontend->mywarn("Error reading '$file': $@
   75   Trying to stash it away as '$to' to prevent further interruptions.
   76   You may want to remove that file later.\n");
   77                 # may fail because somebody else has moved it away in the meantime:
   78                 rename $file, $to or $CPAN::Frontend->mywarn("Could not rename '$file' to '$to': $!\n");
   79                 return;
   80             }
   81         } else {
   82             $CPAN::Frontend->mydie($@);
   83         }
   84     }
   85     CPAN::_flock($fh, LOCK_UN);
   86     return $stats->[0];
   87 }
   88 
   89 #-> sub CPAN::FTP::_mytime
   90 sub _mytime () {
   91     if (CPAN->has_inst("Time::HiRes")) {
   92         return Time::HiRes::time();
   93     } else {
   94         return time;
   95     }
   96 }
   97 
   98 #-> sub CPAN::FTP::_new_stats
   99 sub _new_stats {
  100     my($self,$file) = @_;
  101     my $ret = {
  102                file => $file,
  103                attempts => [],
  104                start => _mytime,
  105               };
  106     $ret;
  107 }
  108 
  109 #-> sub CPAN::FTP::_add_to_statistics
  110 sub _add_to_statistics {
  111     my($self,$stats) = @_;
  112     my $yaml_module = CPAN::_yaml_module();
  113     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
  114     if ($CPAN::META->has_inst($yaml_module)) {
  115         $stats->{thesiteurl} = $ThesiteURL;
  116         $stats->{end} = CPAN::FTP::_mytime();
  117         my $fh = FileHandle->new;
  118         my $time = time;
  119         my $sdebug = 0;
  120         my @debug;
  121         @debug = $time if $sdebug;
  122         my $fullstats = $self->_ftp_statistics($fh);
  123         close $fh;
  124         $fullstats->{history} ||= [];
  125         push @debug, scalar @{$fullstats->{history}} if $sdebug;
  126         push @debug, time if $sdebug;
  127         push @{$fullstats->{history}}, $stats;
  128         # YAML.pm 0.62 is unacceptably slow with 999;
  129         # YAML::Syck 0.82 has no noticable performance problem with 999;
  130         my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
  131         my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
  132         while (
  133                @{$fullstats->{history}} > $ftpstats_size
  134                || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
  135               ) {
  136             shift @{$fullstats->{history}}
  137         }
  138         push @debug, scalar @{$fullstats->{history}} if $sdebug;
  139         push @debug, time if $sdebug;
  140         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
  141         # need no eval because if this fails, it is serious
  142         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
  143         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
  144         if ( $sdebug ) {
  145             local $CPAN::DEBUG = 512; # FTP
  146             push @debug, time;
  147             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
  148                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
  149                                 @debug,
  150                                ));
  151         }
  152         # Win32 cannot rename a file to an existing filename
  153         unlink($sfile) if ($^O eq 'MSWin32' or $^O eq 'os2');
  154     _copy_stat($sfile, "$sfile.$$") if -e $sfile;
  155         rename "$sfile.$$", $sfile
  156             or $CPAN::Frontend->mywarn("Could not rename '$sfile.$$' to '$sfile': $!\nGiving up\n");
  157     }
  158 }
  159 
  160 # Copy some stat information (owner, group, mode and) from one file to
  161 # another.
  162 # This is a utility function which might be moved to a utility repository.
  163 #-> sub CPAN::FTP::_copy_stat
  164 sub _copy_stat {
  165     my($src, $dest) = @_;
  166     my @stat = stat($src);
  167     if (!@stat) {
  168     $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
  169     return;
  170     }
  171 
  172     eval {
  173     chmod $stat[2], $dest
  174         or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
  175     };
  176     warn $@ if $@;
  177     eval {
  178     chown $stat[4], $stat[5], $dest
  179         or do {
  180         my $save_err = $!; # otherwise it's lost in the get... calls
  181         $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
  182                     (getpwuid($stat[4]))[0] . "/" .
  183                     (getgrgid($stat[5]))[0] . ": $save_err\n"
  184                        );
  185         };
  186     };
  187     warn $@ if $@;
  188 }
  189 
  190 # if file is CHECKSUMS, suggest the place where we got the file to be
  191 # checked from, maybe only for young files?
  192 #-> sub CPAN::FTP::_recommend_url_for
  193 sub _recommend_url_for {
  194     my($self, $file, $urllist) = @_;
  195     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
  196         my $fullstats = $self->_ftp_statistics();
  197         my $history = $fullstats->{history} || [];
  198         while (my $last = pop @$history) {
  199             last if $last->{end} - time > 3600; # only young results are interesting
  200             next unless $last->{file}; # dirname of nothing dies!
  201             next unless $file eq dirname($last->{file});
  202             return $last->{thesiteurl};
  203         }
  204     }
  205     if ($CPAN::Config->{randomize_urllist}
  206         &&
  207         rand(1) < $CPAN::Config->{randomize_urllist}
  208        ) {
  209         $urllist->[int rand scalar @$urllist];
  210     } else {
  211         return ();
  212     }
  213 }
  214 
  215 #-> sub CPAN::FTP::_get_urllist
  216 sub _get_urllist {
  217     my($self, $with_defaults) = @_;
  218     $with_defaults ||= 0;
  219     CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG;
  220 
  221     $CPAN::Config->{urllist} ||= [];
  222     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
  223         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
  224         $CPAN::Config->{urllist} = [];
  225     }
  226     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
  227     push @urllist, @CPAN::Defaultsites if $with_defaults;
  228     for my $u (@urllist) {
  229         CPAN->debug("u[$u]") if $CPAN::DEBUG;
  230         if (UNIVERSAL::can($u,"text")) {
  231             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
  232         } else {
  233             $u .= "/" unless substr($u,-1) eq "/";
  234             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
  235         }
  236     }
  237     \@urllist;
  238 }
  239 
  240 #-> sub CPAN::FTP::ftp_get ;
  241 sub ftp_get {
  242     my($class,$host,$dir,$file,$target) = @_;
  243     $class->debug(
  244                   qq[Going to fetch file [$file] from dir [$dir]
  245         on host [$host] as local [$target]\n]
  246                  ) if $CPAN::DEBUG;
  247     my $ftp = Net::FTP->new($host);
  248     unless ($ftp) {
  249         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
  250         return;
  251     }
  252     return 0 unless defined $ftp;
  253     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
  254     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
  255     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
  256         my $msg = $ftp->message;
  257         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg\n");
  258         return;
  259     }
  260     unless ( $ftp->cwd($dir) ) {
  261         my $msg = $ftp->message;
  262         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg\n");
  263         return;
  264     }
  265     $ftp->binary;
  266     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
  267     unless ( $ftp->get($file,$target) ) {
  268         my $msg = $ftp->message;
  269         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg\n");
  270         return;
  271     }
  272     $ftp->quit; # it's ok if this fails
  273     return 1;
  274 }
  275 
  276 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
  277 
  278  # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
  279  # > --- /tmp/cp Wed Sep 24 13:26:40 1997
  280  # > ***************
  281  # > *** 1562,1567 ****
  282  # > --- 1562,1580 ----
  283  # >       return 1 if substr($url,0,4) eq "file";
  284  # >       return 1 unless $url =~ m|://([^/]+)|;
  285  # >       my $host = $1;
  286  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
  287  # > +     if ($proxy) {
  288  # > +         $proxy =~ m|://([^/:]+)|;
  289  # > +         $proxy = $1;
  290  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
  291  # > +         if ($noproxy) {
  292  # > +             if ($host !~ /$noproxy$/) {
  293  # > +                 $host = $proxy;
  294  # > +             }
  295  # > +         } else {
  296  # > +             $host = $proxy;
  297  # > +         }
  298  # > +     }
  299  # >       require Net::Ping;
  300  # >       return 1 unless $Net::Ping::VERSION >= 2;
  301  # >       my $p;
  302 
  303 
  304 #-> sub CPAN::FTP::localize ;
  305 sub localize {
  306     my($self,$file,$aslocal,$force,$with_defaults) = @_;
  307     $force ||= 0;
  308     Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,\$force])" )
  309         unless defined $aslocal;
  310     if ($CPAN::DEBUG){
  311         require Carp;
  312         my $longmess = Carp::longmess();
  313         $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
  314     }
  315     if ($^O eq 'MacOS') {
  316         # Comment by AK on 2000-09-03: Uniq short filenames would be
  317         # available in CHECKSUMS file
  318         my($name, $path) = File::Basename::fileparse($aslocal, '');
  319         if (length($name) > 31) {
  320             $name =~ s/(
  321                         \.(
  322                            readme(\.(gz|Z))? |
  323                            (tar\.)?(gz|Z) |
  324                            tgz |
  325                            zip |
  326                            pm\.(gz|Z)
  327                           )
  328                        )$//x;
  329             my $suf = $1;
  330             my $size = 31 - length($suf);
  331             while (length($name) > $size) {
  332                 chop $name;
  333             }
  334             $name .= $suf;
  335             $aslocal = File::Spec->catfile($path, $name);
  336         }
  337     }
  338 
  339     if (-f $aslocal && -r _ && !($force & 1)) {
  340         my $size;
  341         if ($size = -s $aslocal) {
  342             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
  343             return $aslocal;
  344         } else {
  345             # empty file from a previous unsuccessful attempt to download it
  346             unlink $aslocal or
  347                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
  348                                        "could not remove.");
  349         }
  350     }
  351     my($maybe_restore) = 0;
  352     if (-f $aslocal) {
  353         rename $aslocal, "$aslocal.bak$$";
  354         $maybe_restore++;
  355     }
  356 
  357     my($aslocal_dir) = dirname($aslocal);
  358     # Inheritance is not easier to manage than a few if/else branches
  359     if ($CPAN::META->has_usable('LWP::UserAgent')) {
  360         unless ($Ua) {
  361             CPAN::LWP::UserAgent->config;
  362             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
  363             if ($@) {
  364                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
  365                     if $CPAN::DEBUG;
  366             } else {
  367                 my($var);
  368                 $Ua->proxy('ftp',  $var)
  369                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
  370                 $Ua->proxy('http', $var)
  371                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
  372                 $Ua->no_proxy($var)
  373                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
  374             }
  375         }
  376     }
  377     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
  378         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
  379     }
  380 
  381     # Try the list of urls for each single object. We keep a record
  382     # where we did get a file from
  383     my(@reordered,$last);
  384     my $ccurllist = $self->_get_urllist($with_defaults);
  385     $last = $#$ccurllist;
  386     if ($force & 2) { # local cpans probably out of date, don't reorder
  387         @reordered = (0..$last);
  388     } else {
  389         @reordered =
  390             sort {
  391                 (substr($ccurllist->[$b],0,4) eq "file")
  392                     <=>
  393                 (substr($ccurllist->[$a],0,4) eq "file")
  394                     or
  395                 defined($ThesiteURL)
  396                     and
  397                 ($ccurllist->[$b] eq $ThesiteURL)
  398                     <=>
  399                 ($ccurllist->[$a] eq $ThesiteURL)
  400             } 0..$last;
  401     }
  402     my(@levels);
  403     $Themethod ||= "";
  404     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
  405     my @all_levels = (
  406                       ["dleasy",   "file"],
  407                       ["dleasy"],
  408                       ["dlhard"],
  409                       ["dlhardest"],
  410                       ["dleasy",   "http","defaultsites"],
  411                       ["dlhard",   "http","defaultsites"],
  412                       ["dleasy",   "ftp", "defaultsites"],
  413                       ["dlhard",   "ftp", "defaultsites"],
  414                       ["dlhardest","",    "defaultsites"],
  415                      );
  416     if ($Themethod) {
  417         @levels = grep {$_->[0] eq $Themethod} @all_levels;
  418         push @levels, grep {$_->[0] ne $Themethod} @all_levels;
  419     } else {
  420         @levels = @all_levels;
  421     }
  422     @levels = qw/dleasy/ if $^O eq 'MacOS';
  423     my($levelno);
  424     local $ENV{FTP_PASSIVE} =
  425         exists $CPAN::Config->{ftp_passive} ?
  426         $CPAN::Config->{ftp_passive} : 1;
  427     my $ret;
  428     my $stats = $self->_new_stats($file);
  429     for ($CPAN::Config->{connect_to_internet_ok}) {
  430         $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
  431     }
  432   LEVEL: for $levelno (0..$#levels) {
  433         my $level_tuple = $levels[$levelno];
  434         my($level,$scheme,$sitetag) = @$level_tuple;
  435         $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
  436         my $defaultsites = $sitetag && $sitetag eq "defaultsites" && !@$ccurllist;
  437         my @urllist;
  438         if ($defaultsites) {
  439             unless (defined $connect_to_internet_ok) {
  440                 $CPAN::Frontend->myprint(sprintf qq{
  441 I would like to connect to one of the following sites to get '%s':
  442 
  443 %s
  444 },
  445                                          $file,
  446                                          join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
  447                                         );
  448                 my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
  449                 if ($answer =~ /^y/i) {
  450                     $connect_to_internet_ok = 1;
  451                 } else {
  452                     $connect_to_internet_ok = 0;
  453                 }
  454             }
  455             if ($connect_to_internet_ok) {
  456                 @urllist = @CPAN::Defaultsites;
  457             } else {
  458                 my $sleep = 2;
  459                 # the tricky thing about dying here is that everybody
  460                 # believes that calls to exists() or all_objects() are
  461                 # safe.
  462                 require CPAN::Exception::blocked_urllist;
  463                 die CPAN::Exception::blocked_urllist->new;
  464             }
  465         } else { # ! $defaultsites
  466             my @host_seq = $level =~ /dleasy/ ?
  467                 @reordered : 0..$last;  # reordered has file and $Thesiteurl first
  468             @urllist = map { $ccurllist->[$_] } @host_seq;
  469         }
  470         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
  471         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
  472         if (my $recommend = $self->_recommend_url_for($file,\@urllist)) {
  473             @urllist = grep { $_ ne $recommend } @urllist;
  474             unshift @urllist, $recommend;
  475         }
  476         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
  477         $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
  478         if ($ret) {
  479             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
  480             if ($ret eq $aslocal_tempfile) {
  481                 # if we got it exactly as we asked for, only then we
  482                 # want to rename
  483                 rename $aslocal_tempfile, $aslocal
  484                     or $CPAN::Frontend->mydie("Error while trying to rename ".
  485                                               "'$ret' to '$aslocal': $!");
  486                 $ret = $aslocal;
  487             }
  488             elsif (-f $ret && $scheme eq 'file' ) {
  489                 # it's a local file, so there's nothing left to do, we
  490                 # let them read from where it is
  491             }
  492             $Themethod = $level;
  493             my $now = time;
  494             # utime $now, $now, $aslocal; # too bad, if we do that, we
  495                                           # might alter a local mirror
  496             $self->debug("level[$level]") if $CPAN::DEBUG;
  497             last LEVEL;
  498         } else {
  499             unlink $aslocal_tempfile;
  500             last if $CPAN::Signal; # need to cleanup
  501         }
  502     }
  503     if ($ret) {
  504         $stats->{filesize} = -s $ret;
  505     }
  506     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
  507     $self->_add_to_statistics($stats);
  508     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
  509     if ($ret) {
  510         unlink "$aslocal.bak$$";
  511         return $ret;
  512     }
  513     unless ($CPAN::Signal) {
  514         my(@mess);
  515         local $" = " ";
  516         if (@{$CPAN::Config->{urllist}}) {
  517             push @mess,
  518                 qq{Please check, if the URLs I found in your configuration file \(}.
  519                     join(", ", @{$CPAN::Config->{urllist}}).
  520                         qq{\) are valid.};
  521         } else {
  522             push @mess, qq{Your urllist is empty!};
  523         }
  524         push @mess, qq{The urllist can be edited.},
  525             qq{E.g. with 'o conf urllist push ftp://myurl/'};
  526         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
  527         $CPAN::Frontend->mydie("Could not fetch $file\n");
  528     }
  529     if ($maybe_restore) {
  530         rename "$aslocal.bak$$", $aslocal;
  531         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
  532                                  $self->ls($aslocal) . "\n");
  533         return $aslocal;
  534     }
  535     return;
  536 }
  537 
  538 sub mymkpath {
  539     my($self, $aslocal_dir) = @_;
  540     mkpath($aslocal_dir);
  541     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
  542                             qq{directory "$aslocal_dir".
  543     I\'ll continue, but if you encounter problems, they may be due
  544     to insufficient permissions.\n}) unless -w $aslocal_dir;
  545 }
  546 
  547 sub hostdlxxx {
  548     my $self = shift;
  549     my $level = shift;
  550     my $scheme = shift;
  551     my $h = shift;
  552     $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
  553     my $method = "host$level";
  554     $self->$method($h, @_);
  555 }
  556 
  557 sub _set_attempt {
  558     my($self,$stats,$method,$url) = @_;
  559     push @{$stats->{attempts}}, {
  560                                  method => $method,
  561                                  start => _mytime,
  562                                  url => $url,
  563                                 };
  564 }
  565 
  566 # package CPAN::FTP;
  567 sub hostdleasy { #called from hostdlxxx
  568     my($self,$host_seq,$file,$aslocal,$stats) = @_;
  569     my($ro_url);
  570   HOSTEASY: for $ro_url (@$host_seq) {
  571         $self->_set_attempt($stats,"dleasy",$ro_url);
  572         my $url = "$ro_url$file";
  573         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
  574         if ($url =~ /^file:/) {
  575             my $l;
  576             if ($CPAN::META->has_inst('URI::URL')) {
  577                 my $u =  URI::URL->new($url);
  578                 $l = $u->file;
  579             } else { # works only on Unix, is poorly constructed, but
  580                 # hopefully better than nothing.
  581                 # RFC 1738 says fileurl BNF is
  582                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
  583                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
  584                 # the code
  585                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
  586                 $l =~ s|^file:||;                   # assume they
  587                                                     # meant
  588                                                     # file://localhost
  589                 $l =~ s|^/||s
  590                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
  591             }
  592             $self->debug("local file[$l]") if $CPAN::DEBUG;
  593             if ( -f $l && -r _) {
  594                 $ThesiteURL = $ro_url;
  595                 return $l;
  596             }
  597             # If request is for a compressed file and we can find the
  598             # uncompressed file also, return the path of the uncompressed file
  599             # otherwise, decompress it and return the resulting path
  600             if ($l =~ /(.+)\.gz$/) {
  601                 my $ungz = $1;
  602                 if ( -f $ungz && -r _) {
  603                     $ThesiteURL = $ro_url;
  604                     return $ungz;
  605                 }
  606                 elsif (-f $l && -r _) {
  607                     eval { CPAN::Tarzip->new($l)->gunzip($aslocal) };
  608                     if ( -f $aslocal && -s _) {
  609                         $ThesiteURL = $ro_url;
  610                         return $aslocal;
  611                     }
  612                     elsif (! -s $aslocal) {
  613                         unlink $aslocal;
  614                     }
  615                     elsif (-f $l) {
  616                         $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
  617                             if $@;
  618                         return;
  619                     }
  620                 }
  621             }
  622             # Otherwise, return the local file path if it exists
  623             elsif ( -f $l && -r _) {
  624                 $ThesiteURL = $ro_url;
  625                 return $l;
  626             }
  627             # If we can't find it, but there is a compressed version
  628             # of it, then decompress it
  629             elsif (-f "$l.gz") {
  630                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
  631                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
  632                 if ( -f $aslocal) {
  633                     $ThesiteURL = $ro_url;
  634                     return $aslocal;
  635                 }
  636                 else {
  637                     $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
  638                         if $@;
  639                     return;
  640                 }
  641             }
  642             $CPAN::Frontend->mywarn("Could not find '$l'\n");
  643         }
  644         $self->debug("it was not a file URL") if $CPAN::DEBUG;
  645         if ($CPAN::META->has_usable('LWP')) {
  646             $CPAN::Frontend->myprint("Fetching with LWP:\n$url\n");
  647             unless ($Ua) {
  648                 CPAN::LWP::UserAgent->config;
  649                 eval { $Ua = CPAN::LWP::UserAgent->new; };
  650                 if ($@) {
  651                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
  652                 }
  653             }
  654             my $res = $Ua->mirror($url, $aslocal);
  655             if ($res->is_success) {
  656                 $ThesiteURL = $ro_url;
  657                 my $now = time;
  658                 utime $now, $now, $aslocal; # download time is more
  659                                             # important than upload
  660                                             # time
  661                 return $aslocal;
  662             } elsif ($url !~ /\.gz(?!\n)\Z/) {
  663                 my $gzurl = "$url.gz";
  664                 $CPAN::Frontend->myprint("Fetching with LWP:\n$gzurl\n");
  665                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
  666                 if ($res->is_success) {
  667                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
  668                         $ThesiteURL = $ro_url;
  669                         return $aslocal;
  670                     }
  671                 }
  672             } else {
  673                 $CPAN::Frontend->myprint(sprintf(
  674                                                  "LWP failed with code[%s] message[%s]\n",
  675                                                  $res->code,
  676                                                  $res->message,
  677                                                 ));
  678                 # Alan Burlison informed me that in firewall environments
  679                 # Net::FTP can still succeed where LWP fails. So we do not
  680                 # skip Net::FTP anymore when LWP is available.
  681             }
  682         } elsif ($url =~ /^http:/i && $CPAN::META->has_usable('HTTP::Tiny')) {
  683             require CPAN::HTTP::Client;
  684             my $chc = CPAN::HTTP::Client->new(
  685                 proxy => $CPAN::Config->{http_proxy} || $ENV{http_proxy},
  686                 no_proxy => $CPAN::Config->{no_proxy} || $ENV{no_proxy},
  687             );
  688             for my $try ( $url, ( $url !~ /\.gz(?!\n)\Z/ ? "$url.gz" : () ) ) {
  689                 $CPAN::Frontend->myprint("Fetching with HTTP::Tiny:\n$try\n");
  690                 my $res = eval { $chc->mirror($try, $aslocal) };
  691                 if ( $res && $res->{success} ) {
  692                     $ThesiteURL = $ro_url;
  693                     my $now = time;
  694                     utime $now, $now, $aslocal; # download time is more
  695                                                 # important than upload
  696                                                 # time
  697                     return $aslocal;
  698                 }
  699                 elsif ( $res && $res->{status} ne '599') {
  700                     $CPAN::Frontend->myprint(sprintf(
  701                             "HTTP::Tiny failed with code[%s] message[%s]\n",
  702                             $res->{status},
  703                             $res->{reason},
  704                         )
  705                     );
  706                 }
  707                 elsif ( $res && $res->{status} eq '599') {
  708                     $CPAN::Frontend->myprint(sprintf(
  709                             "HTTP::Tiny failed with an internal error: %s\n",
  710                             $res->{content},
  711                         )
  712                     );
  713                 }
  714                 else {
  715                     my $err = $@ || 'Unknown error';
  716                     $CPAN::Frontend->myprint(sprintf(
  717                             "Error downloading with HTTP::Tiny: %s\n", $err
  718                         )
  719                     );
  720                 }
  721             }
  722         }
  723         return if $CPAN::Signal;
  724         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
  725             # that's the nice and easy way thanks to Graham
  726             $self->debug("recognized ftp") if $CPAN::DEBUG;
  727             my($host,$dir,$getfile) = ($1,$2,$3);
  728             if ($CPAN::META->has_usable('Net::FTP')) {
  729                 $dir =~ s|/+|/|g;
  730                 $CPAN::Frontend->myprint("Fetching with Net::FTP:\n$url\n");
  731                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
  732                              "aslocal[$aslocal]") if $CPAN::DEBUG;
  733                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
  734                     $ThesiteURL = $ro_url;
  735                     return $aslocal;
  736                 }
  737                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
  738                     my $gz = "$aslocal.gz";
  739                     $CPAN::Frontend->myprint("Fetching with Net::FTP\n$url.gz\n");
  740                     if (CPAN::FTP->ftp_get($host,
  741                                            $dir,
  742                                            "$getfile.gz",
  743                                            $gz) &&
  744                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
  745                     ) {
  746                         $ThesiteURL = $ro_url;
  747                         return $aslocal;
  748                     }
  749                 }
  750                 # next HOSTEASY;
  751             } else {
  752                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
  753             }
  754         }
  755         if (
  756             UNIVERSAL::can($ro_url,"text")
  757             and
  758             $ro_url->{FROM} eq "USER"
  759            ) {
  760             ##address #17973: default URLs should not try to override
  761             ##user-defined URLs just because LWP is not available
  762             my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
  763             return $ret if $ret;
  764         }
  765         return if $CPAN::Signal;
  766     }
  767 }
  768 
  769 # package CPAN::FTP;
  770 sub hostdlhard {
  771     my($self,$host_seq,$file,$aslocal,$stats) = @_;
  772 
  773     # Came back if Net::FTP couldn't establish connection (or
  774     # failed otherwise) Maybe they are behind a firewall, but they
  775     # gave us a socksified (or other) ftp program...
  776 
  777     my($ro_url);
  778     my($devnull) = $CPAN::Config->{devnull} || "";
  779     # < /dev/null ";
  780     my($aslocal_dir) = dirname($aslocal);
  781     mkpath($aslocal_dir);
  782     my $some_dl_success = 0;
  783     my $any_attempt = 0;
  784  HOSTHARD: for $ro_url (@$host_seq) {
  785         $self->_set_attempt($stats,"dlhard",$ro_url);
  786         my $url = "$ro_url$file";
  787         my($proto,$host,$dir,$getfile);
  788 
  789         # Courtesy Mark Conty mark_conty@cargill.com change from
  790         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
  791         # to
  792         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
  793             # proto not yet used
  794             ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
  795         } else {
  796             next HOSTHARD; # who said, we could ftp anything except ftp?
  797         }
  798         next HOSTHARD if $proto eq "file"; # file URLs would have had
  799                                            # success above. Likely a bogus URL
  800 
  801         # making at least one attempt against a host
  802         $any_attempt++;
  803 
  804         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
  805 
  806         # Try the most capable first and leave ncftp* for last as it only
  807         # does FTP.
  808         my $proxy_vars = $self->_proxy_vars($ro_url);
  809       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
  810             my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
  811             next DLPRG unless defined $funkyftp;
  812             next DLPRG if $funkyftp =~ /^\s*$/;
  813 
  814             my($src_switch) = "";
  815             my($chdir) = "";
  816             my($stdout_redir) = " > \"$aslocal\"";
  817             if ($f eq "lynx") {
  818                 $src_switch = " -source";
  819             } elsif ($f eq "ncftp") {
  820                 next DLPRG unless $url =~ m{\Aftp://};
  821                 $src_switch = " -c";
  822             } elsif ($f eq "wget") {
  823                 $src_switch = " -O \"$aslocal\"";
  824                 $stdout_redir = "";
  825             } elsif ($f eq 'curl') {
  826                 $src_switch = ' -L -f -s -S --netrc-optional';
  827                 if ($proxy_vars->{http_proxy}) {
  828                     $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
  829                 }
  830             } elsif ($f eq "ncftpget") {
  831                 next DLPRG unless $url =~ m{\Aftp://};
  832                 $chdir = "cd $aslocal_dir && ";
  833                 $stdout_redir = "";
  834             }
  835             $CPAN::Frontend->myprint(
  836                                      qq[
  837 Trying with
  838     $funkyftp$src_switch
  839 to get
  840     $url
  841 ]);
  842             my($system) =
  843                 "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
  844             $self->debug("system[$system]") if $CPAN::DEBUG;
  845             my($wstatus) = system($system);
  846             if ($f eq "lynx") {
  847                 # lynx returns 0 when it fails somewhere
  848                 if (-s $aslocal) {
  849                     my $content = do { local *FH;
  850                                        open FH, $aslocal or die;
  851                                        local $/;
  852                                        <FH> };
  853                     if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
  854                         $CPAN::Frontend->mywarn(qq{
  855 No success, the file that lynx has downloaded looks like an error message:
  856 $content
  857 });
  858                         $CPAN::Frontend->mysleep(1);
  859                         next DLPRG;
  860                     }
  861                     $some_dl_success++;
  862                 } else {
  863                     $CPAN::Frontend->myprint(qq{
  864 No success, the file that lynx has downloaded is an empty file.
  865 });
  866                     next DLPRG;
  867                 }
  868             }
  869             if ($wstatus == 0) {
  870                 if (-s $aslocal) {
  871                     # Looks good
  872                     $some_dl_success++;
  873                 }
  874                 $ThesiteURL = $ro_url;
  875                 return $aslocal;
  876             } else {
  877                 my $estatus = $wstatus >> 8;
  878                 my $size = -f $aslocal ?
  879                     ", left\n$aslocal with size ".-s _ :
  880                     "\nWarning: expected file [$aslocal] doesn't exist";
  881                 $CPAN::Frontend->myprint(qq{
  882     Function system("$system")
  883     returned status $estatus (wstat $wstatus)$size
  884     });
  885             }
  886             return if $CPAN::Signal;
  887         } # download/transfer programs (DLPRG)
  888     } # host
  889     return unless $any_attempt;
  890     if ($some_dl_success) {
  891         $CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.\n");
  892     } else {
  893         $CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it.\n");
  894     }
  895     return;
  896 }
  897 
  898 #-> CPAN::FTP::_proxy_vars
  899 sub _proxy_vars {
  900     my($self,$url) = @_;
  901     my $ret = +{};
  902     my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
  903     if ($http_proxy) {
  904         my($host) = $url =~ m|://([^/:]+)|;
  905         my $want_proxy = 1;
  906         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
  907         my @noproxy = split /\s*,\s*/, $noproxy;
  908         if ($host) {
  909           DOMAIN: for my $domain (@noproxy) {
  910                 if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
  911                     $want_proxy = 0;
  912                     last DOMAIN;
  913                 }
  914             }
  915         } else {
  916             $CPAN::Frontend->mywarn("  Could not determine host from http_proxy '$http_proxy'\n");
  917         }
  918         if ($want_proxy) {
  919             my($user, $pass) =
  920                 CPAN::HTTP::Credentials->get_proxy_credentials();
  921             $ret = {
  922                     proxy_user => $user,
  923                     proxy_pass => $pass,
  924                     http_proxy => $http_proxy
  925                   };
  926         }
  927     }
  928     return $ret;
  929 }
  930 
  931 # package CPAN::FTP;
  932 sub hostdlhardest {
  933     my($self,$host_seq,$file,$aslocal,$stats) = @_;
  934 
  935     return unless @$host_seq;
  936     my($ro_url);
  937     my($aslocal_dir) = dirname($aslocal);
  938     mkpath($aslocal_dir);
  939     my $ftpbin = $CPAN::Config->{ftp};
  940     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
  941         $CPAN::Frontend->myprint("No external ftp command available\n\n");
  942         return;
  943     }
  944     $CPAN::Frontend->mywarn(qq{
  945 As a last resort we now switch to the external ftp command '$ftpbin'
  946 to get '$aslocal'.
  947 
  948 Doing so often leads to problems that are hard to diagnose.
  949 
  950 If you're the victim of such problems, please consider unsetting the
  951 ftp config variable with
  952 
  953     o conf ftp ""
  954     o conf commit
  955 
  956 });
  957     $CPAN::Frontend->mysleep(2);
  958   HOSTHARDEST: for $ro_url (@$host_seq) {
  959         $self->_set_attempt($stats,"dlhardest",$ro_url);
  960         my $url = "$ro_url$file";
  961         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
  962         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
  963             next;
  964         }
  965         my($host,$dir,$getfile) = ($1,$2,$3);
  966         my $timestamp = 0;
  967         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
  968             $ctime,$blksize,$blocks) = stat($aslocal);
  969         $timestamp = $mtime ||= 0;
  970         my($netrc) = CPAN::FTP::netrc->new;
  971         my($netrcfile) = $netrc->netrc;
  972         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
  973         my $targetfile = File::Basename::basename($aslocal);
  974         my(@dialog);
  975         push(
  976              @dialog,
  977              "lcd $aslocal_dir",
  978              "cd /",
  979              map("cd $_", split /\//, $dir), # RFC 1738
  980              "bin",
  981              "passive",
  982              "get $getfile $targetfile",
  983              "quit"
  984         );
  985         if (! $netrcfile) {
  986             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
  987         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
  988             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
  989                                 $netrc->hasdefault,
  990                                 $netrc->contains($host))) if $CPAN::DEBUG;
  991             if ($netrc->protected) {
  992                 my $dialog = join "", map { "    $_\n" } @dialog;
  993                 my $netrc_explain;
  994                 if ($netrc->contains($host)) {
  995                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
  996                         "manages the login";
  997                 } else {
  998                     $netrc_explain = "Relying that your default .netrc entry ".
  999                         "manages the login";
 1000                 }
 1001                 $CPAN::Frontend->myprint(qq{
 1002   Trying with external ftp to get
 1003     '$url'
 1004   $netrc_explain
 1005   Sending the dialog
 1006 $dialog
 1007 }
 1008                 );
 1009                 $self->talk_ftp("$ftpbin$verbose $host",
 1010                                 @dialog);
 1011                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 1012                     $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
 1013                 $mtime ||= 0;
 1014                 if ($mtime > $timestamp) {
 1015                     $CPAN::Frontend->myprint("GOT $aslocal\n");
 1016                     $ThesiteURL = $ro_url;
 1017                     return $aslocal;
 1018                 } else {
 1019                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
 1020                 }
 1021                     return if $CPAN::Signal;
 1022             } else {
 1023                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
 1024                                         qq{correctly protected.\n});
 1025             }
 1026         } else {
 1027             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
 1028   nor does it have a default entry\n");
 1029         }
 1030 
 1031         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
 1032         # then and login manually to host, using e-mail as
 1033         # password.
 1034         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
 1035         unshift(
 1036                 @dialog,
 1037                 "open $host",
 1038                 "user anonymous $Config::Config{'cf_email'}"
 1039         );
 1040         my $dialog = join "", map { "    $_\n" } @dialog;
 1041         $CPAN::Frontend->myprint(qq{
 1042   Trying with external ftp to get
 1043     $url
 1044   Sending the dialog
 1045 $dialog
 1046 }
 1047         );
 1048         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
 1049         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 1050             $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
 1051         $mtime ||= 0;
 1052         if ($mtime > $timestamp) {
 1053             $CPAN::Frontend->myprint("GOT $aslocal\n");
 1054             $ThesiteURL = $ro_url;
 1055             return $aslocal;
 1056         } else {
 1057             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
 1058         }
 1059         return if $CPAN::Signal;
 1060         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
 1061         $CPAN::Frontend->mysleep(2);
 1062     } # host
 1063 }
 1064 
 1065 # package CPAN::FTP;
 1066 sub talk_ftp {
 1067     my($self,$command,@dialog) = @_;
 1068     my $fh = FileHandle->new;
 1069     $fh->open("|$command") or die "Couldn't open ftp: $!";
 1070     foreach (@dialog) { $fh->print("$_\n") }
 1071     $fh->close; # Wait for process to complete
 1072     my $wstatus = $?;
 1073     my $estatus = $wstatus >> 8;
 1074     $CPAN::Frontend->myprint(qq{
 1075 Subprocess "|$command"
 1076   returned status $estatus (wstat $wstatus)
 1077 }) if $wstatus;
 1078 }
 1079 
 1080 # find2perl needs modularization, too, all the following is stolen
 1081 # from there
 1082 # CPAN::FTP::ls
 1083 sub ls {
 1084     my($self,$name) = @_;
 1085     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
 1086      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
 1087 
 1088     my($perms,%user,%group);
 1089     my $pname = $name;
 1090 
 1091     if ($blocks) {
 1092         $blocks = int(($blocks + 1) / 2);
 1093     }
 1094     else {
 1095         $blocks = int(($sizemm + 1023) / 1024);
 1096     }
 1097 
 1098     if    (-f _) { $perms = '-'; }
 1099     elsif (-d _) { $perms = 'd'; }
 1100     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
 1101     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
 1102     elsif (-p _) { $perms = 'p'; }
 1103     elsif (-S _) { $perms = 's'; }
 1104     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
 1105 
 1106     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
 1107     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 1108     my $tmpmode = $mode;
 1109     my $tmp = $rwx[$tmpmode & 7];
 1110     $tmpmode >>= 3;
 1111     $tmp = $rwx[$tmpmode & 7] . $tmp;
 1112     $tmpmode >>= 3;
 1113     $tmp = $rwx[$tmpmode & 7] . $tmp;
 1114     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
 1115     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
 1116     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
 1117     $perms .= $tmp;
 1118 
 1119     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
 1120     my $group = $group{$gid} || $gid;
 1121 
 1122     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
 1123     my($timeyear);
 1124     my($moname) = $moname[$mon];
 1125     if (-M _ > 365.25 / 2) {
 1126         $timeyear = $year + 1900;
 1127     }
 1128     else {
 1129         $timeyear = sprintf("%02d:%02d", $hour, $min);
 1130     }
 1131 
 1132     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
 1133              $ino,
 1134                   $blocks,
 1135                        $perms,
 1136                              $nlink,
 1137                                  $user,
 1138                                       $group,
 1139                                            $sizemm,
 1140                                                $moname,
 1141                                                   $mday,
 1142                                                       $timeyear,
 1143                                                           $pname;
 1144 }
 1145 
 1146 1;