2010-05-01 Daniel Bates <dbates@rim.com>
[WebKit-https.git] / WebKitTools / Scripts / VCSUtils.pm
1 # Copyright (C) 2007, 2008, 2009 Apple Inc.  All rights reserved.
2 # Copyright (C) 2009, 2010 Chris Jerdonek (chris.jerdonek@gmail.com)
3 #
4 # Redistribution and use in source and binary forms, with or without
5 # modification, are permitted provided that the following conditions
6 # are met:
7 #
8 # 1.  Redistributions of source code must retain the above copyright
9 #     notice, this list of conditions and the following disclaimer. 
10 # 2.  Redistributions in binary form must reproduce the above copyright
11 #     notice, this list of conditions and the following disclaimer in the
12 #     documentation and/or other materials provided with the distribution. 
13 # 3.  Neither the name of Apple Computer, Inc. ("Apple") nor the names of
14 #     its contributors may be used to endorse or promote products derived
15 #     from this software without specific prior written permission. 
16 #
17 # THIS SOFTWARE IS PROVIDED BY APPLE AND ITS CONTRIBUTORS "AS IS" AND ANY
18 # EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
20 # DISCLAIMED. IN NO EVENT SHALL APPLE OR ITS CONTRIBUTORS BE LIABLE FOR ANY
21 # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
22 # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
23 # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
24 # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28 # Module to share code to work with various version control systems.
29 package VCSUtils;
30
31 use strict;
32 use warnings;
33
34 use Cwd qw();  # "qw()" prevents warnings about redefining getcwd() with "use POSIX;"
35 use English; # for $POSTMATCH, etc.
36 use File::Basename;
37 use File::Spec;
38 use POSIX;
39
40 BEGIN {
41     use Exporter   ();
42     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
43     $VERSION     = 1.00;
44     @ISA         = qw(Exporter);
45     @EXPORT      = qw(
46         &canonicalizePath
47         &changeLogEmailAddress
48         &changeLogName
49         &chdirReturningRelativePath
50         &decodeGitBinaryPatch
51         &determineSVNRoot
52         &determineVCSRoot
53         &exitStatus
54         &fixChangeLogPatch
55         &gitBranch
56         &gitdiff2svndiff
57         &isGit
58         &isGitBranchBuild
59         &isGitDirectory
60         &isSVN
61         &isSVNDirectory
62         &isSVNVersion16OrNewer
63         &makeFilePathRelative
64         &mergeChangeLogs
65         &normalizePath
66         &parsePatch
67         &pathRelativeToSVNRepositoryRootForPath
68         &prepareParsedPatch
69         &runPatchCommand
70         &svnRevisionForDirectory
71         &svnStatus
72     );
73     %EXPORT_TAGS = ( );
74     @EXPORT_OK   = ();
75 }
76
77 our @EXPORT_OK;
78
79 my $gitBranch;
80 my $gitRoot;
81 my $isGit;
82 my $isGitBranchBuild;
83 my $isSVN;
84 my $svnVersion;
85
86 # This method is for portability. Return the system-appropriate exit
87 # status of a child process.
88 #
89 # Args: pass the child error status returned by the last pipe close,
90 #       for example "$?".
91 sub exitStatus($)
92 {
93     my ($returnvalue) = @_;
94     if ($^O eq "MSWin32") {
95         return $returnvalue >> 8;
96     }
97     return WEXITSTATUS($returnvalue);
98 }
99
100 # Note, this method will not error if the file corresponding to the path does not exist.
101 sub scmToggleExecutableBit
102 {
103     my ($path, $executableBitDelta) = @_;
104     return if ! -e $path;
105     if ($executableBitDelta == 1) {
106         scmAddExecutableBit($path);
107     } elsif ($executableBitDelta == -1) {
108         scmRemoveExecutableBit($path);
109     }
110 }
111
112 sub scmAddExecutableBit($)
113 {
114     my ($path) = @_;
115
116     if (isSVN()) {
117         system("svn", "propset", "svn:executable", "on", $path) == 0 or die "Failed to run 'svn propset svn:executable on $path'.";
118     } elsif (isGit()) {
119         chmod(0755, $path);
120     }
121 }
122
123 sub scmRemoveExecutableBit($)
124 {
125     my ($path) = @_;
126
127     if (isSVN()) {
128         system("svn", "propdel", "svn:executable", $path) == 0 or die "Failed to run 'svn propdel svn:executable $path'.";
129     } elsif (isGit()) {
130         chmod(0664, $path);
131     }
132 }
133
134 sub isGitDirectory($)
135 {
136     my ($dir) = @_;
137     return system("cd $dir && git rev-parse > " . File::Spec->devnull() . " 2>&1") == 0;
138 }
139
140 sub isGit()
141 {
142     return $isGit if defined $isGit;
143
144     $isGit = isGitDirectory(".");
145     return $isGit;
146 }
147
148 sub gitBranch()
149 {
150     unless (defined $gitBranch) {
151         chomp($gitBranch = `git symbolic-ref -q HEAD`);
152         $gitBranch = "" if exitStatus($?);
153         $gitBranch =~ s#^refs/heads/##;
154         $gitBranch = "" if $gitBranch eq "master";
155     }
156
157     return $gitBranch;
158 }
159
160 sub isGitBranchBuild()
161 {
162     my $branch = gitBranch();
163     chomp(my $override = `git config --bool branch.$branch.webKitBranchBuild`);
164     return 1 if $override eq "true";
165     return 0 if $override eq "false";
166
167     unless (defined $isGitBranchBuild) {
168         chomp(my $gitBranchBuild = `git config --bool core.webKitBranchBuild`);
169         $isGitBranchBuild = $gitBranchBuild eq "true";
170     }
171
172     return $isGitBranchBuild;
173 }
174
175 sub isSVNDirectory($)
176 {
177     my ($dir) = @_;
178
179     return -d File::Spec->catdir($dir, ".svn");
180 }
181
182 sub isSVN()
183 {
184     return $isSVN if defined $isSVN;
185
186     $isSVN = isSVNDirectory(".");
187     return $isSVN;
188 }
189
190 sub svnVersion()
191 {
192     return $svnVersion if defined $svnVersion;
193
194     if (!isSVN()) {
195         $svnVersion = 0;
196     } else {
197         chomp($svnVersion = `svn --version --quiet`);
198     }
199     return $svnVersion;
200 }
201
202 sub isSVNVersion16OrNewer()
203 {
204     my $version = svnVersion();
205     return eval "v$version" ge v1.6;
206 }
207
208 sub chdirReturningRelativePath($)
209 {
210     my ($directory) = @_;
211     my $previousDirectory = Cwd::getcwd();
212     chdir $directory;
213     my $newDirectory = Cwd::getcwd();
214     return "." if $newDirectory eq $previousDirectory;
215     return File::Spec->abs2rel($previousDirectory, $newDirectory);
216 }
217
218 sub determineGitRoot()
219 {
220     chomp(my $gitDir = `git rev-parse --git-dir`);
221     return dirname($gitDir);
222 }
223
224 sub determineSVNRoot()
225 {
226     my $last = '';
227     my $path = '.';
228     my $parent = '..';
229     my $repositoryRoot;
230     my $repositoryUUID;
231     while (1) {
232         my $thisRoot;
233         my $thisUUID;
234         # Ignore error messages in case we've run past the root of the checkout.
235         open INFO, "svn info '$path' 2> " . File::Spec->devnull() . " |" or die;
236         while (<INFO>) {
237             if (/^Repository Root: (.+)/) {
238                 $thisRoot = $1;
239             }
240             if (/^Repository UUID: (.+)/) {
241                 $thisUUID = $1;
242             }
243             if ($thisRoot && $thisUUID) {
244                 local $/ = undef;
245                 <INFO>; # Consume the rest of the input.
246             }
247         }
248         close INFO;
249
250         # It's possible (e.g. for developers of some ports) to have a WebKit
251         # checkout in a subdirectory of another checkout.  So abort if the
252         # repository root or the repository UUID suddenly changes.
253         last if !$thisUUID;
254         $repositoryUUID = $thisUUID if !$repositoryUUID;
255         last if $thisUUID ne $repositoryUUID;
256
257         last if !$thisRoot;
258         $repositoryRoot = $thisRoot if !$repositoryRoot;
259         last if $thisRoot ne $repositoryRoot;
260
261         $last = $path;
262         $path = File::Spec->catdir($parent, $path);
263     }
264
265     return File::Spec->rel2abs($last);
266 }
267
268 sub determineVCSRoot()
269 {
270     if (isGit()) {
271         return determineGitRoot();
272     }
273
274     if (!isSVN()) {
275         # Some users have a workflow where svn-create-patch, svn-apply and
276         # svn-unapply are used outside of multiple svn working directores,
277         # so warn the user and assume Subversion is being used in this case.
278         warn "Unable to determine VCS root; assuming Subversion";
279         $isSVN = 1;
280     }
281
282     return determineSVNRoot();
283 }
284
285 sub svnRevisionForDirectory($)
286 {
287     my ($dir) = @_;
288     my $revision;
289
290     if (isSVNDirectory($dir)) {
291         my $svnInfo = `LC_ALL=C svn info $dir | grep Revision:`;
292         ($revision) = ($svnInfo =~ m/Revision: (\d+).*/g);
293     } elsif (isGitDirectory($dir)) {
294         my $gitLog = `cd $dir && LC_ALL=C git log --grep='git-svn-id: ' -n 1 | grep git-svn-id:`;
295         ($revision) = ($gitLog =~ m/ +git-svn-id: .+@(\d+) /g);
296     }
297     die "Unable to determine current SVN revision in $dir" unless (defined $revision);
298     return $revision;
299 }
300
301 sub pathRelativeToSVNRepositoryRootForPath($)
302 {
303     my ($file) = @_;
304     my $relativePath = File::Spec->abs2rel($file);
305
306     my $svnInfo;
307     if (isSVN()) {
308         $svnInfo = `LC_ALL=C svn info $relativePath`;
309     } elsif (isGit()) {
310         $svnInfo = `LC_ALL=C git svn info $relativePath`;
311     }
312
313     $svnInfo =~ /.*^URL: (.*?)$/m;
314     my $svnURL = $1;
315
316     $svnInfo =~ /.*^Repository Root: (.*?)$/m;
317     my $repositoryRoot = $1;
318
319     $svnURL =~ s/$repositoryRoot\///;
320     return $svnURL;
321 }
322
323 sub makeFilePathRelative($)
324 {
325     my ($path) = @_;
326     return $path unless isGit();
327
328     unless (defined $gitRoot) {
329         chomp($gitRoot = `git rev-parse --show-cdup`);
330     }
331     return $gitRoot . $path;
332 }
333
334 sub normalizePath($)
335 {
336     my ($path) = @_;
337     $path =~ s/\\/\//g;
338     return $path;
339 }
340
341 sub canonicalizePath($)
342 {
343     my ($file) = @_;
344
345     # Remove extra slashes and '.' directories in path
346     $file = File::Spec->canonpath($file);
347
348     # Remove '..' directories in path
349     my @dirs = ();
350     foreach my $dir (File::Spec->splitdir($file)) {
351         if ($dir eq '..' && $#dirs >= 0 && $dirs[$#dirs] ne '..') {
352             pop(@dirs);
353         } else {
354             push(@dirs, $dir);
355         }
356     }
357     return ($#dirs >= 0) ? File::Spec->catdir(@dirs) : ".";
358 }
359
360 sub removeEOL($)
361 {
362     my ($line) = @_;
363
364     $line =~ s/[\r\n]+$//g;
365     return $line;
366 }
367
368 sub svnStatus($)
369 {
370     my ($fullPath) = @_;
371     my $svnStatus;
372     open SVN, "svn status --non-interactive --non-recursive '$fullPath' |" or die;
373     if (-d $fullPath) {
374         # When running "svn stat" on a directory, we can't assume that only one
375         # status will be returned (since any files with a status below the
376         # directory will be returned), and we can't assume that the directory will
377         # be first (since any files with unknown status will be listed first).
378         my $normalizedFullPath = File::Spec->catdir(File::Spec->splitdir($fullPath));
379         while (<SVN>) {
380             # Input may use a different EOL sequence than $/, so avoid chomp.
381             $_ = removeEOL($_);
382             my $normalizedStatPath = File::Spec->catdir(File::Spec->splitdir(substr($_, 7)));
383             if ($normalizedFullPath eq $normalizedStatPath) {
384                 $svnStatus = "$_\n";
385                 last;
386             }
387         }
388         # Read the rest of the svn command output to avoid a broken pipe warning.
389         local $/ = undef;
390         <SVN>;
391     }
392     else {
393         # Files will have only one status returned.
394         $svnStatus = removeEOL(<SVN>) . "\n";
395     }
396     close SVN;
397     return $svnStatus;
398 }
399
400 # Convert some lines of a git-formatted patch to SVN format, while
401 # preserving any end-of-line characters.
402 #
403 # Note that this function returns unconverted lines unchanged -- for
404 # example Git-specific lines that may not have an SVN analogue.  In
405 # particular, applying this function to the lines of a Git patch will not
406 # necessarily result in an SVN-formatted patch.
407 sub gitdiff2svndiff($)
408 {
409     $_ = shift @_;
410
411     if (m#^diff --git \w/(.+) \w/([^\r\n]+)#) {
412         return "Index: $1$POSTMATCH";
413     }
414     if (m#^--- \w/([^\r\n]+)#) {
415         return "--- $1$POSTMATCH";
416     }
417     if (m#^\+\+\+ \w/([^\r\n]+)#) {
418         return "+++ $1$POSTMATCH";
419     }
420     return $_; # Allow "unrecognized" lines to pass through.
421 }
422
423 # Parse the next diff header from the given file handle, and advance
424 # the file handle so the last line read is the first line after the
425 # parsed header block.
426 #
427 # This subroutine dies if given leading junk or if the end of the header
428 # block could not be detected. The last line of a header block is a
429 # line beginning with "+++".
430 #
431 # Args:
432 #   $fileHandle: advanced so the last line read is the first line of the
433 #                next diff header. For SVN-formatted diffs, this is the
434 #                "Index:" line.
435 #   $line: the line last read from $fileHandle
436 #
437 # Returns ($headerHashRef, $lastReadLine):
438 #   $headerHashRef: a hash reference representing a diff header
439 #     copiedFromPath: if a file copy, the path from which the file was
440 #                     copied. Otherwise, undefined.
441 #     indexPath: the path in the "Index:" line.
442 #     sourceRevision: the revision number of the source. This is the same
443 #                     as the revision number the file was copied from, in
444 #                     the case of a file copy.
445 #     svnConvertedText: the header text with some lines converted to SVN
446 #                       format.  Git-specific lines are preserved.
447 #   $lastReadLine: the line last read from $fileHandle. This is the first
448 #                  line after the header ending.
449 sub parseDiffHeader($$)
450 {
451     my ($fileHandle, $line) = @_;
452
453     my $filter;
454     if ($line =~ m#^diff --git #) {
455         $filter = \&gitdiff2svndiff;
456     }
457     $line = &$filter($line) if $filter;
458
459     my $indexPath;
460     if ($line =~ /^Index: ([^\r\n]+)/) {
461         $indexPath = $1;
462     } else {
463         die("Could not parse first line of diff header: \"$line\".");
464     }
465
466     my %header;
467
468     my $foundHeaderEnding;
469     my $lastReadLine; 
470     my $sourceRevision;
471     my $svnConvertedText = $line;
472     while (<$fileHandle>) {
473         # Temporarily strip off any end-of-line characters to simplify
474         # regex matching below.
475         s/([\n\r]+)$//;
476         my $eol = $1;
477
478         $_ = &$filter($_) if $filter;
479
480         # Fix paths on ""---" and "+++" lines to match the leading
481         # index line.
482         if (s/^--- \S+/--- $indexPath/) {
483             # ---
484             if (/^--- .+\(revision (\d+)\)/) {
485                 $sourceRevision = $1 if ($1 != 0);
486                 if (/\(from (\S+):(\d+)\)$/) {
487                     # The "from" clause is created by svn-create-patch, in
488                     # which case there is always also a "revision" clause.
489                     $header{copiedFromPath} = $1;
490                     die("Revision number \"$2\" in \"from\" clause does not match " .
491                         "source revision number \"$sourceRevision\".") if ($2 != $sourceRevision);
492                 }
493             }
494         } elsif (s/^\+\+\+ \S+/+++ $indexPath/ ||
495                  /^Cannot display: file marked as a binary type.$/ || # SVN binary
496                  /^GIT binary patch$/) {
497             # +++
498             $foundHeaderEnding = 1;
499         }
500
501         $svnConvertedText .= "$_$eol"; # Also restore end-of-line characters.
502         if ($foundHeaderEnding) {
503             $lastReadLine = <$fileHandle>;
504             last;
505         }
506     } # $lastReadLine is undef if while loop ran out.
507
508     if (!$foundHeaderEnding) {
509         die("Did not find end of header block corresponding to index path \"$indexPath\".");
510     }
511
512     $header{indexPath} = $indexPath;
513     $header{sourceRevision} = $sourceRevision;
514     $header{svnConvertedText} = $svnConvertedText;
515
516     return (\%header, $lastReadLine);
517 }
518
519 # A %diffHash is a hash representing a source control diff of a single
520 # file operation (e.g. a file modification, copy, or delete).
521 #
522 # These hashes appear, for example, in the parseDiff(), parsePatch(),
523 # and prepareParsedPatch() subroutines of this package.
524 #
525 # The corresponding values are--
526 #
527 #   copiedFromPath: if a file copy, the path from which the file was
528 #                   copied. Otherwise, undefined.
529 #   indexPath: the path of the file. For SVN-formatted diffs, this is
530 #              the same as the path in the "Index:" line.
531 #   sourceRevision: the revision number of the source. This is the same
532 #                   as the revision number the file was copied from, in
533 #                   the case of a file copy.
534 #   svnConvertedText: the diff with some lines converted to SVN format.
535 #                     Git-specific lines are preserved.
536
537 # Parse one diff from a patch file created by svn-create-patch, and
538 # advance the file handle so the last line read is the first line
539 # of the next header block.
540 #
541 # This subroutine preserves any leading junk encountered before the header.
542 #
543 # Args:
544 #   $fileHandle: a file handle advanced to the first line of the next
545 #                header block. Leading junk is okay.
546 #   $line: the line last read from $fileHandle.
547 #
548 # Returns ($diffHashRef, $lastReadLine):
549 #   $diffHashRef: A reference to a %diffHash.
550 #                 See the %diffHash documentation above.
551 #   $lastReadLine: the line last read from $fileHandle
552 sub parseDiff($$)
553 {
554     my ($fileHandle, $line) = @_;
555
556     my $headerStartRegEx = qr#^Index: #; # SVN-style header for the default
557     my $gitHeaderStartRegEx = qr#^diff --git \w/#;
558
559     my $headerHashRef; # Last header found, as returned by parseDiffHeader().
560     my $svnText;
561     while (defined($line)) {
562         if (!$headerHashRef && ($line =~ $gitHeaderStartRegEx)) {
563             # Then assume all diffs in the patch are Git-formatted. This
564             # block was made to be enterable at most once since we assume
565             # all diffs in the patch are formatted the same (SVN or Git).
566             $headerStartRegEx = $gitHeaderStartRegEx;
567         }
568
569         if ($line !~ $headerStartRegEx) {
570             # Then we are in the body of the diff.
571             $svnText .= $line;
572             $line = <$fileHandle>;
573             next;
574         } # Otherwise, we found a diff header.
575
576         if ($headerHashRef) {
577             # Then this is the second diff header of this while loop.
578             last;
579         }
580
581         ($headerHashRef, $line) = parseDiffHeader($fileHandle, $line);
582
583         $svnText .= $headerHashRef->{svnConvertedText};
584     }
585
586     my %diffHashRef;
587     $diffHashRef{copiedFromPath} = $headerHashRef->{copiedFromPath};
588     $diffHashRef{indexPath} = $headerHashRef->{indexPath};
589     $diffHashRef{sourceRevision} = $headerHashRef->{sourceRevision};
590     $diffHashRef{svnConvertedText} = $svnText;
591
592     return (\%diffHashRef, $line);
593 }
594
595 # Parse a patch file created by svn-create-patch.
596 #
597 # Args:
598 #   $fileHandle: A file handle to the patch file that has not yet been
599 #                read from.
600 #
601 # Returns:
602 #   @diffHashRefs: an array of diff hash references.
603 #                  See the %diffHash documentation above.
604 sub parsePatch($)
605 {
606     my ($fileHandle) = @_;
607
608     my @diffHashRefs; # return value
609
610     my $line = <$fileHandle>;
611
612     while (defined($line)) { # Otherwise, at EOF.
613
614         my $diffHashRef;
615         ($diffHashRef, $line) = parseDiff($fileHandle, $line);
616
617         push @diffHashRefs, $diffHashRef;
618     }
619
620     return @diffHashRefs;
621 }
622
623 # Prepare the results of parsePatch() for use in svn-apply and svn-unapply.
624 #
625 # Args:
626 #   $shouldForce: Whether to continue processing if an unexpected
627 #                 state occurs.
628 #   @diffHashRefs: An array of references to %diffHashes.
629 #                  See the %diffHash documentation above.
630 #
631 # Returns $preparedPatchHashRef:
632 #   copyDiffHashRefs: A reference to an array of the $diffHashRefs in
633 #                     @diffHashRefs that represent file copies. The original
634 #                     ordering is preserved.
635 #   nonCopyDiffHashRefs: A reference to an array of the $diffHashRefs in
636 #                        @diffHashRefs that do not represent file copies.
637 #                        The original ordering is preserved.
638 #   sourceRevisionHash: A reference to a hash of source path to source
639 #                       revision number.
640 sub prepareParsedPatch($@)
641 {
642     my ($shouldForce, @diffHashRefs) = @_;
643
644     my %copiedFiles;
645
646     # Return values
647     my @copyDiffHashRefs = ();
648     my @nonCopyDiffHashRefs = ();
649     my %sourceRevisionHash = ();
650     for my $diffHashRef (@diffHashRefs) {
651         my $copiedFromPath = $diffHashRef->{copiedFromPath};
652         my $indexPath = $diffHashRef->{indexPath};
653         my $sourceRevision = $diffHashRef->{sourceRevision};
654         my $sourcePath;
655
656         if (defined($copiedFromPath)) {
657             # Then the diff is a copy operation.
658             $sourcePath = $copiedFromPath;
659
660             # FIXME: Consider printing a warning or exiting if
661             #        exists($copiedFiles{$indexPath}) is true -- i.e. if
662             #        $indexPath appears twice as a copy target.
663             $copiedFiles{$indexPath} = $sourcePath;
664
665             push @copyDiffHashRefs, $diffHashRef;
666         } else {
667             # Then the diff is not a copy operation.
668             $sourcePath = $indexPath;
669
670             push @nonCopyDiffHashRefs, $diffHashRef;
671         }
672
673         if (defined($sourceRevision)) {
674             if (exists($sourceRevisionHash{$sourcePath}) &&
675                 ($sourceRevisionHash{$sourcePath} != $sourceRevision)) {
676                 if (!$shouldForce) {
677                     die "Two revisions of the same file required as a source:\n".
678                         "    $sourcePath:$sourceRevisionHash{$sourcePath}\n".
679                         "    $sourcePath:$sourceRevision";
680                 }
681             }
682             $sourceRevisionHash{$sourcePath} = $sourceRevision;
683         }
684     }
685
686     my %preparedPatchHash;
687
688     $preparedPatchHash{copyDiffHashRefs} = \@copyDiffHashRefs;
689     $preparedPatchHash{nonCopyDiffHashRefs} = \@nonCopyDiffHashRefs;
690     $preparedPatchHash{sourceRevisionHash} = \%sourceRevisionHash;
691
692     return \%preparedPatchHash;
693 }
694
695 # If possible, returns a ChangeLog patch equivalent to the given one,
696 # but with the newest ChangeLog entry inserted at the top of the
697 # file -- i.e. no leading context and all lines starting with "+".
698 #
699 # If given a patch string not representable as a patch with the above
700 # properties, it returns the input back unchanged.
701 #
702 # WARNING: This subroutine can return an inequivalent patch string if
703 # both the beginning of the new ChangeLog file matches the beginning
704 # of the source ChangeLog, and the source beginning was modified.
705 # Otherwise, it is guaranteed to return an equivalent patch string,
706 # if it returns.
707 #
708 # Applying this subroutine to ChangeLog patches allows svn-apply to
709 # insert new ChangeLog entries at the top of the ChangeLog file.
710 # svn-apply uses patch with --fuzz=3 to do this. We need to apply
711 # this subroutine because the diff(1) command is greedy when matching
712 # lines. A new ChangeLog entry with the same date and author as the
713 # previous will match and cause the diff to have lines of starting
714 # context.
715 #
716 # This subroutine has unit tests in VCSUtils_unittest.pl.
717 sub fixChangeLogPatch($)
718 {
719     my $patch = shift; # $patch will only contain patch fragments for ChangeLog.
720
721     $patch =~ /(\r?\n)/;
722     my $lineEnding = $1;
723     my @lines = split(/$lineEnding/, $patch);
724
725     my $i = 0; # We reuse the same index throughout.
726
727     # Skip to beginning of first chunk.
728     for (; $i < @lines; ++$i) {
729         if (substr($lines[$i], 0, 1) eq "@") {
730             last;
731         }
732     }
733     my $chunkStartIndex = ++$i;
734
735     # Optimization: do not process if new lines already begin the chunk.
736     if (substr($lines[$i], 0, 1) eq "+") {
737         return $patch;
738     }
739
740     # Skip to first line of newly added ChangeLog entry.
741     # For example, +2009-06-03  Eric Seidel  <eric@webkit.org>
742     my $dateStartRegEx = '^\+(\d{4}-\d{2}-\d{2})' # leading "+" and date
743                          . '\s+(.+)\s+' # name
744                          . '<([^<>]+)>$'; # e-mail address
745
746     for (; $i < @lines; ++$i) {
747         my $line = $lines[$i];
748         my $firstChar = substr($line, 0, 1);
749         if ($line =~ /$dateStartRegEx/) {
750             last;
751         } elsif ($firstChar eq " " or $firstChar eq "+") {
752             next;
753         }
754         return $patch; # Do not change if, for example, "-" or "@" found.
755     }
756     if ($i >= @lines) {
757         return $patch; # Do not change if date not found.
758     }
759     my $dateStartIndex = $i;
760
761     # Rewrite overlapping lines to lead with " ".
762     my @overlappingLines = (); # These will include a leading "+".
763     for (; $i < @lines; ++$i) {
764         my $line = $lines[$i];
765         if (substr($line, 0, 1) ne "+") {
766           last;
767         }
768         push(@overlappingLines, $line);
769         $lines[$i] = " " . substr($line, 1);
770     }
771
772     # Remove excess ending context, if necessary.
773     my $shouldTrimContext = 1;
774     for (; $i < @lines; ++$i) {
775         my $firstChar = substr($lines[$i], 0, 1);
776         if ($firstChar eq " ") {
777             next;
778         } elsif ($firstChar eq "@") {
779             last;
780         }
781         $shouldTrimContext = 0; # For example, if "+" or "-" encountered.
782         last;
783     }
784     my $deletedLineCount = 0;
785     if ($shouldTrimContext) { # Also occurs if end of file reached.
786         splice(@lines, $i - @overlappingLines, @overlappingLines);
787         $deletedLineCount = @overlappingLines;
788     }
789
790     # Work backwards, shifting overlapping lines towards front
791     # while checking that patch stays equivalent.
792     for ($i = $dateStartIndex - 1; $i >= $chunkStartIndex; --$i) {
793         my $line = $lines[$i];
794         if (substr($line, 0, 1) ne " ") {
795             next;
796         }
797         my $text = substr($line, 1);
798         my $newLine = pop(@overlappingLines);
799         if ($text ne substr($newLine, 1)) {
800             return $patch; # Unexpected difference.
801         }
802         $lines[$i] = "+$text";
803     }
804
805     # Finish moving whatever overlapping lines remain, and update
806     # the initial chunk range.
807     my $chunkRangeRegEx = '^\@\@ -(\d+),(\d+) \+\d+,(\d+) \@\@$'; # e.g. @@ -2,6 +2,18 @@
808     if ($lines[$chunkStartIndex - 1] !~ /$chunkRangeRegEx/) {
809         # FIXME: Handle errors differently from ChangeLog files that
810         # are okay but should not be altered. That way we can find out
811         # if improvements to the script ever become necessary.
812         return $patch; # Error: unexpected patch string format.
813     }
814     my $skippedFirstLineCount = $1 - 1;
815     my $oldSourceLineCount = $2;
816     my $oldTargetLineCount = $3;
817
818     if (@overlappingLines != $skippedFirstLineCount) {
819         # This can happen, for example, when deliberately inserting
820         # a new ChangeLog entry earlier in the file.
821         return $patch;
822     }
823     # If @overlappingLines > 0, this is where we make use of the
824     # assumption that the beginning of the source file was not modified.
825     splice(@lines, $chunkStartIndex, 0, @overlappingLines);
826
827     my $sourceLineCount = $oldSourceLineCount + @overlappingLines - $deletedLineCount;
828     my $targetLineCount = $oldTargetLineCount + @overlappingLines - $deletedLineCount;
829     $lines[$chunkStartIndex - 1] = "@@ -1,$sourceLineCount +1,$targetLineCount @@";
830
831     return join($lineEnding, @lines) . "\n"; # patch(1) expects an extra trailing newline.
832 }
833
834 # This is a supporting method for runPatchCommand.
835 #
836 # Arg: the optional $args parameter passed to runPatchCommand (can be undefined).
837 #
838 # Returns ($patchCommand, $isForcing).
839 #
840 # This subroutine has unit tests in VCSUtils_unittest.pl.
841 sub generatePatchCommand($)
842 {
843     my ($passedArgsHashRef) = @_;
844
845     my $argsHashRef = { # Defaults
846         ensureForce => 0,
847         shouldReverse => 0,
848         options => []
849     };
850     
851     # Merges hash references. It's okay here if passed hash reference is undefined.
852     @{$argsHashRef}{keys %{$passedArgsHashRef}} = values %{$passedArgsHashRef};
853     
854     my $ensureForce = $argsHashRef->{ensureForce};
855     my $shouldReverse = $argsHashRef->{shouldReverse};
856     my $options = $argsHashRef->{options};
857
858     if (! $options) {
859         $options = [];
860     } else {
861         $options = [@{$options}]; # Copy to avoid side effects.
862     }
863
864     my $isForcing = 0;
865     if (grep /^--force$/, @{$options}) {
866         $isForcing = 1;
867     } elsif ($ensureForce) {
868         push @{$options}, "--force";
869         $isForcing = 1;
870     }
871
872     if ($shouldReverse) { # No check: --reverse should never be passed explicitly.
873         push @{$options}, "--reverse";
874     }
875
876     @{$options} = sort(@{$options}); # For easier testing.
877
878     my $patchCommand = join(" ", "patch -p0", @{$options});
879
880     return ($patchCommand, $isForcing);
881 }
882
883 # Apply the given patch using the patch(1) command.
884 #
885 # On success, return the resulting exit status. Otherwise, exit with the
886 # exit status. If "--force" is passed as an option, however, then never
887 # exit and always return the exit status.
888 #
889 # Args:
890 #   $patch: a patch string.
891 #   $repositoryRootPath: an absolute path to the repository root.
892 #   $pathRelativeToRoot: the path of the file to be patched, relative to the
893 #                        repository root. This should normally be the path
894 #                        found in the patch's "Index:" line. It is passed
895 #                        explicitly rather than reparsed from the patch
896 #                        string for optimization purposes.
897 #                            This is used only for error reporting. The
898 #                        patch command gleans the actual file to patch
899 #                        from the patch string.
900 #   $args: a reference to a hash of optional arguments. The possible
901 #          keys are --
902 #            ensureForce: whether to ensure --force is passed (defaults to 0).
903 #            shouldReverse: whether to pass --reverse (defaults to 0).
904 #            options: a reference to an array of options to pass to the
905 #                     patch command. The subroutine passes the -p0 option
906 #                     no matter what. This should not include --reverse.
907 #
908 # This subroutine has unit tests in VCSUtils_unittest.pl.
909 sub runPatchCommand($$$;$)
910 {
911     my ($patch, $repositoryRootPath, $pathRelativeToRoot, $args) = @_;
912
913     my ($patchCommand, $isForcing) = generatePatchCommand($args);
914
915     # Temporarily change the working directory since the path found
916     # in the patch's "Index:" line is relative to the repository root
917     # (i.e. the same as $pathRelativeToRoot).
918     my $cwd = Cwd::getcwd();
919     chdir $repositoryRootPath;
920
921     open PATCH, "| $patchCommand" or die "Could not call \"$patchCommand\" for file \"$pathRelativeToRoot\": $!";
922     print PATCH $patch;
923     close PATCH;
924     my $exitStatus = exitStatus($?);
925
926     chdir $cwd;
927
928     if ($exitStatus && !$isForcing) {
929         print "Calling \"$patchCommand\" for file \"$pathRelativeToRoot\" returned " .
930               "status $exitStatus.  Pass --force to ignore patch failures.\n";
931         exit $exitStatus;
932     }
933
934     return $exitStatus;
935 }
936
937 # Merge ChangeLog patches using a three-file approach.
938 #
939 # This is used by resolve-ChangeLogs when it's operated as a merge driver
940 # and when it's used to merge conflicts after a patch is applied or after
941 # an svn update.
942 #
943 # It's also used for traditional rejected patches.
944 #
945 # Args:
946 #   $fileMine:  The merged version of the file.  Also known in git as the
947 #               other branch's version (%B) or "ours".
948 #               For traditional patch rejects, this is the *.rej file.
949 #   $fileOlder: The base version of the file.  Also known in git as the
950 #               ancestor version (%O) or "base".
951 #               For traditional patch rejects, this is the *.orig file.
952 #   $fileNewer: The current version of the file.  Also known in git as the
953 #               current version (%A) or "theirs".
954 #               For traditional patch rejects, this is the original-named
955 #               file.
956 #
957 # Returns 1 if merge was successful, else 0.
958 sub mergeChangeLogs($$$)
959 {
960     my ($fileMine, $fileOlder, $fileNewer) = @_;
961
962     my $traditionalReject = $fileMine =~ /\.rej$/ ? 1 : 0;
963
964     local $/ = undef;
965
966     my $patch;
967     if ($traditionalReject) {
968         open(DIFF, "<", $fileMine) or die $!;
969         $patch = <DIFF>;
970         close(DIFF);
971         rename($fileMine, "$fileMine.save");
972         rename($fileOlder, "$fileOlder.save");
973     } else {
974         open(DIFF, "-|", qw(diff -u -a --binary), $fileOlder, $fileMine) or die $!;
975         $patch = <DIFF>;
976         close(DIFF);
977     }
978
979     unlink("${fileNewer}.orig");
980     unlink("${fileNewer}.rej");
981
982     open(PATCH, "| patch --force --fuzz=3 --binary $fileNewer > " . File::Spec->devnull()) or die $!;
983     print PATCH ($traditionalReject ? $patch : fixChangeLogPatch($patch));
984     close(PATCH);
985
986     my $result = !exitStatus($?);
987
988     # Refuse to merge the patch if it did not apply cleanly
989     if (-e "${fileNewer}.rej") {
990         unlink("${fileNewer}.rej");
991         if (-f "${fileNewer}.orig") {
992             unlink($fileNewer);
993             rename("${fileNewer}.orig", $fileNewer);
994         }
995     } else {
996         unlink("${fileNewer}.orig");
997     }
998
999     if ($traditionalReject) {
1000         rename("$fileMine.save", $fileMine);
1001         rename("$fileOlder.save", $fileOlder);
1002     }
1003
1004     return $result;
1005 }
1006
1007 sub gitConfig($)
1008 {
1009     return unless $isGit;
1010
1011     my ($config) = @_;
1012
1013     my $result = `git config $config`;
1014     if (($? >> 8)) {
1015         $result = `git repo-config $config`;
1016     }
1017     chomp $result;
1018     return $result;
1019 }
1020
1021 sub changeLogNameError($)
1022 {
1023     my ($message) = @_;
1024     print STDERR "$message\nEither:\n";
1025     print STDERR "  set CHANGE_LOG_NAME in your environment\n";
1026     print STDERR "  OR pass --name= on the command line\n";
1027     print STDERR "  OR set REAL_NAME in your environment";
1028     print STDERR "  OR git users can set 'git config user.name'\n";
1029     exit(1);
1030 }
1031
1032 sub changeLogName()
1033 {
1034     my $name = $ENV{CHANGE_LOG_NAME} || $ENV{REAL_NAME} || gitConfig("user.name") || (split /\s*,\s*/, (getpwuid $<)[6])[0];
1035
1036     changeLogNameError("Failed to determine ChangeLog name.") unless $name;
1037     # getpwuid seems to always succeed on windows, returning the username instead of the full name.  This check will catch that case.
1038     changeLogNameError("'$name' does not contain a space!  ChangeLogs should contain your full name.") unless ($name =~ /\w \w/);
1039
1040     return $name;
1041 }
1042
1043 sub changeLogEmailAddressError($)
1044 {
1045     my ($message) = @_;
1046     print STDERR "$message\nEither:\n";
1047     print STDERR "  set CHANGE_LOG_EMAIL_ADDRESS in your environment\n";
1048     print STDERR "  OR pass --email= on the command line\n";
1049     print STDERR "  OR set EMAIL_ADDRESS in your environment\n";
1050     print STDERR "  OR git users can set 'git config user.email'\n";
1051     exit(1);
1052 }
1053
1054 sub changeLogEmailAddress()
1055 {
1056     my $emailAddress = $ENV{CHANGE_LOG_EMAIL_ADDRESS} || $ENV{EMAIL_ADDRESS} || gitConfig("user.email");
1057
1058     changeLogEmailAddressError("Failed to determine email address for ChangeLog.") unless $emailAddress;
1059     changeLogEmailAddressError("Email address '$emailAddress' does not contain '\@' and is likely invalid.") unless ($emailAddress =~ /\@/);
1060
1061     return $emailAddress;
1062 }
1063
1064 # http://tools.ietf.org/html/rfc1924
1065 sub decodeBase85($)
1066 {
1067     my ($encoded) = @_;
1068     my %table;
1069     my @characters = ('0'..'9', 'A'..'Z', 'a'..'z', '!', '#', '$', '%', '&', '(', ')', '*', '+', '-', ';', '<', '=', '>', '?', '@', '^', '_', '`', '{', '|', '}', '~');
1070     for (my $i = 0; $i < 85; $i++) {
1071         $table{$characters[$i]} = $i;
1072     }
1073
1074     my $decoded = '';
1075     my @encodedChars = $encoded =~ /./g;
1076
1077     for (my $encodedIter = 0; defined($encodedChars[$encodedIter]);) {
1078         my $digit = 0;
1079         for (my $i = 0; $i < 5; $i++) {
1080             $digit *= 85;
1081             my $char = $encodedChars[$encodedIter];
1082             $digit += $table{$char};
1083             $encodedIter++;
1084         }
1085
1086         for (my $i = 0; $i < 4; $i++) {
1087             $decoded .= chr(($digit >> (3 - $i) * 8) & 255);
1088         }
1089     }
1090
1091     return $decoded;
1092 }
1093
1094 sub decodeGitBinaryChunk($$)
1095 {
1096     my ($contents, $fullPath) = @_;
1097
1098     # Load this module lazily in case the user don't have this module
1099     # and won't handle git binary patches.
1100     require Compress::Zlib;
1101
1102     my $encoded = "";
1103     my $compressedSize = 0;
1104     while ($contents =~ /^([A-Za-z])(.*)$/gm) {
1105         my $line = $2;
1106         next if $line eq "";
1107         die "$fullPath: unexpected size of a line: $&" if length($2) % 5 != 0;
1108         my $actualSize = length($2) / 5 * 4;
1109         my $encodedExpectedSize = ord($1);
1110         my $expectedSize = $encodedExpectedSize <= ord("Z") ? $encodedExpectedSize - ord("A") + 1 : $encodedExpectedSize - ord("a") + 27;
1111
1112         die "$fullPath: unexpected size of a line: $&" if int(($expectedSize + 3) / 4) * 4 != $actualSize;
1113         $compressedSize += $expectedSize;
1114         $encoded .= $line;
1115     }
1116
1117     my $compressed = decodeBase85($encoded);
1118     $compressed = substr($compressed, 0, $compressedSize);
1119     return Compress::Zlib::uncompress($compressed);
1120 }
1121
1122 sub decodeGitBinaryPatch($$)
1123 {
1124     my ($contents, $fullPath) = @_;
1125
1126     # Git binary patch has two chunks. One is for the normal patching
1127     # and another is for the reverse patching.
1128     #
1129     # Each chunk a line which starts from either "literal" or "delta",
1130     # followed by a number which specifies decoded size of the chunk.
1131     # The "delta" type chunks aren't supported by this function yet.
1132     #
1133     # Then, content of the chunk comes. To decode the content, we
1134     # need decode it with base85 first, and then zlib.
1135     my $gitPatchRegExp = '(literal|delta) ([0-9]+)\n([A-Za-z0-9!#$%&()*+-;<=>?@^_`{|}~\\n]*?)\n\n';
1136     if ($contents !~ m"\nGIT binary patch\n$gitPatchRegExp$gitPatchRegExp\Z") {
1137         die "$fullPath: unknown git binary patch format"
1138     }
1139
1140     my $binaryChunkType = $1;
1141     my $binaryChunkExpectedSize = $2;
1142     my $encodedChunk = $3;
1143     my $reverseBinaryChunkType = $4;
1144     my $reverseBinaryChunkExpectedSize = $5;
1145     my $encodedReverseChunk = $6;
1146
1147     my $binaryChunk = decodeGitBinaryChunk($encodedChunk, $fullPath);
1148     my $binaryChunkActualSize = length($binaryChunk);
1149     my $reverseBinaryChunk = decodeGitBinaryChunk($encodedReverseChunk, $fullPath);
1150     my $reverseBinaryChunkActualSize = length($reverseBinaryChunk);
1151
1152     die "$fullPath: unexpected size of the first chunk (expected $binaryChunkExpectedSize but was $binaryChunkActualSize" if ($binaryChunkExpectedSize != $binaryChunkActualSize);
1153     die "$fullPath: unexpected size of the second chunk (expected $reverseBinaryChunkExpectedSize but was $reverseBinaryChunkActualSize" if ($reverseBinaryChunkExpectedSize != $reverseBinaryChunkActualSize);
1154
1155     return ($binaryChunkType, $binaryChunk, $reverseBinaryChunkType, $reverseBinaryChunk);
1156 }
1157
1158 1;