--- /dev/null
+# -*- 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.5";
+
+package CPAN::CacheMgr;
+use strict;
+
+#-> sub CPAN::CacheMgr::as_string ;
+sub as_string {
+ eval { require Data::Dumper };
+ if ($@) {
+ return shift->SUPER::as_string;
+ } else {
+ return Data::Dumper::Dumper(shift);
+ }
+}
+
+#-> sub CPAN::CacheMgr::cachesize ;
+sub cachesize {
+ shift->{DU};
+}
+
+#-> sub CPAN::CacheMgr::tidyup ;
+sub tidyup {
+ my($self) = @_;
+ return unless $CPAN::META->{LOCK};
+ return unless -d $self->{ID};
+ my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
+ for my $current (0..$#toremove) {
+ my $toremove = $toremove[$current];
+ $CPAN::Frontend->myprint(sprintf(
+ "DEL(%d/%d): %s \n",
+ $current+1,
+ scalar @toremove,
+ $toremove,
+ )
+ );
+ return if $CPAN::Signal;
+ $self->_clean_cache($toremove);
+ return if $CPAN::Signal;
+ }
+}
+
+#-> sub CPAN::CacheMgr::dir ;
+sub dir {
+ shift->{ID};
+}
+
+#-> sub CPAN::CacheMgr::entries ;
+sub entries {
+ my($self,$dir) = @_;
+ return unless defined $dir;
+ $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
+ $dir ||= $self->{ID};
+ my($cwd) = CPAN::anycwd();
+ chdir $dir or Carp::croak("Can't chdir to $dir: $!");
+ my $dh = DirHandle->new(File::Spec->curdir)
+ or Carp::croak("Couldn't opendir $dir: $!");
+ my(@entries);
+ for ($dh->read) {
+ next if $_ eq "." || $_ eq "..";
+ if (-f $_) {
+ push @entries, File::Spec->catfile($dir,$_);
+ } elsif (-d _) {
+ push @entries, File::Spec->catdir($dir,$_);
+ } else {
+ $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
+ }
+ }
+ chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
+ sort { -M $a <=> -M $b} @entries;
+}
+
+#-> sub CPAN::CacheMgr::disk_usage ;
+sub disk_usage {
+ my($self,$dir,$fast) = @_;
+ return if exists $self->{SIZE}{$dir};
+ return if $CPAN::Signal;
+ my($Du) = 0;
+ if (-e $dir) {
+ if (-d $dir) {
+ unless (-x $dir) {
+ unless (chmod 0755, $dir) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
+ "permission to change the permission; cannot ".
+ "estimate disk usage of '$dir'\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ } elsif (-f $dir) {
+ # nothing to say, no matter what the permissions
+ }
+ } else {
+ $CPAN::Frontend->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->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
+ } else {
+ if (-d _) {
+ unless (-x _) {
+ unless (chmod 0755, $_) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
+ "the permission to change the permission; ".
+ "can only partially estimate disk usage ".
+ "of '$_'\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ } else {
+ $Du += (-s _);
+ }
+ }
+ },
+ $dir
+ );
+ }
+ return if $CPAN::Signal;
+ $self->{SIZE}{$dir} = $Du/1024/1024;
+ unshift @{$self->{FIFO}}, $dir;
+ $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
+ $self->{DU} += $Du/1024/1024;
+ $self->{DU};
+}
+
+#-> sub CPAN::CacheMgr::_clean_cache ;
+sub _clean_cache {
+ my($self,$dir) = @_;
+ return unless -e $dir;
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
+ $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
+ "will not remove\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
+ if $CPAN::DEBUG;
+ File::Path::rmtree($dir);
+ my $id_deleted = 0;
+ if ($dir !~ /\.yml$/ && -f "$dir.yml") {
+ my $yaml_module = CPAN::_yaml_module();
+ if ($CPAN::META->has_inst($yaml_module)) {
+ my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
+ if ($@) {
+ $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
+ unlink "$dir.yml" or
+ $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
+ return;
+ } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
+ $CPAN::META->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->mywarn (" +++\n");
+ $id_deleted++;
+ }
+ }
+ unlink "$dir.yml"; # may fail
+ unless ($id_deleted) {
+ CPAN->debug("no distro found associated with '$dir'");
+ }
+ }
+ $self->{DU} -= $self->{SIZE}{$dir};
+ delete $self->{SIZE}{$dir};
+}
+
+#-> sub CPAN::CacheMgr::new ;
+sub new {
+ my $class = shift;
+ my $time = time;
+ my($debug,$t2);
+ $debug = "";
+ my $self = {
+ ID => $CPAN::Config->{build_dir},
+ MAX => $CPAN::Config->{'build_cache'},
+ SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
+ DU => 0
+ };
+ File::Path::mkpath($self->{ID});
+ my $dh = DirHandle->new($self->{ID});
+ bless $self, $class;
+ $self->scan_cache;
+ $t2 = time;
+ $debug .= "timing of CacheMgr->new: ".($t2 - $time);
+ $time = $t2;
+ CPAN->debug($debug) if $CPAN::DEBUG;
+ $self;
+}
+
+#-> sub CPAN::CacheMgr::scan_cache ;
+sub scan_cache {
+ my $self = shift;
+ return if $self->{SCAN} eq 'never';
+ $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
+ unless $self->{SCAN} eq 'atstart';
+ return unless $CPAN::META->{LOCK};
+ $CPAN::Frontend->myprint(
+ sprintf("Scanning cache %s for sizes\n",
+ $self->{ID}));
+ my $e;
+ my @entries = $self->entries($self->{ID});
+ my $i = 0;
+ my $painted = 0;
+ for $e (@entries) {
+ my $symbol = ".";
+ if ($self->{DU} > $self->{MAX}) {
+ $symbol = "-";
+ $self->disk_usage($e,1);
+ } else {
+ $self->disk_usage($e);
+ }
+ $i++;
+ while (($painted/76) < ($i/@entries)) {
+ $CPAN::Frontend->myprint($symbol);
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+ $self->tidyup;
+}
+
+1;
projects / catagits/Gitalist.git / blobdiff