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