git-restore-commit-mtime

#!/usr/bin/env perl
# git-restore-commit-mtime --- sync local file modtimes with commit history
# Author: Noah Friedman <friedman@splode.com>
# Created: 2014-11-17
# Public domain

# Commentary:

# Usage: git-restore-commit-mtime {-C dir} {revrange}
#        git {-C dir} restore-commit-mtime {revrange}
# revrange can be in the form e.g. "@{yesterday}..@"

# Why would you want this?  Well, if you're incrementally building from
# source and pull in updates, you don't; backdating timestamps could break
# your build.  But for initial checkouts, timestamps show what files are
# dormant or active areas of work.

# If you just keep source trees around for reference and regularly pull a
# snapshot (say, once a day) and want to fix mtimes on just files committed
# since then, you can use a revision range like the above example, which
# will significantly prune the commit list that has to be scanned.  That
# scan is by far the slowest part of the operation.

# The --emacs option enables special handling to work around the emacs repo
# touching every goddamned file every year just to change the copyright,
# even if nothing else in the file ever changes.

# Code:

use strict;
use warnings qw(all);

use POSIX qw(:sys_wait_h strftime);
use Fcntl qw(:mode);

use Getopt::Long;
#use Pod::Usage;

# Offsets into the list returned by stat() and lstat() that we use
use constant
  {
    ST_MODE    =>  2,	# file type and perms
    ST_ATIME   =>  8,	# last access time in seconds since the epoch
    ST_MTIME   =>  9,	# last modify time in seconds since the epoch
  };

(my $progname = $0) =~ s=^.*/==;

my %opt = ( emacs_repo  => 0,
            author_time => 0,
            verbose     => 0,
          );
my @git_cmd = ($ENV{GITPROG} || "git");

our $emacscr_re;
our $cmd_exitstat = 0;
our $gitdir = '.';

sub perror
{
  print STDERR join( ': ', $progname, @_, "$!\n" ) if $opt{verbose};
  return; # void
}

sub cmd_waitpid
{
  local $!;   # don't let waitpid() overwrite current error
  while ((my $pid = waitpid( -1, WNOHANG )) > 0 && WIFEXITED( $? ))
    {
      $cmd_exitstat = WEXITSTATUS( $? );
    }
}

# Like `` but avoids shell exec/reparsing.
sub cmd_out
{
  local $SIG{CHLD} = \&cmd_waitpid;
  my $pid = open (my $fh, "-|");
  die "fork: $!" unless defined $pid;
  if ($pid) # parent
    {
      print STDERR "+ @_\n" if $opt{verbose} > 2;
      local $/ = undef;
      my $res = <$fh>;
      # We have to close the fh explicitly if we want to recover the exit
      # status of the process.
      close( $fh );
      return $res;
    }
  else # child
    {
      exec( { $_[0] } @_ ) or die "exec: $_[0]: $!\n";
    }
}


sub git
{
  my @cmd = @git_cmd;
  push( @cmd, '-C', $gitdir ) if $gitdir;
  return cmd_out( @cmd, @_ );
}

sub git_worktree_info
{
  my $data = git( qw(worktree list --porcelain) );
  die "Error from git, cannot continue.\n" unless $cmd_exitstat == 0;

  my %info;
  for my $elt (split( /\n/, $data ))
    {
      if ($elt =~ /^(\S+)\s+(.*)/) { $info{$1}   = $2 }
      else                         { $info{$elt} = 1 }
    }
  return wantarray ? %info : \%info;
}

sub git_live_files
{
  map { $_ => undef } split (/\0/, git (qw(ls-tree -z -r --name-only @)));
}

sub git_log_data
{
  unshift( @_, '@' )        if !@_ || $_[0] !~ m=\@|.+?\.\..+=;
  splice(  @_, 1, 0, '--' ) if  @_ < 2 || $_[1] ne '--';

  my $format = $opt{author_time} ? "%at" : "%ct";
  $format .= "\001%s\001" if $opt{emacs_repo};

  my $data = git( qw(log -z --name-only --relative --max-parents=1),
                  "--format=format:$format", @_ );
  my %tbl;

  # Generate a map of what files are "live", so that we can ignore file
  # names in the commit logs that are not relevant.
  my %have = git_live_files();

  # This was found to be the best compromise between speed and memory.
  # Overly complex regex matching is slower because of backtracking, and
  # pre-splitting the data chunk on \0\0 doubles the amount of memory used.
  my $summary = "";
  my ($off, $len) = (0, length( $data ));
  while ($off < $len)
    {
      my $end = ($data =~ m/\0\0/g) ? pos( $data ) - 2 : $len;
      my ($mtime, $files) = split( /\n/, substr( $data, $off, $end - $off ), 2 );

      ($mtime, $summary) = split ( /\001/, $mtime, 3 ) if $opt{emacs_repo};
      if ($files && !(defined( $emacscr_re ) && $summary =~ /$emacscr_re/o))
        {
          $mtime =~ s/^.*\0//; # skip changelists with no files
          map { $tbl{$_} = $mtime
                  unless exists $tbl{$_} || !exists $have{$_};
              } split( /\0/, $files );
        }
      $off = $end;
    }

  return unless %tbl;
  return \%tbl;
}


