1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 # vim: ts=4 sts=4 sw=4:
3 package CPAN::CacheMgr;
6 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
15 package CPAN::CacheMgr;
18 #-> sub CPAN::CacheMgr::as_string ;
20 eval { require Data::Dumper };
22 return shift->SUPER::as_string;
24 return Data::Dumper::Dumper(shift);
28 #-> sub CPAN::CacheMgr::cachesize ;
33 #-> sub CPAN::CacheMgr::tidyup ;
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(
48 return if $CPAN::Signal;
49 $self->_clean_cache($toremove);
50 return if $CPAN::Signal;
54 #-> sub CPAN::CacheMgr::dir ;
59 #-> sub CPAN::CacheMgr::entries ;
62 return unless defined $dir;
63 $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
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: $!");
71 next if $_ eq "." || $_ eq "..";
73 push @entries, File::Spec->catfile($dir,$_);
75 push @entries, File::Spec->catdir($dir,$_);
77 $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
80 chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
81 sort { -M $a <=> -M $b} @entries;
84 #-> sub CPAN::CacheMgr::disk_usage ;
86 my($self,$dir,$fast) = @_;
87 return if exists $self->{SIZE}{$dir};
88 return if $CPAN::Signal;
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);
102 # nothing to say, no matter what the permissions
105 $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
109 $Du = 0; # placeholder
113 $File::Find::prune++ if $CPAN::Signal;
115 if ($^O eq 'MacOS') {
117 my $cat = Mac::Files::FSpGetCatInfo($_);
118 $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
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 ".
127 $CPAN::Frontend->mysleep(5);
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;
147 #-> sub CPAN::CacheMgr::_clean_cache ;
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);
158 $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
160 File::Path::rmtree($dir);
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"); };
167 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
169 $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
171 } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
172 $CPAN::META->delete("CPAN::Distribution", $id);
174 # XXX we should restore the state NOW, otherise this
175 # distro does not exist until we read an index. BUG ALERT(?)
177 # $CPAN::Frontend->mywarn (" +++\n");
181 unlink "$dir.yml"; # may fail
182 unless ($id_deleted) {
183 CPAN->debug("no distro found associated with '$dir'");
186 $self->{DU} -= $self->{SIZE}{$dir};
187 delete $self->{SIZE}{$dir};
190 #-> sub CPAN::CacheMgr::new ;
197 ID => $CPAN::Config->{build_dir},
198 MAX => $CPAN::Config->{'build_cache'},
199 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
202 File::Path::mkpath($self->{ID});
203 my $dh = DirHandle->new($self->{ID});
207 $debug .= "timing of CacheMgr->new: ".($t2 - $time);
209 CPAN->debug($debug) if $CPAN::DEBUG;
213 #-> sub CPAN::CacheMgr::scan_cache ;
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",
224 my @entries = $self->entries($self->{ID});
229 if ($self->{DU} > $self->{MAX}) {
231 $self->disk_usage($e,1);
233 $self->disk_usage($e);
236 while (($painted/76) < ($i/@entries)) {
237 $CPAN::Frontend->myprint($symbol);
240 return if $CPAN::Signal;
242 $CPAN::Frontend->myprint("DONE\n");