| # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
| # vim: ts=4 sts=4 sw=4: |
| package CPAN::CacheMgr; |
| use strict; |
| use CPAN::InfoObj; |
| @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); |
| use Cwd qw(chdir); |
| use File::Find; |
| |
| use vars qw( |
| $VERSION |
| ); |
| $VERSION = "5.5001"; |
| |
| package CPAN::CacheMgr; |
| use strict; |
| |
| #-> sub CPAN::CacheMgr::as_string ; |
| sub as_string { |
| eval { require Data::Dumper }; |
| if ($@) { |
| return shift->SUPER::as_string; |
| } else { |
| return Data::Dumper::Dumper(shift); |
| } |
| } |
| |
| #-> sub CPAN::CacheMgr::cachesize ; |
| sub cachesize { |
| shift->{DU}; |
| } |
| |
| #-> sub CPAN::CacheMgr::tidyup ; |
| sub tidyup { |
| my($self) = @_; |
| return unless $CPAN::META->{LOCK}; |
| return unless -d $self->{ID}; |
| my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}}; |
| for my $current (0..$#toremove) { |
| my $toremove = $toremove[$current]; |
| $CPAN::Frontend->myprint(sprintf( |
| "DEL(%d/%d): %s \n", |
| $current+1, |
| scalar @toremove, |
| $toremove, |
| ) |
| ); |
| return if $CPAN::Signal; |
| $self->_clean_cache($toremove); |
| return if $CPAN::Signal; |
| } |
| $self->{FIFO} = []; |
| } |
| |
| #-> sub CPAN::CacheMgr::dir ; |
| sub dir { |
| shift->{ID}; |
| } |
| |
| #-> sub CPAN::CacheMgr::entries ; |
| sub entries { |
| my($self,$dir) = @_; |
| return unless defined $dir; |
| $self->debug("reading dir[$dir]") if $CPAN::DEBUG; |
| $dir ||= $self->{ID}; |
| my($cwd) = CPAN::anycwd(); |
| chdir $dir or Carp::croak("Can't chdir to $dir: $!"); |
| my $dh = DirHandle->new(File::Spec->curdir) |
| or Carp::croak("Couldn't opendir $dir: $!"); |
| my(@entries); |
| for ($dh->read) { |
| next if $_ eq "." || $_ eq ".."; |
| if (-f $_) { |
| push @entries, File::Spec->catfile($dir,$_); |
| } elsif (-d _) { |
| push @entries, File::Spec->catdir($dir,$_); |
| } else { |
| $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); |
| } |
| } |
| chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); |
| sort { -M $a <=> -M $b} @entries; |
| } |
| |
| #-> sub CPAN::CacheMgr::disk_usage ; |
| sub disk_usage { |
| my($self,$dir,$fast) = @_; |
| return if exists $self->{SIZE}{$dir}; |
| return if $CPAN::Signal; |
| my($Du) = 0; |
| if (-e $dir) { |
| if (-d $dir) { |
| unless (-x $dir) { |
| unless (chmod 0755, $dir) { |
| $CPAN::Frontend->mywarn("I have neither the -x permission nor the ". |
| "permission to change the permission; cannot ". |
| "estimate disk usage of '$dir'\n"); |
| $CPAN::Frontend->mysleep(5); |
| return; |
| } |
| } |
| } elsif (-f $dir) { |
| # nothing to say, no matter what the permissions |
| } |
| } else { |
| $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n"); |
| return; |
| } |
| if ($fast) { |
| $Du = 0; # placeholder |
| } else { |
| find( |
| sub { |
| $File::Find::prune++ if $CPAN::Signal; |
| return if -l $_; |
| if ($^O eq 'MacOS') { |
| require Mac::Files; |
| my $cat = Mac::Files::FSpGetCatInfo($_); |
| $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat; |
| } else { |
| if (-d _) { |
| unless (-x _) { |
| unless (chmod 0755, $_) { |
| $CPAN::Frontend->mywarn("I have neither the -x permission nor ". |
| "the permission to change the permission; ". |
| "can only partially estimate disk usage ". |
| "of '$_'\n"); |
| $CPAN::Frontend->mysleep(5); |
| return; |
| } |
| } |
| } else { |
| $Du += (-s _); |
| } |
| } |
| }, |
| $dir |
| ); |
| } |
| return if $CPAN::Signal; |
| $self->{SIZE}{$dir} = $Du/1024/1024; |
| unshift @{$self->{FIFO}}, $dir; |
| $self->debug("measured $dir is $Du") if $CPAN::DEBUG; |
| $self->{DU} += $Du/1024/1024; |
| $self->{DU}; |
| } |
| |
| #-> sub CPAN::CacheMgr::_clean_cache ; |
| sub _clean_cache { |
| my($self,$dir) = @_; |
| return unless -e $dir; |
| unless (File::Spec->canonpath(File::Basename::dirname($dir)) |
| eq File::Spec->canonpath($CPAN::Config->{build_dir})) { |
| $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ". |
| "will not remove\n"); |
| $CPAN::Frontend->mysleep(5); |
| return; |
| } |
| $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") |
| if $CPAN::DEBUG; |
| File::Path::rmtree($dir); |
| my $id_deleted = 0; |
| if ($dir !~ /\.yml$/ && -f "$dir.yml") { |
| my $yaml_module = CPAN::_yaml_module(); |
| if ($CPAN::META->has_inst($yaml_module)) { |
| my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); }; |
| if ($@) { |
| $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)"); |
| unlink "$dir.yml" or |
| $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)"); |
| return; |
| } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) { |
| $CPAN::META->delete("CPAN::Distribution", $id); |
| |
| # XXX we should restore the state NOW, otherise this |
| # distro does not exist until we read an index. BUG ALERT(?) |
| |
| # $CPAN::Frontend->mywarn (" +++\n"); |
| $id_deleted++; |
| } |
| } |
| unlink "$dir.yml"; # may fail |
| unless ($id_deleted) { |
| CPAN->debug("no distro found associated with '$dir'"); |
| } |
| } |
| $self->{DU} -= $self->{SIZE}{$dir}; |
| delete $self->{SIZE}{$dir}; |
| } |
| |
| #-> sub CPAN::CacheMgr::new ; |
| sub new { |
| my($class,$phase) = @_; |
| $phase ||= "atstart"; |
| my $time = time; |
| my($debug,$t2); |
| $debug = ""; |
| my $self = { |
| ID => $CPAN::Config->{build_dir}, |
| MAX => $CPAN::Config->{'build_cache'}, |
| SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', |
| DU => 0 |
| }; |
| $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") |
| unless $self->{SCAN} =~ /never|atstart|atexit/; |
| File::Path::mkpath($self->{ID}); |
| my $dh = DirHandle->new($self->{ID}); |
| bless $self, $class; |
| $self->scan_cache($phase); |
| $t2 = time; |
| $debug .= "timing of CacheMgr->new: ".($t2 - $time); |
| $time = $t2; |
| CPAN->debug($debug) if $CPAN::DEBUG; |
| $self; |
| } |
| |
| #-> sub CPAN::CacheMgr::scan_cache ; |
| sub scan_cache { |
| my ($self, $phase) = @_; |
| $phase = '' unless defined $phase; |
| return unless $phase eq $self->{SCAN}; |
| return unless $CPAN::META->{LOCK}; |
| $CPAN::Frontend->myprint( |
| sprintf("Scanning cache %s for sizes\n", |
| $self->{ID})); |
| my $e; |
| my @entries = $self->entries($self->{ID}); |
| my $i = 0; |
| my $painted = 0; |
| for $e (@entries) { |
| my $symbol = "."; |
| if ($self->{DU} > $self->{MAX}) { |
| $symbol = "-"; |
| $self->disk_usage($e,1); |
| } else { |
| $self->disk_usage($e); |
| } |
| $i++; |
| while (($painted/76) < ($i/@entries)) { |
| $CPAN::Frontend->myprint($symbol); |
| $painted++; |
| } |
| return if $CPAN::Signal; |
| } |
| $CPAN::Frontend->myprint("DONE\n"); |
| $self->tidyup; |
| } |
| |
| 1; |