"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/CPAN/CacheMgr.pm" (26 Apr 2015, 7664 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::CacheMgr;
    4 use strict;
    5 use CPAN::InfoObj;
    6 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
    7 use Cwd qw(chdir);
    8 use File::Find;
    9 
   10 use vars qw(
   11             $VERSION
   12 );
   13 $VERSION = "5.5002";
   14 
   15 package CPAN::CacheMgr;
   16 use strict;
   17 
   18 #-> sub CPAN::CacheMgr::as_string ;
   19 sub as_string {
   20     eval { require Data::Dumper };
   21     if ($@) {
   22         return shift->SUPER::as_string;
   23     } else {
   24         return Data::Dumper::Dumper(shift);
   25     }
   26 }
   27 
   28 #-> sub CPAN::CacheMgr::cachesize ;
   29 sub cachesize {
   30     shift->{DU};
   31 }
   32 
   33 #-> sub CPAN::CacheMgr::tidyup ;
   34 sub tidyup {
   35   my($self) = @_;
   36   return unless $CPAN::META->{LOCK};
   37   return unless -d $self->{ID};
   38   my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
   39   for my $current (0..$#toremove) {
   40     my $toremove = $toremove[$current];
   41     $CPAN::Frontend->myprint(sprintf(
   42                                      "DEL(%d/%d): %s \n",
   43                                      $current+1,
   44                                      scalar @toremove,
   45                                      $toremove,
   46                                     )
   47                             );
   48     return if $CPAN::Signal;
   49     $self->_clean_cache($toremove);
   50     return if $CPAN::Signal;
   51   }
   52   $self->{FIFO} = [];
   53 }
   54 
   55 #-> sub CPAN::CacheMgr::dir ;
   56 sub dir {
   57     shift->{ID};
   58 }
   59 
   60 #-> sub CPAN::CacheMgr::entries ;
   61 sub entries {
   62     my($self,$dir) = @_;
   63     return unless defined $dir;
   64     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
   65     $dir ||= $self->{ID};
   66     my($cwd) = CPAN::anycwd();
   67     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
   68     my $dh = DirHandle->new(File::Spec->curdir)
   69         or Carp::croak("Couldn't opendir $dir: $!");
   70     my(@entries);
   71     for ($dh->read) {
   72         next if $_ eq "." || $_ eq "..";
   73         if (-f $_) {
   74             push @entries, File::Spec->catfile($dir,$_);
   75         } elsif (-d _) {
   76             push @entries, File::Spec->catdir($dir,$_);
   77         } else {
   78             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
   79         }
   80     }
   81     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
   82     sort { -M $a <=> -M $b} @entries;
   83 }
   84 
   85 #-> sub CPAN::CacheMgr::disk_usage ;
   86 sub disk_usage {
   87     my($self,$dir,$fast) = @_;
   88     return if exists $self->{SIZE}{$dir};
   89     return if $CPAN::Signal;
   90     my($Du) = 0;
   91     if (-e $dir) {
   92         if (-d $dir) {
   93             unless (-x $dir) {
   94                 unless (chmod 0755, $dir) {
   95                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
   96                                             "permission to change the permission; cannot ".
   97                                             "estimate disk usage of '$dir'\n");
   98                     $CPAN::Frontend->mysleep(5);
   99                     return;
  100                 }
  101             }
  102         } elsif (-f $dir) {
  103             # nothing to say, no matter what the permissions
  104         }
  105     } else {
  106         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
  107         return;
  108     }
  109     if ($fast) {
  110         $Du = 0; # placeholder
  111     } else {
  112         find(
  113              sub {
  114            $File::Find::prune++ if $CPAN::Signal;
  115            return if -l $_;
  116            if ($^O eq 'MacOS') {
  117              require Mac::Files;
  118              my $cat  = Mac::Files::FSpGetCatInfo($_);
  119              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
  120            } else {
  121              if (-d _) {
  122                unless (-x _) {
  123                  unless (chmod 0755, $_) {
  124                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
  125                                            "the permission to change the permission; ".
  126                                            "can only partially estimate disk usage ".
  127                                            "of '$_'\n");
  128                    $CPAN::Frontend->mysleep(5);
  129                    return;
  130                  }
  131                }
  132              } else {
  133                $Du += (-s _);
  134              }
  135            }
  136          },
  137          $dir
  138             );
  139     }
  140     return if $CPAN::Signal;
  141     $self->{SIZE}{$dir} = $Du/1024/1024;
  142     unshift @{$self->{FIFO}}, $dir;
  143     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
  144     $self->{DU} += $Du/1024/1024;
  145     $self->{DU};
  146 }
  147 
  148 #-> sub CPAN::CacheMgr::_clean_cache ;
  149 sub _clean_cache {
  150     my($self,$dir) = @_;
  151     return unless -e $dir;
  152     unless (File::Spec->canonpath(File::Basename::dirname($dir))
  153             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
  154         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
  155                                 "will not remove\n");
  156         $CPAN::Frontend->mysleep(5);
  157         return;
  158     }
  159     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
  160         if $CPAN::DEBUG;
  161     File::Path::rmtree($dir);
  162     my $id_deleted = 0;
  163     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
  164         my $yaml_module = CPAN::_yaml_module();
  165         if ($CPAN::META->has_inst($yaml_module)) {
  166             my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
  167             if ($@) {
  168                 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
  169                 unlink "$dir.yml" or
  170                     $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
  171                 return;
  172             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
  173                 $CPAN::META->delete("CPAN::Distribution", $id);
  174 
  175                 # XXX we should restore the state NOW, otherwise this
  176                 # distro does not exist until we read an index. BUG ALERT(?)
  177 
  178                 # $CPAN::Frontend->mywarn (" +++\n");
  179                 $id_deleted++;
  180             }
  181         }
  182         unlink "$dir.yml"; # may fail
  183         unless ($id_deleted) {
  184             CPAN->debug("no distro found associated with '$dir'");
  185         }
  186     }
  187     $self->{DU} -= $self->{SIZE}{$dir};
  188     delete $self->{SIZE}{$dir};
  189 }
  190 
  191 #-> sub CPAN::CacheMgr::new ;
  192 sub new {
  193     my($class,$phase) = @_;
  194     $phase ||= "atstart";
  195     my $time = time;
  196     my($debug,$t2);
  197     $debug = "";
  198     my $self = {
  199         ID => $CPAN::Config->{build_dir},
  200         MAX => $CPAN::Config->{'build_cache'},
  201         SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
  202         DU => 0
  203     };
  204     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
  205         unless $self->{SCAN} =~ /never|atstart|atexit/;
  206     File::Path::mkpath($self->{ID});
  207     my $dh = DirHandle->new($self->{ID});
  208     bless $self, $class;
  209     $self->scan_cache($phase);
  210     $t2 = time;
  211     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
  212     $time = $t2;
  213     CPAN->debug($debug) if $CPAN::DEBUG;
  214     $self;
  215 }
  216 
  217 #-> sub CPAN::CacheMgr::scan_cache ;
  218 sub scan_cache {
  219     my ($self, $phase) = @_;
  220     $phase = '' unless defined $phase;
  221     return unless $phase eq $self->{SCAN};
  222     return unless $CPAN::META->{LOCK};
  223     $CPAN::Frontend->myprint(
  224                              sprintf("Scanning cache %s for sizes\n",
  225                              $self->{ID}));
  226     my $e;
  227     my @entries = $self->entries($self->{ID});
  228     my $i = 0;
  229     my $painted = 0;
  230     for $e (@entries) {
  231         my $symbol = ".";
  232         if ($self->{DU} > $self->{MAX}) {
  233             $symbol = "-";
  234             $self->disk_usage($e,1);
  235         } else {
  236             $self->disk_usage($e);
  237         }
  238         $i++;
  239         while (($painted/76) < ($i/@entries)) {
  240             $CPAN::Frontend->myprint($symbol);
  241             $painted++;
  242         }
  243         return if $CPAN::Signal;
  244     }
  245     $CPAN::Frontend->myprint("DONE\n");
  246     $self->tidyup;
  247 }
  248 
  249 1;