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