sub walk_dirtree
{
  my ($node, $fn) = @_;

  &$fn( $node );
  return unless -d $node;

  opendir( my $fh, $_[0] ) or return;
  my @files = grep { !/^\.\.?$/ } readdir( $fh ) or return;
  close( $fh );

  $node =~ s=/+$==;
  for my $ent (@files)
    {
      my $file = join( '/', $node, $ent );
      next if -l $file;
      walk_dirtree( $file, $fn );
    }
}

sub max { my $m = shift; map { $m = $_ if $_ > $m } @_; return $m }
sub min { my $m = shift; map { $m = $_ if $_ < $m } @_; return $m }

my %file_msg;

# Do not modify mtime on a file if it's already set to that time.
# This avoids changing the atime or ctime unnecessarily.
#
# Perl cannot presently change the mtime of symlinks (i.e. no
# lutimes() interface), so they are skipped entirely.
# A really inefficient solution would be to call out to touch(1).
sub chmtime
{
  my $mtime = shift;
  if ($opt{verbose})
    {
      my $fmt = '%Y-%m-%d %H:%M:%S';
      my $n = strftime( $fmt, localtime( $mtime ));

      map { my @st = lstat( $_ );
            my $otime = $st[ST_MTIME] ;
            my $o = strftime( $fmt, localtime( $otime ));
            (my $file = $_) =~ s=^\./==;

            if ((S_ISLNK( $st[ST_MODE] )))
              {
                $file_msg{$file} = $o.' => (ignoring symlink)'
                  if $opt{verbose} > 1;
              }
            elsif ($otime == $mtime)
              {
                $file_msg{$file} = $o.' => (no change)' if $opt{verbose} > 1;
              }
            elsif (utime( $st[ST_ATIME], $mtime, $_ ))
              {
                $file_msg{$file} = $o.' => '.$n;
              }
            else
              {
                perror( $file );
              }
          } @_;
    } # verbose
  else
    {
      map { my @st = lstat( $_ );
            utime( $st[ST_ATIME], $mtime, $_ )
              unless S_ISLNK( $st[ST_MODE] ) || $st[ST_MTIME] == $mtime;
          } @_;
    } #!verbose
}

sub print_file_msgs
{
  my ($relative, $topdir) = @_;
  my $prefix_dir = $topdir;

  if    ($relative)            { $prefix_dir = $gitdir }
  elsif (!defined( $topdir ))  { $topdir  = ''  }
  elsif ($topdir eq '.')       { $topdir  = ''  }
  else                         { $topdir .= '/' }

  my $prefix = 1 + length( $prefix_dir );
  for my $file (sort keys %file_msg)
    {
      my $short = ($relative
                   ? ($file eq $prefix_dir
                      ? $topdir
                      : $topdir.'/'.substr( $file, $prefix ))
                   : $topdir . $file);
      printf( "%-42s  %s\n", $file_msg{$file}, $short );
    }
}


sub parse_options
{
  my $help = -1;
  local *ARGV = \@{$_[0]}; # modify our local arglist, not real ARGV.

  my $parser = Getopt::Long::Parser->new;
  $parser->configure (qw(pass_through no_ignore_case no_auto_abbrev no_bundling));
  my $succ = $parser->getoptions
    ( 'h|?|help+'        => \$help,
      'emacs'            => \$opt{emacs_repo},
      'A|author'         => \$opt{author_time},
      'd|directories'    => \$opt{dirs},
      'v|verbose+'       => \$opt{verbose},
    );

  #pod2usage (-exitstatus => 1, -verbose => 0)     unless $succ;
  #pod2usage (-exitstatus => 0, -verbose => $help) if $help >= 0;

  $emacscr_re = qr/(?:add|update|run|set-).*copyright|copyright.year|arch.tag|gplv3/i
    if $opt{emacs_repo};
}

sub main
{
  parse_options( \@_ );
  unshift( @_, '.' ) unless @_ && -d $_[0];

  my $dir = shift;
  return perror( $dir ) unless chdir( $dir );
  my %info = git_worktree_info() or return;

  if ($info{bare})
    {
      $gitdir = $info{worktree};

      my $mtime = git( qw(log -n1 --all --format=%ct) );
      my @node;
      my $fn = sub { my @st = stat( $_[0] );
                     # Don't touch files older than our
                     # computed mtime in bare repos.
                     push( @node, $_[0] ) unless $st[9] < $mtime;
                   };
      walk_dirtree( $gitdir, $fn );
      chmtime( $mtime, @node );
    }
  else
    {
      my $tbl = git_log_data( @_ ) or return;

      if ($opt{dirs})
        {
          # use keys() rather than each() here, because we're modifying $tbl.
          for my $file (keys %$tbl)
            {
              (my $dir = $file) =~ s=/[^/]*$==;
              $dir = '.' if $dir eq $file;
              my $mtime = $tbl->{$file};
              $tbl->{$dir} = $mtime
                unless exists $tbl->{$dir} && $tbl->{$dir} > $mtime;
            }
        }
      while (my ($file, $mtime) = each %$tbl)
        {
          chmtime( $mtime, $file );
        }
    }
  print_file_msgs( $info{bare}, $dir ) if %file_msg;
}

main (@ARGV);

# eof