Commit | Line | Data |
f9916dde |
1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
2 | # vim: ts=4 sts=4 sw=4: |
3 | package CPAN::CacheMgr; |
4 | use strict; |
5 | use CPAN::InfoObj; |
6 | @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); |
7 | use Cwd qw(chdir); |
8 | use File::Find; |
9 | |
10 | use vars qw( |
11 | $VERSION |
12 | ); |
13 | $VERSION = "5.5"; |
14 | |
15 | package CPAN::CacheMgr; |
16 | use strict; |
17 | |
18 | #-> sub CPAN::CacheMgr::as_string ; |
19 | sub 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 ; |
29 | sub cachesize { |
30 | shift->{DU}; |
31 | } |
32 | |
33 | #-> sub CPAN::CacheMgr::tidyup ; |
34 | sub 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 | } |
53 | |
54 | #-> sub CPAN::CacheMgr::dir ; |
55 | sub dir { |
56 | shift->{ID}; |
57 | } |
58 | |
59 | #-> sub CPAN::CacheMgr::entries ; |
60 | sub entries { |
61 | my($self,$dir) = @_; |
62 | return unless defined $dir; |
63 | $self->debug("reading dir[$dir]") if $CPAN::DEBUG; |
64 | $dir ||= $self->{ID}; |
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: $!"); |
69 | my(@entries); |
70 | for ($dh->read) { |
71 | next if $_ eq "." || $_ eq ".."; |
72 | if (-f $_) { |
73 | push @entries, File::Spec->catfile($dir,$_); |
74 | } elsif (-d _) { |
75 | push @entries, File::Spec->catdir($dir,$_); |
76 | } else { |
77 | $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); |
78 | } |
79 | } |
80 | chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); |
81 | sort { -M $a <=> -M $b} @entries; |
82 | } |
83 | |
84 | #-> sub CPAN::CacheMgr::disk_usage ; |
85 | sub disk_usage { |
86 | my($self,$dir,$fast) = @_; |
87 | return if exists $self->{SIZE}{$dir}; |
88 | return if $CPAN::Signal; |
89 | my($Du) = 0; |
90 | if (-e $dir) { |
91 | if (-d $dir) { |
92 | unless (-x $dir) { |
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); |
98 | return; |
99 | } |
100 | } |
101 | } elsif (-f $dir) { |
102 | # nothing to say, no matter what the permissions |
103 | } |
104 | } else { |
105 | $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n"); |
106 | return; |
107 | } |
108 | if ($fast) { |
109 | $Du = 0; # placeholder |
110 | } else { |
111 | find( |
112 | sub { |
113 | $File::Find::prune++ if $CPAN::Signal; |
114 | return if -l $_; |
115 | if ($^O eq 'MacOS') { |
116 | require Mac::Files; |
117 | my $cat = Mac::Files::FSpGetCatInfo($_); |
118 | $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat; |
119 | } else { |
120 | if (-d _) { |
121 | unless (-x _) { |
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 ". |
126 | "of '$_'\n"); |
127 | $CPAN::Frontend->mysleep(5); |
128 | return; |
129 | } |
130 | } |
131 | } else { |
132 | $Du += (-s _); |
133 | } |
134 | } |
135 | }, |
136 | $dir |
137 | ); |
138 | } |
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; |
144 | $self->{DU}; |
145 | } |
146 | |
147 | #-> sub CPAN::CacheMgr::_clean_cache ; |
148 | sub _clean_cache { |
149 | my($self,$dir) = @_; |
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); |
156 | return; |
157 | } |
158 | $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") |
159 | if $CPAN::DEBUG; |
160 | File::Path::rmtree($dir); |
161 | my $id_deleted = 0; |
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"); }; |
166 | if ($@) { |
167 | $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)"); |
168 | unlink "$dir.yml" or |
169 | $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)"); |
170 | return; |
171 | } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) { |
172 | $CPAN::META->delete("CPAN::Distribution", $id); |
173 | |
174 | # XXX we should restore the state NOW, otherise this |
175 | # distro does not exist until we read an index. BUG ALERT(?) |
176 | |
177 | # $CPAN::Frontend->mywarn (" +++\n"); |
178 | $id_deleted++; |
179 | } |
180 | } |
181 | unlink "$dir.yml"; # may fail |
182 | unless ($id_deleted) { |
183 | CPAN->debug("no distro found associated with '$dir'"); |
184 | } |
185 | } |
186 | $self->{DU} -= $self->{SIZE}{$dir}; |
187 | delete $self->{SIZE}{$dir}; |
188 | } |
189 | |
190 | #-> sub CPAN::CacheMgr::new ; |
191 | sub new { |
192 | my $class = shift; |
193 | my $time = time; |
194 | my($debug,$t2); |
195 | $debug = ""; |
196 | my $self = { |
197 | ID => $CPAN::Config->{build_dir}, |
198 | MAX => $CPAN::Config->{'build_cache'}, |
199 | SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', |
200 | DU => 0 |
201 | }; |
202 | File::Path::mkpath($self->{ID}); |
203 | my $dh = DirHandle->new($self->{ID}); |
204 | bless $self, $class; |
205 | $self->scan_cache; |
206 | $t2 = time; |
207 | $debug .= "timing of CacheMgr->new: ".($t2 - $time); |
208 | $time = $t2; |
209 | CPAN->debug($debug) if $CPAN::DEBUG; |
210 | $self; |
211 | } |
212 | |
213 | #-> sub CPAN::CacheMgr::scan_cache ; |
214 | sub scan_cache { |
215 | my $self = shift; |
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", |
222 | $self->{ID})); |
223 | my $e; |
224 | my @entries = $self->entries($self->{ID}); |
225 | my $i = 0; |
226 | my $painted = 0; |
227 | for $e (@entries) { |
228 | my $symbol = "."; |
229 | if ($self->{DU} > $self->{MAX}) { |
230 | $symbol = "-"; |
231 | $self->disk_usage($e,1); |
232 | } else { |
233 | $self->disk_usage($e); |
234 | } |
235 | $i++; |
236 | while (($painted/76) < ($i/@entries)) { |
237 | $CPAN::Frontend->myprint($symbol); |
238 | $painted++; |
239 | } |
240 | return if $CPAN::Signal; |
241 | } |
242 | $CPAN::Frontend->myprint("DONE\n"); |
243 | $self->tidyup; |
244 | } |
245 | |
246 | 1; |