File Coverage

blib/lib/CPAN/CacheMgr.pm
Criterion Covered Total %
statement 18 154 11.6
branch 0 92 0.0
condition 0 13 0.0
subroutine 6 16 37.5
pod 2 8 25.0
total 26 283 9.1


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2             # vim: ts=4 sts=4 sw=4:
3             package CPAN::CacheMgr;
4 13     13   97 use strict;
  13         30  
  13         403  
5 13     13   70 use CPAN::InfoObj;
  13         26  
  13         442  
6             @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
7 13     13   74 use Cwd qw(chdir);
  13         37  
  13         792  
8 13     13   1729 use File::Find;
  13         27  
  13         858  
9              
10 13         743 use vars qw(
11             $VERSION
12 13     13   89 );
  13         23  
13             $VERSION = "5.5002";
14              
15             package CPAN::CacheMgr;
16 13     13   82 use strict;
  13         31  
  13         23011  
17              
18             #-> sub CPAN::CacheMgr::as_string ;
19             sub as_string {
20 0     0 1   eval { require Data::Dumper };
  0            
21 0 0         if ($@) {
22 0           return shift->SUPER::as_string;
23             } else {
24 0           return Data::Dumper::Dumper(shift);
25             }
26             }
27              
28             #-> sub CPAN::CacheMgr::cachesize ;
29             sub cachesize {
30 0     0 0   shift->{DU};
31             }
32              
33             #-> sub CPAN::CacheMgr::tidyup ;
34             sub tidyup {
35 0     0 0   my($self) = @_;
36 0 0         return unless $CPAN::META->{LOCK};
37 0 0         return unless -d $self->{ID};
38 0           my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
  0            
  0            
39 0           for my $current (0..$#toremove) {
40 0           my $toremove = $toremove[$current];
41 0           $CPAN::Frontend->myprint(sprintf(
42             "DEL(%d/%d): %s \n",
43             $current+1,
44             scalar @toremove,
45             $toremove,
46             )
47             );
48 0 0         return if $CPAN::Signal;
49 0           $self->_clean_cache($toremove);
50 0 0         return if $CPAN::Signal;
51             }
52 0           $self->{FIFO} = [];
53             }
54              
55             #-> sub CPAN::CacheMgr::dir ;
56             sub dir {
57 0     0 1   shift->{ID};
58             }
59              
60             #-> sub CPAN::CacheMgr::entries ;
61             sub entries {
62 0     0 0   my($self,$dir) = @_;
63 0 0         return unless defined $dir;
64 0 0         $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
65 0   0       $dir ||= $self->{ID};
66 0           my($cwd) = CPAN::anycwd();
67 0 0         chdir $dir or Carp::croak("Can't chdir to $dir: $!");
68 0 0         my $dh = DirHandle->new(File::Spec->curdir)
69             or Carp::croak("Couldn't opendir $dir: $!");
70 0           my(@entries);
71 0           for ($dh->read) {
72 0 0 0       next if $_ eq "." || $_ eq "..";
73 0 0         if (-f $_) {
    0          
74 0           push @entries, File::Spec->catfile($dir,$_);
75             } elsif (-d _) {
76 0           push @entries, File::Spec->catdir($dir,$_);
77             } else {
78 0           $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
79             }
80             }
81 0 0         chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
82 0           sort { -M $a <=> -M $b} @entries;
  0            
83             }
84              
85             #-> sub CPAN::CacheMgr::disk_usage ;
86             sub disk_usage {
87 0     0 0   my($self,$dir,$fast) = @_;
88 0 0         return if exists $self->{SIZE}{$dir};
89 0 0         return if $CPAN::Signal;
90 0           my($Du) = 0;
91 0 0         if (-e $dir) {
92 0 0         if (-d $dir) {
    0          
93 0 0         unless (-x $dir) {
94 0 0         unless (chmod 0755, $dir) {
95 0           $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 0           $CPAN::Frontend->mysleep(5);
99 0           return;
100             }
101             }
102             } elsif (-f $dir) {
103             # nothing to say, no matter what the permissions
104             }
105             } else {
106 0           $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
107 0           return;
108             }
109 0 0         if ($fast) {
110 0           $Du = 0; # placeholder
111             } else {
112             find(
113             sub {
114 0 0   0     $File::Find::prune++ if $CPAN::Signal;
115 0 0         return if -l $_;
116 0 0         if ($^O eq 'MacOS') {
117 0           require Mac::Files;
118 0           my $cat = Mac::Files::FSpGetCatInfo($_);
119 0 0         $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
120             } else {
121 0 0         if (-d _) {
122 0 0         unless (-x _) {
123 0 0         unless (chmod 0755, $_) {
124 0           $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 0           $CPAN::Frontend->mysleep(5);
129 0           return;
130             }
131             }
132             } else {
133 0           $Du += (-s _);
134             }
135             }
136             },
137 0           $dir
138             );
139             }
140 0 0         return if $CPAN::Signal;
141 0           $self->{SIZE}{$dir} = $Du/1024/1024;
142 0           unshift @{$self->{FIFO}}, $dir;
  0            
143 0 0         $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
144 0           $self->{DU} += $Du/1024/1024;
145 0           $self->{DU};
146             }
147              
148             #-> sub CPAN::CacheMgr::_clean_cache ;
149             sub _clean_cache {
150 0     0     my($self,$dir) = @_;
151 0 0         return unless -e $dir;
152 0 0         unless (File::Spec->canonpath(File::Basename::dirname($dir))
153             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
154 0           $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
155             "will not remove\n");
156 0           $CPAN::Frontend->mysleep(5);
157 0           return;
158             }
159 0 0         $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
160             if $CPAN::DEBUG;
161 0           File::Path::rmtree($dir);
162 0           my $id_deleted = 0;
163 0 0 0       if ($dir !~ /\.yml$/ && -f "$dir.yml") {
164 0           my $yaml_module = CPAN::_yaml_module();
165 0 0         if ($CPAN::META->has_inst($yaml_module)) {
166 0           my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
  0            
167 0 0         if ($@) {
    0          
168 0           $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
169 0 0         unlink "$dir.yml" or
170             $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
171 0           return;
172             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
173 0           $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 0           $id_deleted++;
180             }
181             }
182 0           unlink "$dir.yml"; # may fail
183 0 0         unless ($id_deleted) {
184 0           CPAN->debug("no distro found associated with '$dir'");
185             }
186             }
187 0           $self->{DU} -= $self->{SIZE}{$dir};
188 0           delete $self->{SIZE}{$dir};
189             }
190              
191             #-> sub CPAN::CacheMgr::new ;
192             sub new {
193 0     0 0   my($class,$phase) = @_;
194 0   0       $phase ||= "atstart";
195 0           my $time = time;
196 0           my($debug,$t2);
197 0           $debug = "";
198             my $self = {
199             ID => $CPAN::Config->{build_dir},
200             MAX => $CPAN::Config->{'build_cache'},
201 0   0       SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
202             DU => 0
203             };
204             $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
205 0 0         unless $self->{SCAN} =~ /never|atstart|atexit/;
206 0           File::Path::mkpath($self->{ID});
207 0           my $dh = DirHandle->new($self->{ID});
208 0           bless $self, $class;
209 0           $self->scan_cache($phase);
210 0           $t2 = time;
211 0           $debug .= "timing of CacheMgr->new: ".($t2 - $time);
212 0           $time = $t2;
213 0 0         CPAN->debug($debug) if $CPAN::DEBUG;
214 0           $self;
215             }
216              
217             #-> sub CPAN::CacheMgr::scan_cache ;
218             sub scan_cache {
219 0     0 0   my ($self, $phase) = @_;
220 0 0         $phase = '' unless defined $phase;
221 0 0         return unless $phase eq $self->{SCAN};
222 0 0         return unless $CPAN::META->{LOCK};
223             $CPAN::Frontend->myprint(
224             sprintf("Scanning cache %s for sizes\n",
225 0           $self->{ID}));
226 0           my $e;
227 0           my @entries = $self->entries($self->{ID});
228 0           my $i = 0;
229 0           my $painted = 0;
230 0           for $e (@entries) {
231 0           my $symbol = ".";
232 0 0         if ($self->{DU} > $self->{MAX}) {
233 0           $symbol = "-";
234 0           $self->disk_usage($e,1);
235             } else {
236 0           $self->disk_usage($e);
237             }
238 0           $i++;
239 0           while (($painted/76) < ($i/@entries)) {
240 0           $CPAN::Frontend->myprint($symbol);
241 0           $painted++;
242             }
243 0 0         return if $CPAN::Signal;
244             }
245 0           $CPAN::Frontend->myprint("DONE\n");
246 0           $self->tidyup;
247             }
248              
249             1;