touchdirs

#!/usr/bin/env perl
BEGIN { require 5.008 }
package Touchdirs;
our $VERSION = 'v5.0.2';
eval { $VERSION = version->declare($VERSION) };
eval 'use version 0.77; $VERSION = version->declare($VERSION)' if($@);

use warnings;
use strict;
use integer;
no  sort 'stable';
use Getopt::Long 2.24 ();
use File::Find ();
use File::Spec ();
use Time::localtime ();
#use File::lchown 0.02 ();  # used for lutimes if available; fallback to system
#use Pod::Usage ();  # needed for --man, --help, some errors
#use String::ShellQuote ();  # not mandatory but recommended: poor fallback
#use Time::HiRes ();  # needed unless -R is used

=encoding UTF-8

=head1 NAME

touchdirs - Touch directories according to their newest file

=head1 SYNOPSIS

B<touchdirs> [options] [I<dirs or files>]

To get an extended help, type B<touchdirs --man> or B<touchdirs -?>

=head1 DESCRIPTION

Look for all files in I<dirs> and then change all dirs' mtimestamps according
to the newest file contained (empty dirs' mtimestamps are ignored).
The used resolution of timestamps is one second, independent of the
properties of the filesystem.
If I<dirs or files> is not specified, the current directory is assumed.

=head1 OPTIONS AND ARGUMENTS

=over 8

=item B<--round> or B<-r>

On filestamps with non-integer seconds, drop to integers and
modify recursed filestamps correspondingly.

=item B<--rounding>

On filestamps with non-integer seconds, drop to integers,
but do not touch non-directories only for this modification.

=item B<--roundread> or B<-R>

As B<--rounding> but do not even touch directories for the modification.

=item B<--force> or B<-f>

Touch dirs even if time did not change.
This has effects e.g. on copy-on-write filesystems or with B<--rounding>.

=item B<--all> or B<-a>

As B<--force> but additionally touch all files

=item B<--access> or B<-A>

Let access time be the same as modification time.

=item B<--mtime> or B<-m>

Do not drop non-integer seconds for atime if this is the only reason
why the file/dir would need to be touched.

=item B<--ignore=>I<regexp> or B<-i> I<regexp>

Ignore files whose (relative) path matches I<regexp> (perl multiline regexp).

=item B<--ignore-case=>I<regexp> or B<-I> I<regexp>

Ignore files whose (relative) path matches I<regexp> (perl multiline regexp),
ignoring case.

=item B<--dotdirs> or B<-d>

Ignore .* dirs. Equivalent to B<--ignore=/\..+/>

=item B<--dotfiles> or B<-D>

Ignore .* files. Equivalent to B<--ignore=/\.[^/]+\z>

=item B<--empty-ignore>, B<--empty> or B<-e>

Ignore empty directories

=item B<--dot>

Ignore .* files/dirs. Equivalent to B<--ignore=/\.> or to B<-dD>

=item B<--git> or B<-g>

Ignore .git dirs. Equivalent to B<--ignore=/\.git/>

=item B<--follow-link> or B<-F>

Follow links to further directories.
Also use time of the file the link points to instead of time of the link.

=item B<--quiet> or B<-q>

Do not print ignored directories.
If specified twice, do not print executed commands, either.

=item B<--check> or B<-c>

Check only whether Time::Hires seems to work correctly and then exit.
If combined with B<--quiet> do not output anything.

=item B<--dry-run> or B<--show> or B<-n> or B<-s>

Only show what would be done, do not alter anything.

=item B<--verbose> or B<-v>

Inform about empty directories.

=item B<--version> or B<-V>

Print version number

=item B<--help> or B<-h>

Display brief help.

=item B<--man> or B<-?>

Display extended help as a manpage.

=item B<-->

Last option

=back

=head1 AUTHOR

Martin VE<auml>th E<lt>martin@mvath.deE<gt>

=cut

# Options and their default:

my $check = '';
my $access = '';
my $force = '';
my $all = '';
my $round = '';
my $rounding = '';
my $roundread = '';
my $round_atime_write = '';
my $show = '';
my $follow = '';
my $emptyignore = '';
my $quiet = 0;
my $verbose = 0;
my @exclude = ();

# Global Variables:

my $name = 'touchdirs';
my $hires_write;
my %DIR;
my %PARENT;
my $count;
my @topdirs;
my $lutimes = undef;

# Functions:

sub not_equal {
	my ($a, $b) = @_;
	no integer;
	$a != $b
}

sub is_equal {
	my ($a, $b) = @_;
	no integer;
	$a == $b
}

sub myctime {
	my ($rtime) = @_;
	my ($time, $itime);
	my $hires_writing = '';
	my $arg = '-t';
	my $format = '%04d%02d%02d%02d%02d%s%02d%s';
	my $dot = '.';
	my $rest = '';
	if($hires_write) {
		$itime = int($rtime);
		$time = Time::localtime::localtime($itime);
		if(&not_equal($itime, $rtime)) {
			no integer;
			$hires_writing = 1;
			$rest = $rtime - $itime;
			$rest =~ s{^(?:[^\.]*)\.}{\.} or
				&fatal('strange number conversion');
			$arg = '-d';
			$format = '%04d-%02d-%02d %02d:%02d:%s%02d%s';
			$dot = ''
		}
	} else {
		$time = Time::localtime::localtime($rtime)
	}
	($hires_writing, $arg, sprintf($format,
		(1900 + $time->year()), 1 + $time->mon(), $time->mday(),
		$time->hour(), $time->min(), $dot, $time->sec(), $rest))
}

sub check_lutimes {
	eval {
		require File::lchown
	};
	return ($lutimes = '') if($@);
	no integer;
	$lutimes = (defined($File::lchown::VERSION) &&
		($File::lchown::VERSION >= 0.02))
}

sub touchit {
	my ($atime, $mtime, $file) = @_;
	return if($show && ($quiet >= 2));
	my $symlink = ((!$follow) && (-l $file));
	my @touch = ('touch');
	push(@touch, '-h') if($symlink);
	my ($cm, $cmarg, $cmtime) = &myctime($mtime);
	my ($ca, $caarg, $catime) =
		(&is_equal($atime, $mtime) ? (undef) : &myctime($atime));
	my $system = ($cm || ($ca // ''));
	if($symlink && !$system) {
		&check_lutimes() unless(defined($lutimes));
		$system = 1 unless($lutimes)
	}
	my $shellexec = ($system && !$show);
	my $shellprint = ($quiet < 2);
	if($shellprint || $shellexec) {
		if(!defined($ca)) {
			&printexec($shellprint, $shellexec,
				[@touch, $cmarg, $cmtime], $file)
		} else {
			&printexec($shellprint, $shellexec,
				[@touch, '-m', $cmarg, $cmtime], $file);
			&printexec($shellprint, $shellexec,
				[@touch, '-a', $caarg, $catime], $file)
		}
	}
	unless($system || $show) {
		if($symlink) {
			File::lchown::lutimes($atime, $mtime, $file)
		} else {
			utime($atime, $mtime, $file)
		}
	}
}

sub exclude {
	my ($path) = @_;
	for my $regex (@exclude) {
		if($path =~ $regex) {
			return 1
		}
	}
	''
}

sub my_split {
	my ($arr, $dir) = @_;
	@$arr = File::Spec->splitdir($dir)
}

sub my_cat {
	File::Spec->catdir(@_)
}

{ my $have_hires_lstat = undef;
sub my_amtime {
	my ($file) = @_;
	(((!$follow) && (-l $file)) ?
		(($roundread ||
			!($have_hires_lstat //= defined(&Time::HiRes::lstat)))
			? lstat($file) : Time::HiRes::lstat($file)) :
		($roundread ? stat($file) : Time::HiRes::stat($file)))[8, 9]
}}

sub dotouch {
	if(defined($File::Find::dir) && ($File::Find::dir ne $_)) {
		$PARENT{$File::Find::dir} = 1
	}
	if((-d $_) && ($follow || !(-l $_))) {
		return if($emptyignore || exists($PARENT{$_}));
		&printcomment('empty', $_) if($verbose)
	}
	if(&exclude($_)) {
		&printcomment('ignored', $_) unless($quiet);
		return
	}
	my @dirs;
	&my_split(\@dirs, $_);
	for my $i (@topdirs) {
		if((!@dirs) || ($i ne shift(@dirs))) {
			&printcomment('prune', $_);
			$File::Find::prune = 1;
			return
		}
	}
	my $filename = &my_cat(@topdirs, @dirs);
	my ($atime, $mtime) = &my_amtime($filename);
	unless(defined($atime) && defined($mtime)) {
		&printcomment('non-statable', $filename);
		return
	}
	my $write = $all;
	if($rounding) {
		my ($oldatime, $oldmtime) = ($atime, $mtime);
		($atime, $mtime) = (int($atime), int($mtime));
		if($round && !$write) {
			$write = 1 if(&not_equal($oldmtime, $mtime) ||
				($round_atime_write &&
					&not_equal($oldatime, $atime)))
		}
	}
	if($access && &not_equal($atime, $mtime)) {
		$atime = $mtime;
		&touchit($atime, $mtime, $filename)
	} elsif($write) {
		&touchit($atime, $mtime, $filename)
	}
	while(@dirs) {
		pop(@dirs);
		my $dirname = &my_cat(@topdirs, @dirs);
		my $array = $DIR{$dirname};
		if(defined($array)) {
			my ($oriatime, $orimtime) = @$array;
			if($atime > $oriatime) {
				$array->[0] = $atime
			}
			if($mtime > $orimtime) {
				$array->[1] = $mtime
			}
		} else {
			$DIR{$dirname} = [ $atime, $mtime,
				scalar(@dirs), $count++ ]
		}
	}
}

sub printcomment {
	my $comment = shift();
	my $text = &shell_comment_quote(&shell_quote_best_effort('x', @_));
	$text =~ s{^[^ ]*}{};
	print('# ', $comment, $text, "\n")
}

sub printexec {
	my $shellprint = shift();
	my $shellexec = shift();
	# The following shortcut-check is done at a higher level:
	# return unless($shellprint || $shellexec);
	my @cmd = &shdash;
	&shprintraw(@cmd) if($shellprint);
	system(@cmd) if($shellexec)
}

sub shdash {
	my $c = shift();
	$c = [$c] unless(ref($c) eq 'ARRAY');
	for my $i (@_) {
		if($i =~ m{^[-+]}o) {
			push(@$c, '--');
			last
		}
	}
	(@$c, @_)
}

# use String::ShellQuote () and return whether successful

{ my $shellquote = undef;  # A closure static variable
sub use_shellquote {
	return $shellquote if(defined($shellquote));
	eval {
		require String::ShellQuote
	};
	$shellquote = !$@
}}

# like join(' ', @_), but shell-quote arguments

sub join_quoted {
	my @r;
	for my $i (@_) {
		my $a = $i;
		$a =~ s{\'}{\'\\\'\'}g;
		$a = "'$a'";
		$a =~ s{(\A|[^\\])\'([\w\-\,\.\:\/]*)\'}{$1$2}gm;
		push(@r, ($a ne '') ? $a : "''")
	}
	join(' ', @r)
}

sub shell_quote_best_effort {
	(&use_shellquote() ?
		&String::ShellQuote::shell_quote_best_effort : &join_quoted)
}

sub shprintraw {
	print(&shell_quote_best_effort, "\n")
}

#sub shprint {
#	&shprintraw(&shdash)
#}

sub my_shell_comment_quote {
	my ($arg) = @_;
	$arg =~ s{\n}{\n\#}gm;
	$arg
}

sub shell_comment_quote {
	(&use_shellquote() ? &String::ShellQuote::shell_comment_quote :
		&my_shell_comment_quote)
}

sub info {
	my $add = ': ';
	print($name, $add,
		join("\n" . (' ' x (length($name) + length($add))), @_), "\n")
}

sub warning {
	my $add = ': warning: ';
	print(STDERR $name, $add,
		join("\n" . (' ' x (length($name) + length($add))), @_), "\n")
}

sub fatal {
	my $add = ': fatal: ';
	print(STDERR $name, $add,
		join("\n" . (' ' x (length($name) + length($add))), @_), "\n");
	exit(1)
}

sub version {
	print($name, ' ', $VERSION, "\n");
	exit(0)
}

sub pod2usage {
	require Pod::Usage;
	&Pod::Usage::pod2usage
}

# Parse Options:

{
my @iexclude = ();
my $opt_mtime;
Getopt::Long::Configure(qw(gnu_getopt));
Getopt::Long::GetOptions(
	'help|h', sub { &pod2usage(0) },
	'man|?', sub { &pod2usage(-verbose => 2, -exit => 0) },
	'version|V', \&version,
	'round|r', \$round,
	'rounding', \$rounding,
	'roundread|R', \$roundread,
	'mtime|m', \$opt_mtime,
	'force|f', \$force,
	'all|a', \$all,
	'access|A', \$access,
	'ignore|i=s', \@exclude,
	'ignore-case|I=s', \@iexclude,
	'dotdir|d', sub { push(@exclude, qr{/\..+/}m) },
	'dotfile|D', sub { push(@exclude, qr{/\.[^/]+\z}m) },
	'dot', sub { push(@exclude, qr{/\.}) },
	'git|g', sub { push(@exclude, qr{/\.git/}) },
	'show|dry-run|s|n', \$show,
	'verbose|v', \$verbose,
	'quiet|q+', \$quiet,
	'check|c', \$check,
	'empty|empty-ignore|e', \$emptyignore,
	'noempty|no-empty|noempty-ignore|no-emptyignore',
		sub { $emptyignore = '' },
	'follow-link|F', \$follow,
	'nofollow-link|no-follow-link', sub { $follow = '' }
) or &pod2usage(2);
for my $i (@ARGV) {
	(-e $i) || (-l $i) || &pod2usage("cannot find $i")
}
@ARGV = (File::Spec->curdir()) unless($check || @ARGV);

# Set dependent options

$round_atime_write = !$opt_mtime;

$rounding = 1 if($round || $roundread);
if($all) {
	$force = 1;
	$round = ''
}
if($check) {
	$roundread = '';
	$follow = 1
}

# Set globals depending on options
$hires_write = !$rounding;
unless($roundread) {
	eval {
		require Time::HiRes
	};
	if($@) {
		my @err = ('perl module Time::HiRes not found:', $@);
		if($check) {
			&info(@err) unless($quiet);
			exit(1)
		}
		&warning(@err, 'Forcing option -R');
		$roundread = 1
	} else {
		my ($atime, $mtime) = &my_amtime(File::Spec->curdir());
		if((int($atime) < 1000000) || (int($mtime) < 1000000)) {
			my @err = ('Time::Hires::stat() appears broken');
			if($check) {
				print(@err) unless($quiet);
				exit(1)
			}
			$roundread = 1;
			($atime, $mtime) = &my_amtime(File::Spec->curdir());
			&fatal('stat() appears to be corrupted by Time::Hires',
				'You might want to retry with option -R')
				if((int($atime) < 1000000) ||
					(int($mtime) < 1000000));
			&warning(@err, 'Forcing option -R')
		} elsif($check) {
			&info('Time::Hires appears to work') unless($quiet);
			exit(0)
		}
	}
	if($roundread) {  # error case
		$round = '';
		$rounding = 1
	}
}

# Compile regular expressions and make one array:
for my $i (@exclude) {
	$i = qr{$i}m if(ref($i) ne 'Regexp')
}
for my $i (@iexclude) {
	$i = qr{$i}im if(ref($i) ne 'Regexp');
	Push(@exclude, $i)
}

}  # End of option parsing

# Main Loop
for my $currdir (@ARGV) {
	%DIR = ();
	$count = 0;
	&my_split(\@topdirs, File::Spec->canonpath($currdir));
	my $topdir = &my_cat(@topdirs);
	unless(-d $topdir) {
		$_ = $topdir;
		&dotouch();
		next
	}
	%PARENT = ();
	File::Find::find({
		bydepth => 1,
		follow => $follow,
		follow_skip => 2,
		no_chdir => 1,
		dangling_symlinks => '',
		wanted => \&dotouch
	}, $topdir);
	my @DIR = sort {
		my ($x, $y) = ($DIR{$a}, $DIR{$b});
		($y->[2] cmp $x->[2]) || ($y->[3] cmp $x->[3])
	} keys(%DIR);
	for my $dir (@DIR) {
		my ($atime, $mtime) = &my_amtime($dir);
		my ($newatime, $newmtime) = @{$DIR{$dir}};
		if($force || &not_equal($atime, $newatime) ||
			&not_equal($mtime, $newmtime)) {
			&touchit($newatime, $newmtime, $dir)
		}
	}
}
1;