<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::CacheMgr;
use strict;
use CPAN::InfoObj;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use Cwd qw(chdir);
use File::Find;

use vars qw(
            $VERSION
);
$VERSION = "5.5001";

package CPAN::CacheMgr;
use strict;

#-&gt; sub CPAN::CacheMgr::as_string ;
sub as_string {
    eval { require Data::Dumper };
    if ($@) {
        return shift-&gt;SUPER::as_string;
    } else {
        return Data::Dumper::Dumper(shift);
    }
}

#-&gt; sub CPAN::CacheMgr::cachesize ;
sub cachesize {
    shift-&gt;{DU};
}

#-&gt; sub CPAN::CacheMgr::tidyup ;
sub tidyup {
  my($self) = @_;
  return unless $CPAN::META-&gt;{LOCK};
  return unless -d $self-&gt;{ID};
  my @toremove = grep { $self-&gt;{SIZE}{$_}==0 } @{$self-&gt;{FIFO}};
  for my $current (0..$#toremove) {
    my $toremove = $toremove[$current];
    $CPAN::Frontend-&gt;myprint(sprintf(
                                     "DEL(%d/%d): %s \n",
                                     $current+1,
                                     scalar @toremove,
                                     $toremove,
                                    )
                            );
    return if $CPAN::Signal;
    $self-&gt;_clean_cache($toremove);
    return if $CPAN::Signal;
  }
  $self-&gt;{FIFO} = [];
}

#-&gt; sub CPAN::CacheMgr::dir ;
sub dir {
    shift-&gt;{ID};
}

#-&gt; sub CPAN::CacheMgr::entries ;
sub entries {
    my($self,$dir) = @_;
    return unless defined $dir;
    $self-&gt;debug("reading dir[$dir]") if $CPAN::DEBUG;
    $dir ||= $self-&gt;{ID};
    my($cwd) = CPAN::anycwd();
    chdir $dir or Carp::croak("Can't chdir to $dir: $!");
    my $dh = DirHandle-&gt;new(File::Spec-&gt;curdir)
        or Carp::croak("Couldn't opendir $dir: $!");
    my(@entries);
    for ($dh-&gt;read) {
        next if $_ eq "." || $_ eq "..";
        if (-f $_) {
            push @entries, File::Spec-&gt;catfile($dir,$_);
        } elsif (-d _) {
            push @entries, File::Spec-&gt;catdir($dir,$_);
        } else {
            $CPAN::Frontend-&gt;mywarn("Warning: weird direntry in $dir: $_\n");
        }
    }
    chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
    sort { -M $a &lt;=&gt; -M $b} @entries;
}

#-&gt; sub CPAN::CacheMgr::disk_usage ;
sub disk_usage {
    my($self,$dir,$fast) = @_;
    return if exists $self-&gt;{SIZE}{$dir};
    return if $CPAN::Signal;
    my($Du) = 0;
    if (-e $dir) {
        if (-d $dir) {
            unless (-x $dir) {
                unless (chmod 0755, $dir) {
                    $CPAN::Frontend-&gt;mywarn("I have neither the -x permission nor the ".
                                            "permission to change the permission; cannot ".
                                            "estimate disk usage of '$dir'\n");
                    $CPAN::Frontend-&gt;mysleep(5);
                    return;
                }
            }
        } elsif (-f $dir) {
            # nothing to say, no matter what the permissions
        }
    } else {
        $CPAN::Frontend-&gt;mywarn("File or directory '$dir' has gone, ignoring\n");
        return;
    }
    if ($fast) {
        $Du = 0; # placeholder
    } else {
        find(
             sub {
           $File::Find::prune++ if $CPAN::Signal;
           return if -l $_;
           if ($^O eq 'MacOS') {
             require Mac::Files;
             my $cat  = Mac::Files::FSpGetCatInfo($_);
             $Du += $cat-&gt;ioFlLgLen() + $cat-&gt;ioFlRLgLen() if $cat;
           } else {
             if (-d _) {
               unless (-x _) {
                 unless (chmod 0755, $_) {
                   $CPAN::Frontend-&gt;mywarn("I have neither the -x permission nor ".
                                           "the permission to change the permission; ".
                                           "can only partially estimate disk usage ".
                                           "of '$_'\n");
                   $CPAN::Frontend-&gt;mysleep(5);
                   return;
                 }
               }
             } else {
               $Du += (-s _);
             }
           }
         },
         $dir
            );
    }
    return if $CPAN::Signal;
    $self-&gt;{SIZE}{$dir} = $Du/1024/1024;
    unshift @{$self-&gt;{FIFO}}, $dir;
    $self-&gt;debug("measured $dir is $Du") if $CPAN::DEBUG;
    $self-&gt;{DU} += $Du/1024/1024;
    $self-&gt;{DU};
}

