From 316ee97c621496b0fe3267f57cce81bee44ca1e6 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Thu, 17 Feb 2011 12:20:49 +0000 Subject: Moving old tlperl prior to committing new one git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm | 246 ------------------------------- 1 file changed, 246 deletions(-) delete mode 100755 Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm (limited to 'Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm') 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; -- cgit v1.2.3