Commit | Line | Data |
---|---|---|
f9916dde A |
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; |