#-&gt; sub CPAN::CacheMgr::_clean_cache ;
sub _clean_cache {
    my($self,$dir) = @_;
    return unless -e $dir;
    unless (File::Spec-&gt;canonpath(File::Basename::dirname($dir))
            eq File::Spec-&gt;canonpath($CPAN::Config-&gt;{build_dir})) {
        $CPAN::Frontend-&gt;mywarn("Directory '$dir' not below $CPAN::Config-&gt;{build_dir}, ".
                                "will not remove\n");
        $CPAN::Frontend-&gt;mysleep(5);
        return;
    }
    $self-&gt;debug("have to rmtree $dir, will free $self-&gt;{SIZE}{$dir}")
        if $CPAN::DEBUG;
    File::Path::rmtree($dir);
    my $id_deleted = 0;
    if ($dir !~ /\.yml$/ &amp;&amp; -f "$dir.yml") {
        my $yaml_module = CPAN::_yaml_module();
        if ($CPAN::META-&gt;has_inst($yaml_module)) {
            my($peek_yaml) = eval { CPAN-&gt;_yaml_loadfile("$dir.yml"); };
            if ($@) {
                $CPAN::Frontend-&gt;mywarn("(parse error on '$dir.yml' removing anyway)");
                unlink "$dir.yml" or
                    $CPAN::Frontend-&gt;mywarn("(Could not unlink '$dir.yml': $!)");
                return;
            } elsif (my $id = $peek_yaml-&gt;[0]{distribution}{ID}) {
                $CPAN::META-&gt;delete("CPAN::Distribution", $id);

                # XXX we should restore the state NOW, otherise this
                # distro does not exist until we read an index. BUG ALERT(?)

                # $CPAN::Frontend-&gt;mywarn (" +++\n");
                $id_deleted++;
            }
        }
        unlink "$dir.yml"; # may fail
        unless ($id_deleted) {
            CPAN-&gt;debug("no distro found associated with '$dir'");
        }
    }
    $self-&gt;{DU} -= $self-&gt;{SIZE}{$dir};
    delete $self-&gt;{SIZE}{$dir};
}

#-&gt; sub CPAN::CacheMgr::new ;
sub new {
    my($class,$phase) = @_;
    $phase ||= "atstart";
    my $time = time;
    my($debug,$t2);
    $debug = "";
    my $self = {
        ID =&gt; $CPAN::Config-&gt;{build_dir},
        MAX =&gt; $CPAN::Config-&gt;{'build_cache'},
        SCAN =&gt; $CPAN::Config-&gt;{'scan_cache'} || 'atstart',
        DU =&gt; 0
    };
    $CPAN::Frontend-&gt;mydie("Unknown scan_cache argument: $self-&gt;{SCAN}")
        unless $self-&gt;{SCAN} =~ /never|atstart|atexit/;
    File::Path::mkpath($self-&gt;{ID});
    my $dh = DirHandle-&gt;new($self-&gt;{ID});
    bless $self, $class;
    $self-&gt;scan_cache($phase);
    $t2 = time;
    $debug .= "timing of CacheMgr-&gt;new: ".($t2 - $time);
    $time = $t2;
    CPAN-&gt;debug($debug) if $CPAN::DEBUG;
    $self;
}

#-&gt; sub CPAN::CacheMgr::scan_cache ;
sub scan_cache {
    my ($self, $phase) = @_;
    $phase = '' unless defined $phase;
    return unless $phase eq $self-&gt;{SCAN};
    return unless $CPAN::META-&gt;{LOCK};
    $CPAN::Frontend-&gt;myprint(
                             sprintf("Scanning cache %s for sizes\n",
                             $self-&gt;{ID}));
    my $e;
    my @entries = $self-&gt;entries($self-&gt;{ID});
    my $i = 0;
    my $painted = 0;
    for $e (@entries) {
        my $symbol = ".";
        if ($self-&gt;{DU} &gt; $self-&gt;{MAX}) {
            $symbol = "-";
            $self-&gt;disk_usage($e,1);
        } else {
            $self-&gt;disk_usage($e);
        }
        $i++;
        while (($painted/76) &lt; ($i/@entries)) {
            $CPAN::Frontend-&gt;myprint($symbol);
            $painted++;
        }
        return if $CPAN::Signal;
    }
    $CPAN::Frontend-&gt;myprint("DONE\n");
    $self-&gt;tidyup;
}

1;
</pre></body></html>