DEVEL/hooksdir/NHsubst

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