summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff)
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/CacheMgr.pm246
1 files changed, 0 insertions, 246 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm b/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
deleted file mode 100755
index 827baeaefdb..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
+++ /dev/null
@@ -1,246 +0,0 @@
-# -*- 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;