view release on metacpan or  search on metacpan

lib/App/FileCleanerByDiskUage.pm  view on Meta::CPAN

	my @files_info;
	File::Find::find(
		sub {
			# $_ is the basename (we are chdir'd into the containing dir),
			# $File::Find::name is the full path. stat($_) populates the "_"
			# handle so the -f test below reuses it rather than statting again.
			my @stat = stat($_);
			return unless @stat;    # skip on stat failure (races, broken symlinks)
			return unless -f _;     # regular files only, matching the old ->file rule
			return if defined($ignore_re) && $_ =~ $ignore_re;    # ignore by basename
			# blocks ($stat[12], 512-byte units) is the space actually freed by
			# unlinking, used by the removal loop to estimate disk usage between
			# df() calls. apparent size would over-count sparse/small files.
			push( @files_info, { name => $File::Find::name, mtime => $stat[9], blocks => $stat[12] } );
		},
		@paths
	);
	$results->{found_files_count} = scalar(@files_info);

	# if we have a min number of files specified, make sure we found more than
	# that many. min_files elements at indexes 0 .. min_files-1, so index
	# min_files existing means there is at least one file eligible for removal.
	if ( $opts{min_files} && !defined( $files_info[ $opts{min_files} ] ) ) {
		$results->{min_files} = $opts{min_files};
		if ( $opts{use_pid} ) {
			unlink_pid_file($pid_file);
		}
		return $results;
	}

	# sort files oldest to newest based on mtime, numerically
	@files_info = sort { $a->{mtime} <=> $b->{mtime} } @files_info;
	# save the full, sorted list into the results; the unlink loop below is
	# bounded by an index so it never touches this array, meaning we don't
	# need a defensive copy here
	$results->{found_files} = \@files_info;

	# the newest min_files files are kept regardless of disk usage. As the list
	# is sorted oldest to newest, those are the last min_files entries, so we
	# simply stop the removal loop before reaching them rather than removing
	# them from the array.
	my $min_files = 0;
	if ( defined( $opts{min_files} ) && $opts{min_files} > 0 ) {
		$min_files            = $opts{min_files};
		$results->{min_files} = $min_files;
	}
	# index of the last (oldest end) file eligible for removal
	my $last_removable = $#files_info - $min_files;

	# go through files and remove the oldest till we drop below the threshold.
	#
	# Rather than calling df() after every single unlink (a statvfs syscall each
	# time, which dominates the loop on high latency filesystems), we estimate
	# how much space we still need to free from the block counts we already have
	# and only consult the real df() when the estimate says we should be close.
	# The real df() remains the authoritative stop condition, so this never
	# under removes; the $resync cap bounds how far a bad estimate (concurrent
	# writers, files held open elsewhere) can run us past the target.
	my $per = $df->{per};

	# bytes the user may occupy, used to translate a percentage into bytes. The
	# byte mode df() (block size of 1) reports used/bavail in bytes.
	my $df_bytes = $df_func->( $du_path, 1 );
	my $user_total = ( $df_bytes->{used} || 0 ) + ( $df_bytes->{bavail} || 0 );
	# estimated bytes still to free to reach the target, and bytes freed since
	# the last real df() check
	my $need  = ( ( $per - $opts{du} ) / 100 ) * $user_total;
	my $freed = 0;

	my $int             = 0;
	my $since_resync    = 0;
	while ( $per >= $opts{du} && $int <= $last_removable ) {
		my $file = $files_info[$int];
		eval {
			if ( $opts{dry_run} ) {
				# dry run: never remove anything, just verify the file would be
				# removable by checking it is writable by the current user
				if ( !-w $file->{name} ) {
					die('file is not writable');
				}
			} else {
				unlink( $file->{name} ) or die($!);
			}

		};
		if ($@) {
			push( @{ $results->{unlink_errors} }, 'Failed to remove "' . $file->{name} . '"... ' . $@ );
			push( @{ $results->{unlink_failed} }, $file );
		} else {
			push( @{ $results->{unlinked} }, $file );
			# a failed unlink frees nothing, so only count successful removals
			$freed += ( $file->{blocks} || 0 ) * 512 unless $opts{dry_run};
		}

		$int++;
		$since_resync++;

		# a dry run never changes disk usage, so re-checking df() would loop
		# forever on the same $per; the index bound above is what stops it.
		next if $opts{dry_run};

		# consult the real df() only once we estimate we have freed enough, or
		# once $resync files have gone by, whichever comes first
		if ( $freed >= $need || $since_resync >= $resync ) {
			$df           = $df_func->($du_path);
			$per          = $df->{per};
			$need         = ( ( $per - $opts{du} ) / 100 ) * $user_total;
			$freed        = 0;
			$since_resync = 0;
		}
	} ## end while ( $per >= $opts{du} && $int <= $last_removable )

	# make sure du_ending reflects real disk usage, not the last estimate
	$df = $df_func->($du_path);
	$results->{du_ending} = $df->{per};
	if ( defined( $results->{unlinked}[0] ) ) {
		$results->{unlinked_count} = $#{ $results->{unlinked} } + 1;
	}
	if ( defined( $results->{unlink_failed}[0] ) ) {
		$results->{unlink_failed_count} = $#{ $results->{unlink_failed} } + 1;
	}