Edit: /usr/share/perl5/CPAN/CacheMgr.pm (7537B)
# -*- 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.5";
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;
}
}
#-> 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 = shift;
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
};
File::Path::mkpath($self->{ID});
my $dh = DirHandle->new($self->{ID});
bless $self, $class;
$self->scan_cache;
$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 = shift;
return if $self->{SCAN} eq 'never';
$CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
unless $self->{SCAN} eq 'atstart';
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;