view release on metacpan or  search on metacpan

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

	}

	if ( !$opts{dry_run} ) {
		$opts{dry_run} = 0,;
	} else {
		$opts{dry_run} = 1,;
	}

	# df() is normally Filesys::Df::df, but may be overridden internally via the
	# _df option so the removal loop's disk-usage logic can be tested without a
	# real filesystem. _resync bounds how many files may be removed between real
	# df() checks (see the removal loop below).
	my $df_func = ( ref( $opts{_df} ) eq 'CODE' ) ? $opts{_df} : \&df;
	my $resync = ( defined( $opts{_resync} ) && $opts{_resync} =~ /^\d+$/ && $opts{_resync} > 0 ) ? $opts{_resync} : 64;

	my $df = $df_func->($du_path);

	# the results to be returned
	my $results = {
		unlinked            => [],
		unlink_failed       => [],
		unlink_errors       => [],
		found_files         => [],
		found_files_count   => 0,
		unlinked_count      => 0,
		unlink_failed_count => 0,
		du_target           => $opts{du},
		du_starting         => $df->{per},
		du_ending           => $df->{per},
		min_files           => 0,
		dry_run             => $opts{dry_run},
		path                => \@paths,
		missing_paths       => \@missing_paths,
	};

	if ( !defined( $paths[0] ) ) {
		if ( $opts{use_pid} ) {
			unlink_pid_file($pid_file);
		}
		return $results;
	}

	if ( $df->{per} < $opts{du} ) {
		if ( $opts{use_pid} ) {
			unlink_pid_file($pid_file);
		}
		return $results;
	}

	# compile the ignore regexp once, if specified, and reuse it below
	my $ignore_re = defined( $opts{ignore} ) ? qr/$opts{ignore}/ : undef;

	# Recursively find regular files under the requested paths, statting each
	# one inline during the traversal. Doing the stat here means a single stat
	# syscall per file (the traversal and the mtime lookup share it) and avoids
	# building a separate array of path strings alongside the file info.
	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;