#!/usr/bin/perl
#
# Copyright (c) 2010 Roger F. Crew.  All rights reserved.
#
# This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the Perl README file.
# If you need more liberal licensing terms, please contact the
# maintainer.

$VERSION = '1.0';  # 9/9/2011

use warnings;
use strict;

# output file to be #included in server sources
# 
our $version_file = 'version_src.h';

# cache_file retains information from prior build
#   each line is of the form <key>=<value>
#   see %cache below for expected keys
# 
our $cache_file = "version.sha";

sub read_cache {
   my ($cache) = @_;

   if (-r $cache_file) {
      open CACHE,"+<$cache_file" or die "could not open $cache_file: $!";
      %{$cache} = (%{$cache}, map { chomp; (split('=',$_, 2))[0..1] } <CACHE>);
      seek(CACHE,0,0);
   }
}
  
sub write_cache {
   my ($cache) = @_;
   open CACHE,">$cache_file" or die "could not open $cache_file: $!"
     unless (defined(fileno(CACHE)));
   truncate(CACHE,0);
   print CACHE "$_=$cache->{$_}\n" for (keys %{$cache});
   close CACHE;
}

# do_cmd(CMD[, SUB])
#   CMD = shell command or label string for
#   SUB = code ref to be called in forked child
# if SUB not given, run CMD as a shell command.
# In either case, catch everything sent to stdout
# and return as a list of lines.
# die if child exits nonzero.
sub do_cmd {
   my ($cmd) = @_;
   my @r = &do_cmd_failok;
   die "$cmd: exit code = ".($?>>8) if ($?);
   return @r;
}

# do_cmd_failok(CMD[, SUB])
#   Same as do_cmd but
# die only if fork/pipe fails or child killed by signal
sub do_cmd_failok {
   my ($cmd,$sub) = @_;
   my $o = open SUB,"-|",$sub ? '-' : $cmd;
   die "$cmd failed: $!" 
     unless defined($o);

   if ($sub && !$o) { 
      # child perl interpreter
      # will call die if it needs to.
      $sub->(); 
      exit 0; 
   }
   my @r = map { chomp; $_ } <SUB>;
   close SUB;
   die "$cmd ... killed by signal $?" 
     if ($? && !($?>>8));
     # nonzero exit status not involving signals may still be okay
     # check it later.
   return @r;
}


# return the lines of git diff --raw
# but with the object hashes of the
# changed working directory files filled in
sub git_real_diff {
   my @changed = do_cmd('git diff --raw --no-abbrev --no-renames HEAD .');
   if (@changed) {
      foreach (@changed) {
	 my ($s,@f) = split "\t";
	 # for every case except file deletion (D)
	 if ($s =~ m/^(.*) 0{40} ([A-CE-Z]\d*)$/) {
	    # diff --raw format is 
	    #  :mode1 mode2 sha1 sha2 [ACDMRTUX][0-9]+\tfile1(\tfile2)?
	    # only C and R name two files;
	    # last filename on the line is the one that matters.
	    # sha2 == 0{40} means that file changed in the working
	    # directory but git didn't bother to compute a new hash,
	    # so we fill it in if we can
	    my($h) = do_cmd_failok(qq(git-hash-object $f[-1] 2>&-));
	    $_ = join("\t","$1 $h $2",@f) if $h;
	 }
      }
   }
   return @changed;
}

# compute a hash value.
sub list_to_hash_value {
   return '' unless (@_);
   my @changed = @_;
   my ($diff_hash) = do_cmd
     (diffhash => sub {
	 # any available digest algorithm will do,
	 # but git-hash-object is guaranteed to be there.
	 open SUB2,"|git hash-object --stdin" or die "list_to_hash_value failed: $!";
	 print SUB2 @changed;
	 close SUB2;
      });
   return $diff_hash;
}


sub makeoverride_deffn {
   my ($odef,$mvs) = @_;
   my $do = "($odef)";
   return $do unless $mvs;

   # GNUmake does the following quoting of overridden variables
   # before stuffing them into MAKEOVERRIDES:
   #   (0) backslash (\) is backslash-escaped
   #   (1) space is backslash-escaped
   #   (2) dollar ($) is $-escaped
   # all variable settings are then joined with space.
   # The GNUmakefile hook also does
   #   (3) single quote (') is escaped as $Q
   # since single quote is the one character that needs special
   # treatment to survive shell-quoting and $Q is a safe
   # substitution because of (2)
   # Since the final destination is a doublequoted #define string
   # we need to undo (1)-(3) and backslash-escape all double quotes (")

   # undo quoting on $ and '
   $mvs =~ s/(?<!\$)(?:\$\$)*\K\$Q/'/g;
   $mvs =~ s/\$\$/\$/g;
   my %vars = ();
   # split at unescaped spaces, restore escaped spaces
   # leave all other backslashes in place
   foreach (map { s/\\ / /g; $_ } split /(?<!\\)(?:\\\\)*\K +/,$mvs) {
      # backslash-escape all double quotes
      s/"/\\\"/g;
      my($var,$value) = split '=',$_,2;
      $vars{$var} = $value;
   }
   $do .= qq( \\\n  $odef($_,"$vars{$_}")) foreach keys %vars;
   return $do;
}

