DEVEL/hooksdir/NHsubst

   1 #!/usr/bin/perl
   2 #
   3 # NHsubst
   4 # $NHDT-Date$
   5 # git merge driver for substitutions (like RCS/CVS)
   6 # driver line:   .... %O %A %B %L
   7 use strict;
   8
   9 my $debug = 0;
  10 my $rawin = 0;  # feed diff to stdin for testing (do NOT set $debug=1)
  11
  12 # We want TRACE open so we don't need to test $debug everywhere, but we skip
  13 # this first block because it's expensive and dumpfile() hangs with $rawin.
  14 my $sink = ($^O eq "MSWin32") ? "NUL" : "/dev/null";
  15 my $dbgfile = ($^O eq "MSWin32") ? "$ENV{TEMP}.$$" : "/tmp/trace.$$";
  16 open TRACE, ">>", $rawin?"/dev/tty":(($debug==0)? $sink : $dbgfile);
  17 print TRACE "TEST TRACE\n";
  18 if($debug){
  19         print TRACE "START CLIENT ARGV:\n";
  20         print TRACE "[0] $0\n";
  21         my $x1;
  22         for(my $x=0;$x<scalar @ARGV;$x++){
  23                 $x1 = $x+1;
  24                 print TRACE "[$x1] $ARGV[$x]\n";
  25         }
  26         print TRACE "ENV:\n";
  27         foreach my $k (sort keys %ENV){
  28                 next unless ($k =~ m/^GIT_/);
  29                 print TRACE " $k => $ENV{$k}\n";
  30         }
  31         print TRACE "CWD: " . `pwd`;
  32         &dumpfile($ARGV[0], "[0O]");
  33         &dumpfile($ARGV[1], "[1A]");
  34         &dumpfile($ARGV[2], "[2B]");
  35         print TRACE "L=$ARGV[3]\n";
  36         print TRACE "END\n";
  37 }
  38
  39 my $mark_len = $ARGV[3];
  40 $mark_len = 3 if($mark_len==0 && $rawin);
  41
  42 my $mark_start = '<' x $mark_len;
  43 my $mark_middle = '=' x $mark_len;
  44 my $mark_end = '>' x $mark_len;
  45
  46 my $PREFIX;
  47 # pick up the prefix for substitutions in this repo
  48 if($rawin){
  49         $PREFIX = "TEST";
  50 } else {
  51         $PREFIX = `git config --local --get nethack.substprefix`;
  52         chomp($PREFIX);
  53 }
  54
  55 my @out;
  56 my $cntout;
  57 if($rawin){
  58         @out = <STDIN>;
  59 } else {
  60         #system "git merge-file -p .... > temp
  61         my $tags = "-L CURRENT -L ANCESTOR -L OTHER";   # XXX should "CURRENT" be "MINE"?
  62         @out = `git merge-file -p $tags $ARGV[1] $ARGV[0] $ARGV[2]`;
  63         #NB: we don't check the exit value because it's useless
  64         print TRACE "MERGE-FILE START\n".join("",@out)."MERGE-FILE END\n";
  65 }
  66
  67 ($cntout,@out) = &edit_merge(@out);
  68
  69 if($rawin){
  70         print "COUNT: $cntout\n";
  71         print @out;
  72 } else {
  73         # spit @out to $ARGV[1]  (careful: what about EOL character?)
  74         open OUT, ">$ARGV[1]" or die "Can't open $ARGV[1]";
  75         print OUT @out;
  76         close OUT;
  77
  78         print TRACE "WRITING START ($ARGV[1])\n".join("",@out)."WRITING END\n";
  79         &dumpfile($ARGV[1], "READBACK");
  80 }
  81 print TRACE "COUNT: $cntout\n";
  82
  83 exit( ($cntout>0) ? 1 : 0);
  84
  85 #git merge-file [-L <current-name> [-L <base-name> [-L <other-name>]]]
  86 #               [--ours|--theirs|--union] [-p|--stdout] [-q|--quiet] [--marker-size=<n>]
  87 #               [--[no-]diff3] <current-file> <base-file> <other-file>
  88 #The `merge.*.driver` variable's value is used to construct a command to run to merge ancestor's
  89 #           version (%O), current version (%A) and the other branches' version (%B). These three tokens are
  90 #           replaced with the names of temporary files that hold the contents of these versions when the
  91 #           command line is built. Additionally, %L will be replaced with the conflict marker size (see
  92 #           below).
  93
  94 # keep failing so we don't need to keep changing the setup while building this script
  95
  96 sub dumpfile {
  97         my($file, $tag) = @_;
  98         print TRACE "FILE $tag START\n";
  99         print TRACE `hexdump -C $file`;
 100         print TRACE "FILE END\n";
 101 }
 102
 103 sub edit_merge {
 104         my(@input) = @_;
 105                                         # $::count is a bit ugly XXX
 106         local $::count = 0;             # we need the number of conflicts for exit()
 107         my @out;
 108
 109         local $_;
 110         while($_ = shift @input){
 111                 if(m/^$mark_start /){
 112                         print TRACE "FOUND A CONFLICT\n";
 113                         my @conflict;
 114                         push(@conflict, $_);
 115                         while($_ = shift @input){
 116                                 push(@conflict, $_);
 117                                 if(m/^$mark_end /){
 118                                         last;
 119                                 }
 120                         }
 121                         push(@out, &edit_conflict(@conflict));
 122                 } else {
 123                         push(@out, $_);
 124                 }
 125         }
 126         print TRACE "RETURN count=$::count\n";
 127         return($::count, @out);
 128 }
 129
 130 sub edit_conflict {
 131         my(@in) = @_;
 132
 133         print TRACE "EDIT START: " . scalar(@in)."\n";
 134         if($debug){
 135                 foreach my $x (@in){ my $xx = $x; chomp($xx); print TRACE "-$xx-\n"; }
 136         }
 137         print TRACE "EDIT END INPUT\n";
 138
 139                 # one-line change - use as base case to develop the code
 140                 #   ours        ARGV[1] top-of-diff
 141                 #   theirs      ARGV[2] bottom-of-diff
 142                 # simple conflict:
 143                 # [0] <<<<<<< d1
 144                 # [1] $$PREFIX-Date: 1 ...
 145                 # [2] =======
 146                 # [3] $$PREFIX-Date: 3 ...
 147                 # [4] >>>>>>> d3
 148         if(scalar(@in) == 5 && $in[2] =~ m/^$mark_middle/){
 149                 my $back = &merge_one_line_maybe($in[1],$in[3]);        # (ours, theirs)
 150                 if(!defined $back){
 151                         $::count++;     # leave the conflict
 152                         return @in;
 153                 } else {
 154                         return ($back);
 155                 }
 156                 # NOTREACHED
 157         } else {
 158 # XXX LATER
 159 # Start at the top of both sections and work downwards.  As long as the lines can be merged,
 160 # push them out and keep going.  If there are lines left, we will still have a conflict but
 161 # we can try to make it smaller.  Push out the start-conflict marker.  Start at the
 162 # bottom of both section and work upwards.  As long as the lines can be merged, reverse push out
 163 # the merged line and keep going.  (We know there will be lines left at some point.)  Push out
 164 # remaining (middle) lines from OURS.  Push out mark_middle.  Push out remaining middle lines
 165 # from THEIRS.  Push out end-conflict marker.  $::count++; return (@a,$b,@c,$d,@e,$f,@g)
 166 # @a
 167 # $b = <<<
 168 # @c
 169 # $d = ===
 170 # @e
 171 # $f = >>>
 172 # @g
 173         }
 174                 # not matched - return the unchanged conflict
 175         $::count++;
 176         return @in;
 177 }
 178
 179 # XXX This is expensive.  Add a quick check for "anything that looks like a subst var" and just
 180 #  declare the lines unmergeable if it fails.
 181 sub merge_one_line_maybe {
 182         my($ours, $theirs) = @_;
 183
 184         my $more = 1;
 185         my $fail = 0;
 186         my $out = '';
 187                 # TYPES:
 188                 # 0 no match
 189                 # 1 unexpanded var
 190                 # 2 expanded var
 191                 # 3 non-var text
 192         my($ourstype, $theirtype);
 193         my($oursvar, $theirvar);
 194         my($oursval, $theirval);
 195
 196         while($more){
 197                 ($ourstype, $theirtype) = (0,0);
 198                 ($oursvar, $theirvar) = (undef, undef);
 199                 ($oursvar, $theirvar) = (undef, undef);
 200                         # unexpanded var
 201                 if($ours =~ m/\G\$$PREFIX-([A-Z][a-z]+)\$/gc){
 202                         $ourstype = 1;
 203                         $oursvar = $1;
 204                 }
 205                 if($theirs =~ m/\G\$$PREFIX-([A-Z][a-z]+)\$/gc){
 206                         $theirtype = 1;
 207                         $theirvar = $1;
 208                 }
 209                         # expanded var
 210                 unless($ourstype){
 211                         if($ours =~ m/\G\$$PREFIX-([A-Za-z]+):\s+(.*?)\s\$/gc){
 212                                 $ourstype = 2;
 213                                 $oursvar = $1;
 214                                 $oursval = $2;
 215                         }
 216                 }
 217                 unless($theirtype){
 218                         if($theirs =~ m/\G\$$PREFIX-([A-Za-z]+):\s+(.*?)\s\$/gc){
 219                                 $theirtype = 2;
 220                                 $theirvar = $1;
 221                                 $theirval = $2;
 222                         }
 223                 }
 224                         # non-var text
 225                 unless($ourstype){
 226                         if($ours =~ m/\G(\$?[^\x24]*)/gc){
 227                                 $ourstype = 3;
 228                                 $oursval = $1;
 229                         }
 230                 }
 231                 unless($theirtype){
 232                         if($theirs =~ m/\G(\$?[^\x24]*)/gc){
 233                                 $theirtype = 3;
 234                                 $theirval = $1;
 235                         }
 236                 }
 237 print TRACE "MID: $ourstype/$oursval $theirtype/$theirval\n";
 238                 # are we done?
 239                 if(pos($ours)==length $ours && pos($theirs) == length $theirs){
 240                         $more = 0;
 241                 }
 242                 if($ourstype == 0 && $theirtype == 0){
 243                         die "NHsubst MERGE FAILED - aborted infinite loop\n";
 244                 }
 245
 246                 # now see if ours and their match or can be resolved
 247                         # text
 248                 if($ourstype == 3 && $theirtype == 3){
 249 #mismatch is \s vs \s\s - where is this coming from?
 250                         # HACK - hopefully temporary
 251                         if($oursval =~ m/^\s+$/ && $theirval =~ m/^\s+$/){
 252                                 $out .= $oursval;
 253                                 next;
 254                         }
 255                         if($oursval eq $theirval){
 256                                 $out .= $oursval;
 257                                 next;
 258                         }
 259                         return undef;
 260                 }
 261                 if($ourstype == 3 || $theirtype == 3){
 262                         return undef;
 263                 }
 264 # XXX we could do better: on failure of one field, return 2 lines with the fields we _can_ fix
 265 #  substituted into those lines, leaving only the fail-to-match bits for the user to
 266 #  deal with.  Later.
 267                         # vars (all 4 cases)
 268                 if($oursvar ne $theirvar){
 269                         return undef;
 270                 }
 271                 my $m = merge_one_var_maybe($oursvar, $oursval, $theirval);
 272                 if(! defined $m){
 273                         return undef;
 274                 }
 275                 $out .= $m;
 276         }
 277         return $out;
 278 }
 279
 280 # return undef if we can't merge the values; $NAME: VALUE $ or $NAME$ (as appropriate) if we can.
 281 sub merge_one_var_maybe {
 282         my($varname, $oursval, $theirval) = @_;
 283 print TRACE "MVM: -$varname-$oursval-$theirval-\n";
 284         my $resolvedas;
 285         {
 286                 no strict;
 287                 my $fn = "PREFIX::$varname";
 288                 if(defined &$fn){
 289                         $resolvedas = &$fn($PREFIX,$varname,$oursval, $theirval);
 290                 } else {
 291                         $resolvedas = undef;    # can't resolve
 292                 }
 293         }
 294
 295         if(!defined $resolvedas){
 296                 $::count++;     # we have an externally visible conflict
 297                 return undef;
 298         } else {
 299                 return $resolvedas;
 300         }
 301         # NOTREACHED
 302 }
 303
 304 package PREFIX;
 305 # Resolve the conflict of a single var's 2 values.  Return undef to leave the conflict.
 306 sub Date {
 307         my($PREFIX, $varname, $mine, $theirs) = @_;
 308         my $m = ($mine =~ m/(\d+)/)[0];
 309         my $t = ($theirs =~ m/(\d+)/)[0];
 310         return undef unless ($m>0) && ($t>0);
 311
 312         return "\$$PREFIX-$varname: " . (($m>$t)?$mine:$theirs) .' $';
 313 }
 314
 315 #sub Header {
 316 #sub Author {
 317
 318 sub Branch {
 319         my($PREFIX, $varname, $mine, $theirs) = @_;
 320         $mine =~ s/^\s+//;      $mine =~ s/\s+$//;
 321         $theirs =~ s/^\s+//;    $theirs =~ s/\s+$//;
 322         return "\$$PREFIX-$varname: $mine \$" if(length $mine);
 323         return "\$$PREFIX-$varname: $theirs \$" if(length $theirs);
 324         return "\$$PREFIX-$varname\$" if(length $theirs);
 325 }
 326
 327 sub Revision {
 328         my($PREFIX, $varname, $mine, $theirs) = @_;
 329         my($m) = ($mine =~ m/1.(\d+)/);
 330         my($t) = ($theirs =~ m/1.(\d+)/);
 331         if($m > 0 && $t > 0){
 332                 my $q = ($m > $t) ? $m : $t;
 333                 return "\$$PREFIX-$varname: 1.$q \$";
 334         }
 335         if($m > 0){
 336                 return "\$$PREFIX-$varname: 1.$m \$";
 337         }
 338         if($t > 0){
 339                 return "\$$PREFIX-$varname: 1.$t \$";
 340         }
 341         return "\$$PREFIX-$varname\$";
 342 }
 343 __END__
 344
 345 TEST 1:
 346 <<< d1
 347 $TEST-Date: 1 $
 348 ===
 349 $TEST-Date: 3 $
 350 >>> d3
 351
 352 TEST 2:
 353 nothing
 354 at all
 355
 356 TEST 3:
 357 <<< d1
 358 a line
 359 ===
 360 one line
 361 two lines
 362 >>> d3
 363
 364 TEST 4:
 365 <<< d1
 366 $TEST-Date: 1 $ yes
 367 ===
 368 $TEST-Date: 1 $ no
 369 >>> d3
 370
 371 TEST 5:
 372 <<< d1
 373 $TEST-Date: 3 $ yes
 374 ===
 375 $TEST-Date: 1 $ yes
 376 >>> d3
 377
 378 TEST 6:
 379 <<< d1
 380 $TEST-Date: 3 $ yes$TEST-Date: 4 $
 381 ===
 382 $TEST-Date: 1 $ yes$TEST-Date: 5 $
 383 >>> d3
 384
 385 TEST 7:
 386 <<< d1
 387 $TEST-Branch: mine $
 388 ===
 389 $TEST-Branch: theirs $
 390 >>> d3
 391
 392 TEST 8:
 393 <<< d1
 394 /* NetHack 3.6        objnam.c        $TEST-Date$ $TEST-Branch$:$TEST-Revision$ */
 395 ===
 396 /* NetHack 3.6        objnam.c        $TEST-Date: 1426977394 2015/03/21 22:36:34 $  $TEST-Branch: master $:$TEST-Revision: 1.108 $ */
 397 >>> d3