lib/CPAN/CacheMgr.pm

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