####################################################################
# actual script starts here
####################################################################

# whatever happens, make sure we don't leave
# a bogus $version_file lying around
#
$SIG{__DIE__} = sub { 
   # child interpreters calling die() will get here, too.

   # re-throw error if we in an eval
   die @_ if $^S;

   unlink $version_file; 
};

# redirect STDOUT to STDERR
# 
# Since Makefile redirects stdout to /dev/null (otherwise anything
# that slips through would become a prequisite for the $version_file:
# target), there's no use for stdout anyway.
#
open STDOUT,'>&=2' or die "could not redirect STDOUT: $!";
select (STDOUT);
$|=1;

# diagnostic:  yes, we actually got called
print "Checking version...";

my %cache = 
  (
   VPREV  => '',   # previous commit ID
   UCOUNT => 0,	   # uncommitted build count
   WDIFF  => '',   # hash of uncommitted files
   GIT => '',	   # git version
   MAKE => '',
  );
read_cache(\%cache);


#
# do we need to rewrite version_src.h?
# reasons to do so include:
#
my $redo = 0;

# (1) make run with different options
#
my $make_overrides = $ENV{MAKEOVERRIDES} || '';
if ($make_overrides ne $cache{MAKE}) {
   print " (different make)"; 
   $cache{MAKE} = $make_overrides;
   $redo = 1; 
}

# (2) upgraded git
#
my ($git_version) = do_cmd('git --version');
$git_version =~ s/^git version +//;
if ($git_version ne $cache{GIT}) {
   print " (new git)"; 
   $cache{GIT} = $git_version;
   $redo = 1;
}

# (3) fresh commit
#
my ($commit_id) = do_cmd('git rev-parse HEAD');
if ($commit_id ne $cache{VPREV}) {
   $cache{VPREV} = $commit_id;
   $cache{UCOUNT} = 0;
   $cache{WDIFF} = '';
   $redo = 1;
}

# (4) there are uncommitted changes and these differ from the last build;
#     UCOUNT is the number of times we've built off the current commit
#     with distinct uncommitted changes
#
my @changed = git_real_diff();
my $diff_hash = list_to_hash_value(@changed);
if ($diff_hash ne $cache{WDIFF}) {
   $cache{WDIFF} = $diff_hash;
   if (!$diff_hash) {
      $cache{UCOUNT} = 0;
   }
   elsif ($diff_hash ne $cache{WDIFF}) {
      $cache{UCOUNT}++;
   }
   $redo = 1;
}


if (!$redo) {
   print "unchanged\n";
   close CACHE;
   goto done;
}
write_cache(\%cache);


# find most recent commit tagged as 'v<version-number>'
# parse the version number from it
#
my ($gdesc) = do_cmd(q(git describe --tags --match 'v[0-9]*'));
$gdesc =~ s/^v//;
my $ext;
my %defval = $gdesc =~ m/(\d+)\.(\d+)\.(\d+)(?:-(\d+))?/ 
  ? (
     MAJOR => $1,
     MINOR => $2,
     RELEASE => $3,
     EXT => qq(").($ext=($4 ? "+$4" : '').($cache{UCOUNT} ? "u$cache{UCOUNT}" : '')).qq("),
    )
  : (
     EXT => qq(").($ext="?$gdesc").qq("),
    );
my $vstring = $1 ? "$1.$2.$3${ext}" : "?? $gdesc";

# gather everything else we are going to write
#
my %deffn = 
  (
   MAKEVARS => makeoverride_deffn(DEF => $make_overrides),
   SOURCE => <<SRC ,
(DEF) \\
  DEF(vcs,"git") \\
  DEF(vcs_version,"$git_version") \\
  DEF(commit,"$commit_id") \\
  DEF(desc,"$gdesc")
SRC
  );

# and write the file
# 
open VSRC,">$version_file" or die "writing $version_file: $!";
print VSRC qq(#define VERSION_${_} $defval{${_}}\n) 
  foreach keys %defval;
print VSRC qq(#define VERSION_${_}$deffn{${_}}\n) 
  foreach keys %deffn;
close VSRC;

# diagnostic
print " $vstring\n";

done:
exit 0;