1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- 2# vim: ts=4 sts=4 sw=4: 3package CPAN::CacheMgr; 4use strict; 5use CPAN::InfoObj; 6@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); 7use Cwd qw(chdir); 8use File::Find; 9 10use vars qw( 11 $VERSION 12); 13$VERSION = "5.5002"; 14 15package CPAN::CacheMgr; 16use strict; 17 18#-> sub CPAN::CacheMgr::as_string ; 19sub 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 ; 29sub cachesize { 30 shift->{DU}; 31} 32 33#-> sub CPAN::CacheMgr::tidyup ; 34sub 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 ; 56sub dir { 57 shift->{ID}; 58} 59 60#-> sub CPAN::CacheMgr::entries ; 61sub 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 ; 86sub 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 ; 149sub _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 ; 192sub 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 ; 218sub 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 2491; 250