Sorry inserting two times the chmod $tmpfile, oct(600); does not help. The same error message appears on the following tie command. I attache my modified version to ensure I made no error while changing the code. For your convenience, all my modifications are between comment # my modifications - begin and # my modifications - end.
Thanks Chris
#!/usr/bin/perl # apt-cacher-cleanup.pl # # Script to clean the apt-cacher cache. # # Copyright (C) 2007-14, Mark Hindley <[email protected]> # Copyright (C) 2005, Eduard Bloch <[email protected]> # Copyright (C) 2002-03, Jonathan Oxer <[email protected]> # Portions (C) 2002, Jacob Lundberg <[email protected]> # # Distributed under the terms of the GNU Public Licence (GPL). use strict; use warnings; use lib '/usr/share/apt-cacher/lib'; use sigtrap qw(die normal-signals); use Cwd (); use Fcntl qw/:DEFAULT :flock F_SETFD/; use Getopt::Long qw(:config no_ignore_case); use Digest::SHA; use HTTP::Date (); use HTTP::Response; use IO::Uncompress::AnyUncompress qw($AnyUncompressError); use IO::Compress::Bzip2; use IO::Compress::Gzip; my $configfile = '/etc/apt-cacher/apt-cacher.conf'; my $nice_mode=0; my $verbose=0; my $help; my $force; my $sim_mode=0; my $offline=0; my $pdiff_mode=0; my $db_recover=0; my @db_mode; my $patchprog = 'red -s'; my %options = ( "h|help" => \$help, "n|nice" => \$nice_mode, "v|verbose" => \$verbose, "f|force" => \$force, "c|cfg|conf=s" => \$configfile, "s|simulate" => \$sim_mode, "o|offline" => \$offline, "p|pdiff" => \$pdiff_mode, "r|recover" => \$db_recover, "d|db=s{,}" => \@db_mode ); { # Scoping block local @ARGV = @ARGV; # Use a local copy in case required for rexec if (!GetOptions(%options) || $help) { die <<EOM Usage: $0 [-c|cfg|conf <configfile>] [-n|nice] [-s|simulate] [-v|verbose] [-o|offline] [-f|force] [-r|recover] ][-d|db <command> [<arg>]] Options: -n Renice (and ionice, if possible) to lowest priority and continue. -s Simulate and just show what would be done. -o Don't update index files. Overrides offline_mode from configfile. -p Try to update index files by patching. -v Verbose. -f Force execution, disable sanity checks. -r Attempt recovery of corrupt checksum database. -d <command> [<arg>] Manipulate checksum database. Available commands are: dump print db contents search <arg> print entries matching regexp delete <arg> delete entries matching regexp import read new checksum data from Packages and Sources files in cache_dir compact clean and compact database failcheck remove locks left by failed process verify verify the database EOM } } if ($sim_mode) { $verbose = 1; print "Simulation mode. Just printing what would be done.\n"; } local $SIG{CHLD} = 'IGNORE'; # Auto reap children ############################################################################# ### configuration ########################################################### # Include the library for the config file parser require('apt-cacher.pl'); # Read in the config file and set the necessary variables # $cfg needs to be global for setup_ownership our $cfg = eval{ read_config($configfile) }; # not sure what to do if we can't read the config file... die "Could not read configuration file '$configfile': $@" if $@; private_config(); # check whether we're actually meant to clean the cache if ( $cfg->{clean_cache} ne 1 ) { printmsg("Maintenance disallowed by configuration item clean_cache\n"); exit 0; } check_install(); # Before we give up rights # change uid and gid if root and another user/group configured if (($cfg->{user} && $cfg->{user} !~ 'root' && !$> ) || ($cfg->{group} && $cfg->{group} !~ 'root' && !$) =~ /^0/)){ printmsg("Invoked as root, changing to $cfg->{user}:$cfg->{group} and re-execing.\n"); setup_ownership($cfg); # Rexec to ensure /proc/self/fd ownerships correct which are needed for red # patching with pdiffs exec($0, @ARGV) or die "Unable to rexec $0: $!\n"; } # Output data as soon as we print it local $| = 1; load_checksum(); # Will disable checksum if BerkeleyDB not available if ($nice_mode) { printmsg("Nice mode\n"); setpriority 0, 0, 20; use Linux::IO_Prio qw(:all); ioprio_set(IOPRIO_WHO_PROCESS, $$,IOPRIO_PRIO_VALUE(IOPRIO_CLASS_IDLE, 0)) == 0 || printmsg("ioprio_set failed: $!\n"); } sub printmsg { my @args = @_; my $ret; $ret = print @args if $verbose; return $ret; } sub open_lock { my ($file) = @_; my $retried; TRY: # Lock header LOCK_EX first to block apt-cacher from working on it open(my $hfh, '+<', "../headers/$file") || do { if ($!{ENOENT} && !$retried && !$offline) { printmsg ("../headers/$file missing. Attempting download\n"); get($file); $retried = 1; goto TRY; } warn ("Error: cannot open ../headers/$file for locking: $!\n"); return; }; _flock($hfh, LOCK_EX) || die "Lock ../headers/$file failed: $!"; # Read lock file LOCK_SH open(my $cfh, '+<', $file) || do { warn ("Error: cannot open $file for locking: $!\n"); return; }; _flock($cfh, LOCK_SH) || die "Lock $file failed: $!"; return ($cfh, $hfh); } sub get { my ($file, $use_url) = @_; my $path_info; # use path if stored in cached header/complete file if($use_url && (my $url = get_original_url($file))) { $path_info= $url; } else { $path_info=$file; $path_info=~s/^/\//; $path_info=~s/_/\//g; } defined(my $refresh_pid = open(my $fh, '|-')) || die "Failed to open refresh pipe: $!"; if ($refresh_pid){ printmsg "Get $path_info\n"; print $fh "$_\r\n" foreach ("HEAD $path_info", 'Cache-Control: max-age=0', 'Connection: Close', ''); close($fh); } else { close (STDOUT); open (STDOUT, '>', '/dev/null') || die $!; local $ENV{REMOTE_ADDR} = 'CLEANUPREFRESH'; local @ARGV = ('-i', '-c', $configfile); do '/usr/share/apt-cacher/apt-cacher'; } waitpid($refresh_pid,0); if(($? > 0) && ! $force) { die "Unable to update $path_info (status: $?).\nCleanup aborted to prevent deletion of cached data.\n"; } return $?; } sub pdiff { my ($name) = @_; if (!-f $name) { warn ("File $name not found\n"); return; } if ($name !~ /main|contrib|non-free/) { printmsg "Upstream repository for $name not standard hierarchy, skipping attempting to patch\n"; return; } my ($basename,$type) = ($name =~ /(^.+?)(\.(?:bz2|gz))?$/); (my $release = $basename) =~ s/(?:main|contrib|non-free).*$/{In,}Release/; (my $diffindex = $basename) .= '.diff_Index'; my ($release_fh, $diffin_fh); foreach my $glob_fh ([\$release, \$release_fh], [\$diffindex, \$diffin_fh]) { foreach my $file (glob(${$glob_fh->[0]})) { get($file) unless $offline; # Don't use open_lock(), it is too noisy if (open(${$glob_fh->[1]}, '<', $file)) { ${$glob_fh->[0]} = $file; last; } else { printmsg("Failed to open $file: $!\n"); } } return unless ${$glob_fh->[1]}->opened; _flock(${$glob_fh->[1]}, LOCK_SH) || die("Cannot lock ${$glob_fh->[0]}: $!"); } # Read Release file (my $diffindex_patt = $diffindex) =~ s/^.*(main|contrib|non-free.*)/$1/; (my $name_patt = $name) =~ s/^.*(main|contrib|non-free.*)/$1/; for ($diffindex_patt, $name_patt) { s/_/\//g; } # printmsg "Searching $release for $diffindex_patt and $name_patt\n"; my ($diffindex_sha1, $name_sha1, $name_size); while (<$release_fh>) { if (/^\s(\w{40})\s+\d+\s$diffindex_patt\n/) { $diffindex_sha1 = $1; # printmsg "Found! $diffindex_patt $1\n"; } elsif (/^\s(\w{40})\s+(\d+)\s$name_patt\n/) { $name_sha1 = $1; $name_size = $2; # printmsg "Found! $name_patt $1 $2\n"; } last if ($name_sha1 && $diffindex_sha1); } _flock($release_fh, LOCK_UN); close($release_fh); if (!$name_sha1 || !$name_size || !$diffindex_sha1) { warn "SHA1s for $name_patt and/or $diffindex_patt not found in $release, aborting patch\n"; return; } my $sha1 = Digest::SHA->new(1); # SHA1 my $digest; (my ($cfh, $hfh) = open_lock($name)) == 2 || do { warn "Failed to open filehandles for $name, aborting patch\n"; return; }; # Check size first if (-s $cfh == $name_size) { printmsg ("$name matches size in $release, going on to check SHA1..\n"); # Check SHA1 only if size correct $digest = $sha1->addfile($cfh)->hexdigest; if ($digest eq $name_sha1) { printmsg "$name already matches SHA1 in $release: patching not required\n"; return 1 # success } else { printmsg "$name SHA1 not latest: proceeding with patch\n"; } } else { printmsg ("$name size not latest, proceeding with patch\n"); } my $raw = IO::Uncompress::AnyUncompress->new($cfh) or die "Decompression failed: $AnyUncompressError\n"; open (my $tfh, "+>", undef)|| die "Unable to open temp file: $!"; printmsg "Reading $basename...\n"; while (<$raw>){ last if $AnyUncompressError; print $tfh $_; $sha1->add($_); } close($raw); if ($AnyUncompressError) { warn "$name read failed: $AnyUncompressError. Aborting patch\n"; return; } $digest = $sha1->hexdigest; # printmsg "$basename SHA1: $digest\n"; # Read diff_Index my (@hist, @patch); my $diffindex_digest = $sha1->addfile($diffin_fh)->hexdigest; if ($diffindex_digest ne $diffindex_sha1) { _flock($diffin_fh, LOCK_UN); close ($diffin_fh); if ($force) { warn "$diffindex incorrect SHA1: expected $diffindex_sha1, got $diffindex_digest. Continuing anyway as --force specified\n"; } else { warn "$diffindex incorrect SHA1: expected $diffindex_sha1, got $diffindex_digest. Aborting patch. Use --force to ignore\n"; return; } } seek($diffin_fh,0,0) || die "Seek failed: $!"; # rewind my $curr= <$diffin_fh>; # read first line chomp $curr; # remove trailing \n # printmsg "$diffindex: $curr\n"; my ($target_sha1, $target_size) = (split (/\s+/,$curr))[1,2]; if ($digest eq $target_sha1) { # check this matches /SHA1/ printmsg "SHA1 match: $name already up to date\n"; _flock($diffin_fh, LOCK_UN); close ($diffin_fh); return 1; # success } else { while (<$diffin_fh>) { next if (/^SHA1-History:/); # skip header last if (/^SHA1-Patches:/);# end of history push @hist, $_; next; } while (<$diffin_fh>) { push @patch, $_; # To EOF next; } } _flock($diffin_fh, LOCK_UN); close ($diffin_fh); my $diff; my $count=0; for (@hist) { my @line; @line = split; # printmsg "Checking $digest against @line\n"; if ($digest eq $line[0]) { # printmsg "found SHA1 match at \$hist $count: $line[0]\n"; $diff = $count; last } $count++; } if (!defined $diff) { warn "$name SHA1 not found in diff_Index, aborting patch\n"; return; } my $diffs=''; # Initialise to work around perl bug giving "Use of uninitialized value error" open(my $diffs_fh, ">", \$diffs) || die "Failed to open in memory diff file: $!"; for (@patch[$diff .. $#patch]) { my ($pdiffsha1, $size, $suff) = split; my $pdiff = "$basename.diff_$suff.gz"; if (!-f $pdiff) { if (!$offline) { get($pdiff); } if (!-f $pdiff) { warn("$pdiff not available, aborting patch"); return; } } printmsg "Reading $pdiff\n"; if ((my ($pdfh, undef) = open_lock($pdiff)) == 2) { my $zpdfh = IO::Uncompress::AnyUncompress->new($pdfh) or die "Decompression failed: $AnyUncompressError\n"; while (<$zpdfh>) { last if $AnyUncompressError; print $diffs_fh $_; $sha1->add($_); } } else { die "Failed to open $pdiff for locking: $!"; } if ($AnyUncompressError) { warn "$pdiff read failed: $AnyUncompressError. Aborting patch\n"; return; } my $pdiffdigest = $sha1->hexdigest; # printmsg "$pdiff SHA1: $pdiffdigest\n"; if ($pdiffsha1 ne $pdiffdigest) { warn "$pdiff SHA1 incorrect: got $pdiffdigest, expected $pdiffsha1, aborting patch"; return; } } close($diffs_fh); fcntl($tfh, F_SETFD, 0) or die "Can't clear close-on-exec flag on temp filehandle: $!\n"; my $cwd = Cwd::cwd(); # Save chdir '/proc/self/fd' or die "Unable to change working directory: $!"; open(my $patchpipe, '|-', "$patchprog ".fileno($tfh).($verbose ? '' : ' 2>/dev/null')) || die "Unable to open pipe for patch: $!"; printmsg "Patching $name with $patchprog\n"; print $patchpipe $diffs; print $patchpipe "w\n"; # ed write command close($patchpipe); chdir $cwd or die "Unable to restore working directory: $!"; # Restore my $rstat =($? >> 8); if ($rstat) { warn "Patching failed (exit code $rstat), aborting\n"; return; } printmsg "Verifying patched file\n"; if (-s $tfh != $target_size) { warn "$name patching failed! $tfh is not size $target_size\n"; return; } seek($tfh,0,0) || die "Seek failed: $!"; # rewind $sha1->addfile($tfh); $digest=$sha1->hexdigest; if ($digest eq $target_sha1) { printmsg "Success! SHA1: $digest\n"; if ($sim_mode) { printmsg "Simulation mode, so not replacing existing files\n"; } else { printmsg "Saving as $name\n"; seek($tfh, 0, 0) || die "Seek failed: $!"; # rewind truncate($cfh, 0) || die "Truncate failed: $!"; seek($cfh, 0, 0) || die "Seek failed: $!"; my ($z,$encoding) = ($name=~/bz2$/ ? ((IO::Compress::Bzip2->new($cfh)), "x-bzip2") : ($name=~/gz$/ ? ((IO::Compress::Gzip->new($cfh, -Level => 9)), "x-gzip") : $cfh)); while (<$tfh>) { $z->print($_); } close($z); $cfh->flush; # So the size is correct my $datestring = HTTP::Date::time2str; my $response = HTTP::Response->new(200, 'OK', ['Date' => $datestring, 'Content-Length' => -s $cfh, 'Content-Type' => 'text/plain', 'Last-Modified' => $datestring]); $response->header('Content-Encoding' => $encoding) if $encoding;; write_header($hfh, $response); _flock($cfh, LOCK_SH); # Downgrade _flock($hfh, LOCK_UN); # Read checksums if ($cfg->{checksum}) { printmsg ("Importing new checksums from patched $name\n"); import_sums($name, $cfh); } } } else { warn "$name patching failed! Patched SHA1 is $digest, expecting $target_sha1\n"; return; } close $tfh; return 1; # success } # Calls _db_compact to do the work and reports results # Arg: DB handle ref sub db_compact { my ($dbh) = @_; printmsg "Compacting checksum database....\n"; while (my ($status, %results) = @{_db_compact($dbh)}) { if ($status) { printmsg "db_compact failed: $status\n"; last; } else { printmsg " Compacted ". $results{compact_pages_free} ." pages\n Freed ". $results{compact_pages_truncated} ." pages\n"; if ($results{compact_pages_free} + $results{compact_pages_truncated} == 0) { printmsg "Done!\n"; last; } } } return; } ############################################################################# # Manipulate checksum database if (@db_mode || $db_recover){ my $ok_chars = '-a-zA-Z0-9+_.,~^$*?{}[]()'; # Acceptable characters for user input $ok_chars .= '/' if $cfg->{distinct_namespaces}; print "Checksum database mode\n"; if (!$cfg->{checksum}) { die "$0: checksumming not enabled. Use --force to override\n" if !$force; print "$0: checksumming not enabled, but forced to continue\n"; } $verbose = 1; # Just for now if ($db_recover) { printmsg "Running database recovery..."; db_recover(); printmsg "Done!\n"; } chdir "$cfg->{cache_dir}/packages" || die "Unable to enter cache package dir: $!"; SWITCH: while (local $_ = shift @db_mode) { /^import$/ && do { foreach (glob('*es.bz2 *es.gz *es *Release *diff_Index')) { open(my $fh, '<', $_)|| do { warn "Failed to open $_ for import: $!"; next; }; printmsg "Importing checksums from $_\n"; import_sums($_, $fh) if !$sim_mode; } next SWITCH; }; /^compact$/ && do { db_compact(db()); next SWITCH; }; /^(?:dump|search)$/ && do { my $re; if (/^search$/){ $re = shift @db_mode; die "No search expression given\n" if !$re; die "Invalid character '$1' in search\n" if $re =~ /([^$ok_chars])/o; # sanitize } my $cursor = get_cursor(db()); my ($filename,$data) = ('',''); while (cursor_next($cursor, \$filename, \$data) == 0) { next if /^search/ && $filename !~ /$re/; print "$filename\n"; my $href = hashify(\$data); while (my ($k,$v) = each %$href) { $v = '' if ! defined $v; print " $k: $v\n"; } } next SWITCH; }; /^delete$/ && do { my $re = shift @db_mode; die "No give regex to match files to delete\n" if !$re; die "Invalid character '$1' in pattern\n" if $re =~ /([^$ok_chars])/o; # sanitize my $cursor = get_cursor(db(),1); my ($filename,$data) = ('',''); while (cursor_next($cursor, \$filename, \$data) == 0) { next if $filename !~ /$re/; printmsg "Deleting data for $filename\n"; $cursor->c_del == 0 || warn "c_del failed: $BerkeleyDB::Error" if !$sim_mode; } next SWITCH; }; /^failcheck$/ && do { printmsg 'Connecting to database....'; # Just connect to the database which runs failchk() if (db(1)) { # Without locking printmsg "Success!\n"; } next SWITCH; }; /^verify$/ && do { printmsg "Waiting for exclusive lock..."; if (db_flock(LOCK_EX)){ printmsg "Got it!\nVerifying database..."; printmsg db_verify("$cfg->{cache_dir}/sums.db", temp_env()) ? "Failed! " . db_error() . "\n" : "Passed!\n"; } else { warn "Unable to get exclusive database lock: $!\n"; } next SWITCH; }; warn "Unknown command $_ \n"; next SWITCH; } exit; } ############################################################################# # Cache cleaning from here # Take a lock on the cache dir to ensure only one cleanup script can run at a # time as this can take a while on some systems. open (my $cleanup_lock, '<', $cfg->{'cache_dir'}) or die "Can't open $cfg->{'cache_dir'} for locking!\nError: $!\n"; flock($cleanup_lock, LOCK_EX|LOCK_NB) or die "Another apt-cacher-cleanup is already running. Exiting!\n"; # check offline mode in config if (defined $cfg->{offline_mode} && $cfg->{offline_mode}) { $offline = 1; } use GDBM_File; open(my $tmpfile, "+>", undef) or die $!; # my modifications - begin chmod $tmpfile, oct(600); # workaround 5.22.1 # my modifications - end tie my %valid, 'GDBM_File', fd_path($tmpfile), &GDBM_NEWDB|&GDBM_FAST, oct(600) # Does a separate open or die "GDBM_File tie failed: $!"; close($tmpfile); # So we can close this ### Preparation of the package lists ######################################## chdir "$cfg->{cache_dir}/packages" && -w "." || die "Could not enter the cache dir: $!"; if($> == 0 && !$cfg->{user} && !$force) { die "Running $0 as root\nand no effective user has been specified. Aborting.\nPlease set the effective user in $configfile or use --force to ignore\n"; } # Try to ensure corresponding Packages/Sources is present for each diff_Index # and Release for each Packages/Sources { my %missing; CHECKFILE: foreach (glob('*diff_Index *{Packages,Sources}{,.gz,.bz2}')) { my $file = $_; if (s/\.diff_Index$/{,.gz,.bz2}/) { printmsg "Checking for $_ for $file\n"; } elsif (s/(?:dists_[^_]+_(?:updates_)?\K(?:[^_]+_){2})?(?:Packages|Sources)(?:\.(?:bz2|gz))?$/{In,}Release/) { printmsg "checking for $_ for $file\n"; } foreach (glob) { if ( -f $_ ) { printmsg "Found $_\n"; next CHECKFILE; } } $missing{(glob)[-1]} = 1; } get($_) foreach keys %missing; } # Initially preserve the index files %valid = map {$_ => 1} glob('*{Release,diff_Index} *{Packages,Sources}{,.gz,.bz2}'); foreach my $file (keys %valid) { # Try to patch my $patched; if($pdiff_mode && $file =~ /(?:Packages|Sources)(?:\.(?:bz2|gz))?$/) { printmsg "Attempting to update $file by patching\n"; ($patched = pdiff($file)) || printmsg "Patching failed or not possible\n"; } # If patching failed download them, unless offline if (!$patched) { if(!$offline) { get($file); } else { printmsg "Offline: Reusing existing $file\n"; } } # Remove obsolete Release and Release.gpg if ((my $obsolete = $file) =~ s/InRelease/Release/) { next unless exists $valid{$obsolete}; printmsg "Removing $obsolete in favour of $file\n"; delete $valid{$obsolete}; unlink $obsolete, "$obsolete.gpg" if !$sim_mode; } } foreach my $file (keys %valid) { printmsg "Reading: $file\n"; if ((my ($cfh, undef) = open_lock($file)) == 2) { extract_sums($file, $cfh, \%valid) || die("Error processing $file in $cfg->{cache_dir}/packages, cleanup stopped.\nRemove the file if the repository is no longer interesting and the packages pulled from it are to be removed.\n"); } else { die "Failed to open filehandles for $file. Resolve this manually. \nExiting to prevent deletion of cache contents.\n"; } } printmsg "Found ".scalar (keys %valid)." valid file entries\n"; #print join("\n",keys %valid); # Remove old checksum data if ($cfg->{checksum}) { my $dbh = db(); my $do_compact; $dbh && do { printmsg "Removing expired entries from checksum database\n"; my $cursor = get_cursor($dbh,1); my ($filename,$data)=('',''); while (cursor_next($cursor, \$filename, \$data) == 0) { next if defined $valid{$filename}; printmsg "Deleting checksum data for $filename\n"; $cursor->c_del == 0 || warn "c_del failed: $BerkeleyDB::Error" if !$sim_mode; $do_compact = 1; } db_compact($dbh) if $do_compact || $pdiff_mode; }; } # Clean package directory { # Scoping block # Build a source package version reverse hash for changelog validation from the .dsc files printmsg "Building source package file/version table\n"; open(my $tmpfile, "+>", undef) or die $!; # my modifications - begin chmod $tmpfile, oct(600); # workaround 5.22.1 # my modifications - end tie my %svrhash, 'GDBM_File', fd_path($tmpfile), &GDBM_NEWDB|&GDBM_FAST, oct(600) # Does a separate open or die "GDBM_File tie failed: $!"; close($tmpfile); # So we can close this %svrhash = map {m#([-+.a-z0-9]+_(?:\d:)?[-+.~a-zA-Z0-9]+)\.dsc# && $1 => 1} keys %valid; foreach (glob('*{,/*}')) { next if -d; # Skip directories if (/([-+.a-z0-9]+_(?:\d:)?[-+.~a-zA-Z0-9]+)_changelog$/ && !$svrhash{$1}) { unlink $_, "../headers/$_" unless $sim_mode; printmsg "Removing expired changelog: $_ and company...\n"; next; } next unless is_file_type('package', $_) || is_file_type('pdiff', get_original_url($_)); # Package and pdiff files only if(! defined($valid{$_})) { unlink $_, "../headers/$_", "../private/$_.complete" unless $sim_mode; printmsg "Removing file: $_ and company...\n"; } else { # Verify SHA1 checksum my $target_sum = hashify(\$valid{$_})->{sha1}; next unless $target_sum; # print "Validating SHA1 $target_sum for $_\n"; open(my $fh, '<', $_) || die "Unable to open file $_ to verify checksum: $!"; flock($fh, LOCK_EX); if (is_file_type('pdiff', get_original_url($_))) { # pdiffs need decompressing $fh = IO::Uncompress::AnyUncompress->new($fh) or die "Decompression failed: $AnyUncompressError\n"; } if ((my $sha1 = Digest::SHA->new(1)->addfile($fh)->hexdigest) ne $target_sum) { unlink $_, "../headers/$_", "../private/$_.complete" unless $sim_mode; printmsg "Checksum mismatch ($target_sum <=> $sha1): $_, removing\n"; } # No explicit LOCK_UN: it fails with IO::Uncompress::AnyUncompress, just rely on close close $fh; } } } # Clean header directory chdir "$cfg->{cache_dir}/headers" && -w "." || die "Could not enter the cache header dir: $!"; foreach (glob('*{,/*}')) { next if -d; # Skip directories if((is_file_type('package', $_) && !defined($valid{$_})) # Not indexed || !-e "../packages/$_") { # No corresponding package unlink $_, "../private/$_.complete" unless $sim_mode; printmsg "Removing expired headers: $_ and company...\n"; next; } my $resp = read_header($_); next if $resp && $resp->is_success; # Don't cache errors any more printmsg "Removing cached error/invalid response: $_\n"; delete $valid{$_}; unlink $_ unless $sim_mode; } # Remove .complete files, for which we no longer have cached data. No new # complete files are being created, but they do contain the URL that was used, # so keep those for now chdir "$cfg->{cache_dir}/private" && -w "." || die "Could not enter the cache private dir: $!"; foreach (glob('*.complete')) { s/.complete$//; if(!(defined($valid{$_}) && -e "../packages/$_" && -e "../headers/$_")) { printmsg "Removing: $_.complete\n"; unlink "$_.complete" unless $sim_mode; } elsif (my $resp = read_header("../headers/$_")) { next unless $resp->header('X-AptCacher-URL'); # Remove complete files if we now have the upstream URL in the headers printmsg "Removing redundant $_.complete\n"; unlink "$_.complete" unless $sim_mode; } } # last step, kill some zombies foreach (glob('*.notify')) { printmsg "Removing obsolete notify file: $_\n"; unlink $_ unless $sim_mode; } chdir "$cfg->{cache_dir}/packages" || die "Could not enter the cache package dir: $!"; foreach (glob('*{,/*}')) { # must be empty and not complete and being downloaded right now if(-z $_) { my $fromfile; if(open($fromfile, '<', $_) && flock($fromfile, LOCK_SH|LOCK_NB)) { # double-check, may have changed while locking if(-z $fromfile) { printmsg "Removing zombie files: $_ and company...\n"; unlink $_, "../headers/$_", "../private/$_.complete" unless $sim_mode; _flock($fromfile, LOCK_UN); close($fromfile); } } } }
