#!/usr/bin/perl -w
# -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 2 -*-
#
# Copyright (C) 2000, 2001 Eazel, Inc.
# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Apple Inc. All rights reserved.
# Copyright (C) 2009 Torch Mobile, Inc.
# Copyright (C) 2009 Cameron McCormack <cam@mcc.id.au>
#
# prepare-ChangeLog is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# prepare-ChangeLog is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the Free
# Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# Perl script to create a ChangeLog entry with names of files
# and functions from a diff.
#
# Darin Adler <darin@bentspoon.com>, started 20 April 2000
# Java support added by Maciej Stachowiak <mjs@eazel.com>
# Objective-C, C++ and Objective-C++ support added by Maciej Stachowiak <mjs@apple.com>
# Git support added by Adam Roben <aroben@apple.com>
# --git-index flag added by Joe Mason <joe.mason@torchmobile.com>
#
# TODO:
# List functions that have been removed too.
# Decide what a good logical order is for the changed files
# other than a normal text "sort" (top level first?)
# (group directories?) (.h before .c?)
# Handle yacc source files too (other languages?).
# Help merge when there are ChangeLog conflicts or if there's
# already a partly written ChangeLog entry.
# Add command line option to put the ChangeLog into a separate file.
# Add SVN version numbers for commit (can't do that until
# the changes are checked in, though).
# Work around diff stupidity where deleting a function that starts
# with a comment makes diff think that the following function
# has been changed (if the following function starts with a comment
# with the same first line, such as /**)
# Work around diff stupidity where deleting an entire function and
# the blank lines before it makes diff think you've changed the
# previous function.
use strict;
use warnings;
use File::Basename;
use File::Spec;
use FindBin;
use Getopt::Long;
use lib $FindBin::Bin;
use POSIX qw(strftime);
use VCSUtils;
sub changeLogDate($);
sub changeLogEmailAddressFromArgs($);
sub changeLogNameFromArgs($);
sub firstDirectoryOrCwd();
sub diffFromToString();
sub diffCommand(@);
sub statusCommand(@);
sub createPatchCommand($);
sub diffHeaderFormat();
sub findOriginalFileFromSvn($);
sub determinePropertyChanges($$$);
sub pluralizeAndList($$@);
sub generateFileList(\@\@\%);
sub isUnmodifiedStatus($);
sub isModifiedStatus($);
sub isAddedStatus($);
sub isConflictStatus($);
sub statusDescription($$$$);
sub propertyChangeDescription($);
sub extractLineRange($);
sub testListForChangeLog(@);
sub get_function_line_ranges($$);
sub get_function_line_ranges_for_c($$);
sub get_function_line_ranges_for_java($$);
sub get_function_line_ranges_for_javascript($$);
sub get_selector_line_ranges_for_css($$);
sub method_decl_to_selector($);
sub processPaths(\@);
sub reviewerAndDescriptionForGitCommit($);
sub normalizeLineEndings($$);
sub decodeEntities($);
# Project time zone for Cupertino, CA, US
my $changeLogTimeZone = "PST8PDT";
my $bugDescription;
my $bugNumber;
my $name;
my $emailAddress;
my $mergeBase = 0;
my $gitCommit = 0;
my $gitIndex = "";
my $gitReviewer = "";
my $openChangeLogs = 0;
my $writeChangeLogs = 1;
my $showHelp = 0;
my $spewDiff = $ENV{"PREPARE_CHANGELOG_DIFF"};
my $updateChangeLogs = 1;
my $parseOptionsResult =
GetOptions("diff|d!" => \$spewDiff,
"bug|b:i" => \$bugNumber,
"description:s" => \$bugDescription,
"name:s" => \$name,
"email:s" => \$emailAddress,
"merge-base:s" => \$mergeBase,
"git-commit|g:s" => \$gitCommit,
"git-index" => \$gitIndex,
"git-reviewer:s" => \$gitReviewer,
"help|h!" => \$showHelp,
"open|o!" => \$openChangeLogs,
"write!" => \$writeChangeLogs,
"update!" => \$updateChangeLogs);
if (!$parseOptionsResult || $showHelp) {
print STDERR basename($0) . " [-b|--bug=<bugid>] [-d|--diff] [-h|--help] [-o|--open] [-g|--git-commit=<committish>] [--git-reviewer=<name>] [svndir1 [svndir2 ...]]\n";
print STDERR " -b|--bug Fill in the ChangeLog bug information from the given bug.\n";
print STDERR " --description One-line description that matches the bug title.\n";
print STDERR " -d|--diff Spew diff to stdout when running\n";
print STDERR " --merge-base Populate the ChangeLogs with the diff to this branch\n";
print STDERR " -g|--git-commit Populate the ChangeLogs from the specified git commit\n";
print STDERR " --git-index Populate the ChangeLogs from the git index only\n";
print STDERR " --git-reviewer When populating the ChangeLogs from a git commit claim that the spcified name reviewed the change.\n";
print STDERR " This option is useful when the git commit lacks a Signed-Off-By: line\n";
print STDERR " -h|--help Show this help message\n";
print STDERR " -o|--open Open ChangeLogs in an editor when done\n";
print STDERR " --[no-]update Update ChangeLogs from svn before adding entry (default: update)\n";
print STDERR " --[no-]write Write ChangeLogs to disk (otherwise send new entries to stdout) (default: write)\n";
print STDERR " --email= Specify the email address to be used in the patch\n";
exit 1;
}
die "--git-commit and --git-index are incompatible." if ($gitIndex && $gitCommit);
my %paths = processPaths(@ARGV);
my $isGit = isGitDirectory(firstDirectoryOrCwd());
my $isSVN = isSVNDirectory(firstDirectoryOrCwd());
$isSVN || $isGit || die "Couldn't determine your version control system.";
my $SVN = "svn";
my $GIT = "git";
# Find the list of modified files
my @changed_files;
my $changed_files_string;
my %changed_line_ranges;
my %function_lists;
my @conflict_files;
my %supportedTestExtensions = map { $_ => 1 } qw(html shtml svg xml xhtml pl php);
my @addedRegressionTests = ();
my $didChangeRegressionTests = 0;
generateFileList(@changed_files, @conflict_files, %function_lists);
if (!@changed_files && !@conflict_files && !keys %function_lists) {
print STDERR " No changes found.\n";
exit 1;
}
if (@conflict_files) {
print STDERR " The following files have conflicts. Run prepare-ChangeLog again after fixing the conflicts:\n";
print STDERR join("\n", @conflict_files), "\n";
exit 1;
}
if (@changed_files) {
$changed_files_string = "'" . join ("' '", @changed_files) . "'";
# For each file, build a list of modified lines.
# Use line numbers from the "after" side of each diff.
print STDERR " Reviewing diff to determine which lines changed.\n";
my $file;
open DIFF, "-|", diffCommand(@changed_files) or die "The diff failed: $!.\n";
while (<DIFF>) {
$file = makeFilePathRelative($1) if $_ =~ diffHeaderFormat();
if (defined $file) {
my ($start, $end) = extractLineRange($_);
if ($start >= 0 && $end >= 0) {
push @{$changed_line_ranges{$file}}, [ $start, $end ];
} elsif (/DO_NOT_COMMIT/) {
print STDERR "WARNING: file $file contains the string DO_NOT_COMMIT, line $.\n";
}
}
}
close DIFF;
}
# For each source file, convert line range to function list.
if (%changed_line_ranges) {
print STDERR " Extracting affected function names from source files.\n";
foreach my $file (keys %changed_line_ranges) {
# Only look for function names in certain source files.
next unless $file =~ /\.(c|cpp|m|mm|h|java|js)/;
# Find all the functions in the file.
open SOURCE, $file or next;
my @function_ranges = get_function_line_ranges(\*SOURCE, $file);
close SOURCE;
# Find all the modified functions.
my @functions;
my %saw_function;
my @change_ranges = (@{$changed_line_ranges{$file}}, []);
my @change_range = (0, 0);
FUNCTION: foreach my $function_range_ref (@function_ranges) {
my @function_range = @$function_range_ref;
# Advance to successive change ranges.
for (;; @change_range = @{shift @change_ranges}) {
last FUNCTION unless @change_range;
# If past this function, move on to the next one.
next FUNCTION if $change_range[0] > $function_range[1];
# If an overlap with this function range, record the function name.
if ($change_range[1] >= $function_range[0]
and $change_range[0] <= $function_range[1]) {
if (!$saw_function{$function_range[2]}) {
$saw_function{$function_range[2]} = 1;
push @functions, $function_range[2];
}
next FUNCTION;
}
}
}
# Format the list of functions now.
if (@functions) {
$function_lists{$file} = "" if !defined $function_lists{$file};
$function_lists{$file} .= "\n (" . join("):\n (", @functions) . "):";
}
}
}
# Get some parameters for the ChangeLog we are about to write.
my $date = changeLogDate($changeLogTimeZone);
$name = changeLogNameFromArgs($name);
$emailAddress = changeLogEmailAddressFromArgs($emailAddress);
print STDERR " Change author: $name <$emailAddress>.\n";
my $bugURL;
if ($bugNumber) {
$bugURL = "https://bugs.webkit.org/show_bug.cgi?id=$bugNumber";
}
if ($bugNumber && !$bugDescription) {
my $bugXMLURL = "$bugURL&ctype=xml";
# Perl has no built in XML processing, so we'll fetch and parse with curl and grep
# Pass --insecure because some cygwin installs have no certs we don't
# care about validating that bugs.webkit.org is who it says it is here.
my $descriptionLine = `curl --insecure --silent "$bugXMLURL" | grep short_desc`;
if ($descriptionLine !~ /<short_desc>(.*)<\/short_desc>/) {
# Maybe the reason the above did not work is because the curl that is installed doesn't
# support ssl at all.
if (`curl --version | grep ^Protocols` !~ /\bhttps\b/) {
print STDERR " Could not get description for bug $bugNumber.\n";
print STDERR " It looks like your version of curl does not support ssl.\n";
print STDERR " If you are using macports, this can be fixed with sudo port install curl +ssl.\n";
} else {
print STDERR " Bug $bugNumber has no bug description. Maybe you set wrong bug ID?\n";
print STDERR " The bug URL: $bugXMLURL\n";
}
exit 1;
}
$bugDescription = decodeEntities($1);
print STDERR " Description from bug $bugNumber:\n \"$bugDescription\".\n";
}
# Remove trailing parenthesized notes from user name (bit of hack).
$name =~ s/\(.*?\)\s*$//g;
# Find the change logs.
my %has_log;
my %files;
foreach my $file (sort keys %function_lists) {
my $prefix = $file;
my $has_log = 0;
while ($prefix) {
$prefix =~ s-/[^/]+/?$-/- or $prefix = "";
$has_log = $has_log{$prefix};
if (!defined $has_log) {
$has_log = -f "${prefix}ChangeLog";
$has_log{$prefix} = $has_log;
}
last if $has_log;
}
if (!$has_log) {
print STDERR "No ChangeLog found for $file.\n";
} else {
push @{$files{$prefix}}, $file;
}
}
# Build the list of ChangeLog prefixes in the correct project order
my @prefixes;
my %prefixesSort;
foreach my $prefix (keys %files) {
my $prefixDir = substr($prefix, 0, length($prefix) - 1); # strip trailing /
my $sortKey = lc $prefix;
$sortKey = "top level" unless length $sortKey;
if ($prefixDir eq "top level") {
$sortKey = "";
} elsif ($prefixDir eq "Tools") {
$sortKey = "-, just after top level";
} elsif ($prefixDir eq "WebBrowser") {
$sortKey = lc "WebKit, WebBrowser after";
} elsif ($prefixDir eq "Source/WebCore") {
$sortKey = lc "WebFoundation, WebCore after";
} elsif ($prefixDir eq "LayoutTests") {
$sortKey = lc "~, LayoutTests last";
}
$prefixesSort{$sortKey} = $prefix;
}
foreach my $prefixSort (sort keys %prefixesSort) {
push @prefixes, $prefixesSort{$prefixSort};
}
# Get the latest ChangeLog files from svn.
my @logs = ();
foreach my $prefix (@prefixes) {
push @logs, File::Spec->catfile($prefix || ".", "ChangeLog");
}
if (@logs && $updateChangeLogs && $isSVN) {
print STDERR " Running 'svn update' to update ChangeLog files.\n";
open ERRORS, "-|", $SVN, "update", @logs
or die "The svn update of ChangeLog files failed: $!.\n";
my @conflictedChangeLogs;
while (my $line = <ERRORS>) {
print STDERR " ", $line;
push @conflictedChangeLogs, $1 if $line =~ m/^C\s+(.+?)[\r\n]*$/;
}
close ERRORS;
if (@conflictedChangeLogs) {
print STDERR " Attempting to merge conflicted ChangeLogs.\n";
my $resolveChangeLogsPath = File::Spec->catfile(dirname($0), "resolve-ChangeLogs");
open RESOLVE, "-|", $resolveChangeLogsPath, "--no-warnings", @conflictedChangeLogs
or die "Could not open resolve-ChangeLogs script: $!.\n";
print STDERR " $_" while <RESOLVE>;
close RESOLVE;
}
}
# Generate new ChangeLog entries and (optionally) write out new ChangeLog files.
foreach my $prefix (@prefixes) {
my $endl = "\n";
my @old_change_log;
if ($writeChangeLogs) {
my $changeLogPath = File::Spec->catfile($prefix || ".", "ChangeLog");
print STDERR " Editing the ${changeLogPath} file.\n";
open OLD_CHANGE_LOG, ${changeLogPath} or die "Could not open ${changeLogPath} file: $!.\n";
# It's less efficient to read the whole thing into memory than it would be
# to read it while we prepend to it later, but I like doing this part first.
@old_change_log = <OLD_CHANGE_LOG>;
close OLD_CHANGE_LOG;
# We want to match the ChangeLog's line endings in case it doesn't match
# the native line endings for this version of perl.
if ($old_change_log[0] =~ /(\r?\n)$/g) {
$endl = "$1";
}
open CHANGE_LOG, "> ${changeLogPath}" or die "Could not write ${changeLogPath}\n.";
} else {
open CHANGE_LOG, ">-" or die "Could not write to STDOUT\n.";
print substr($prefix, 0, length($prefix) - 1) . ":\n\n" unless (scalar @prefixes) == 1;
}
print CHANGE_LOG normalizeLineEndings("$date $name <$emailAddress>\n\n", $endl);
my ($reviewer, $description) = reviewerAndDescriptionForGitCommit($gitCommit) if $gitCommit;
$reviewer = "NOBODY (OO" . "PS!)" if !$reviewer;
print CHANGE_LOG normalizeLineEndings(" Reviewed by $reviewer.\n\n", $endl);
print CHANGE_LOG normalizeLineEndings($description . "\n", $endl) if $description;
$bugDescription = "Need a short description and bug URL (OOPS!)" unless $bugDescription;
print CHANGE_LOG normalizeLineEndings(" $bugDescription\n", $endl) if $bugDescription;
print CHANGE_LOG normalizeLineEndings(" $bugURL\n", $endl) if $bugURL;
print CHANGE_LOG normalizeLineEndings("\n", $endl);
if ($prefix =~ m/WebCore/ || `pwd` =~ m/WebCore/) {
if ($didChangeRegressionTests) {
print CHANGE_LOG normalizeLineEndings(testListForChangeLog(sort @addedRegressionTests), $endl);
} else {
print CHANGE_LOG normalizeLineEndings(" No new tests. (OOPS!)\n\n", $endl);
}
}
foreach my $file (sort @{$files{$prefix}}) {
my $file_stem = substr $file, length $prefix;
print CHANGE_LOG normalizeLineEndings(" * $file_stem:$function_lists{$file}\n", $endl);
}
if ($writeChangeLogs) {
print CHANGE_LOG normalizeLineEndings("\n", $endl), @old_change_log;
} else {
print CHANGE_LOG "\n";
}
close CHANGE_LOG;
}
if ($writeChangeLogs) {
print STDERR "-- Please remember to include a detailed description in your ChangeLog entry. --\n-- See <http://webkit.org/coding/contributing.html> for more info --\n";
}
# Write out another diff.
if ($spewDiff && @changed_files) {
print STDERR " Running diff to help you write the ChangeLog entries.\n";
local $/ = undef; # local slurp mode
open DIFF, "-|", createPatchCommand($changed_files_string) or die "The diff failed: $!.\n";
print <DIFF>;
close DIFF;
}
# Open ChangeLogs.
if ($openChangeLogs && @logs) {
print STDERR " Opening the edited ChangeLog files.\n";
my $editor = $ENV{CHANGE_LOG_EDITOR};
if ($editor) {
system ((split ' ', $editor), @logs);
} else {
$editor = $ENV{CHANGE_LOG_EDIT_APPLICATION};
if ($editor) {
system "open", "-a", $editor, @logs;
} else {
system "open", "-e", @logs;
}
}
}
# Done.
exit;
sub changeLogDate($)
{
my ($timeZone) = @_;
my $savedTimeZone = $ENV{'TZ'};
# Set TZ temporarily so that localtime() is in that time zone
$ENV{'TZ'} = $timeZone;
my $date = strftime("%Y-%m-%d", localtime());
if (defined $savedTimeZone) {
$ENV{'TZ'} = $savedTimeZone;
} else {
delete $ENV{'TZ'};
}
return $date;
}
sub changeLogNameFromArgs($)
{
my ($nameFromArgs) = @_;
# Silently allow --git-commit to win, we could warn if $nameFromArgs is defined.
return `$GIT log --max-count=1 --pretty=\"format:%an\" \"$gitCommit\"` if $gitCommit;
return $nameFromArgs || changeLogName();
}
sub changeLogEmailAddressFromArgs($)
{
my ($emailAddressFromArgs) = @_;
# Silently allow --git-commit to win, we could warn if $emailAddressFromArgs is defined.
return `$GIT log --max-count=1 --pretty=\"format:%ae\" \"$gitCommit\"` if $gitCommit;
return $emailAddressFromArgs || changeLogEmailAddress();
}
sub get_function_line_ranges($$)
{
my ($file_handle, $file_name) = @_;
if ($file_name =~ /\.(c|cpp|m|mm|h)$/) {
return get_function_line_ranges_for_c ($file_handle, $file_name);
} elsif ($file_name =~ /\.java$/) {
return get_function_line_ranges_for_java ($file_handle, $file_name);
} elsif ($file_name =~ /\.js$/) {
return get_function_line_ranges_for_javascript ($file_handle, $file_name);
} elsif ($file_name =~ /\.css$/) {
return get_selector_line_ranges_for_css ($file_handle, $file_name);
}
return ();
}
sub method_decl_to_selector($)
{
(my $method_decl) = @_;
$_ = $method_decl;
if ((my $comment_stripped) = m-([^/]*)(//|/*).*-) {
$_ = $comment_stripped;
}
s/,\s*...//;
if (/:/) {
my @components = split /:/;
pop @components if (scalar @components > 1);
$_ = (join ':', map {s/.*[^[:word:]]//; scalar $_;} @components) . ':';
} else {
s/\s*$//;
s/.*[^[:word:]]//;
}
return $_;
}
# Read a file and get all the line ranges of the things that look like C functions.
# A function name is the last word before an open parenthesis before the outer
# level open brace. A function starts at the first character after the last close
# brace or semicolon before the function name and ends at the close brace.
# Comment handling is simple-minded but will work for all but pathological cases.
#
# Result is a list of triples: [ start_line, end_line, function_name ].
sub get_function_line_ranges_for_c($$)
{
my ($file_handle, $file_name) = @_;
my @ranges;
my $in_comment = 0;
my $in_macro = 0;
my $in_method_declaration = 0;
my $in_parentheses = 0;
my $in_braces = 0;
my $brace_start = 0;
my $brace_end = 0;
my $skip_til_brace_or_semicolon = 0;
my $word = "";
my $interface_name = "";
my $potential_method_char = "";
my $potential_method_spec = "";
my $potential_start = 0;
my $potential_name = "";
my $start = 0;
my $name = "";
my $next_word_could_be_namespace = 0;
my $potential_namespace = "";
my @namespaces;
while (<$file_handle>) {
# Handle continued multi-line comment.
if ($in_comment) {
next unless s-.*\*/--;
$in_comment = 0;
}
# Handle continued macro.
if ($in_macro) {
$in_macro = 0 unless /\\$/;
next;
}
# Handle start of macro (or any preprocessor directive).
if (/^\s*\#/) {
$in_macro = 1 if /^([^\\]|\\.)*\\$/;
next;
}
# Handle comments and quoted text.
while (m-(/\*|//|\'|\")-) { # \' and \" keep emacs perl mode happy
my $match = $1;
if ($match eq "/*") {
if (!s-/\*.*?\*/--) {
s-/\*.*--;
$in_comment = 1;
}
} elsif ($match eq "//") {
s-//.*--;
} else { # ' or "
if (!s-$match([^\\]|\\.)*?$match--) {
warn "mismatched quotes at line $. in $file_name\n";
s-$match.*--;
}
}
}
# continued method declaration
if ($in_method_declaration) {
my $original = $_;
my $method_cont = $_;
chomp $method_cont;
$method_cont =~ s/[;\{].*//;
$potential_method_spec = "${potential_method_spec} ${method_cont}";
$_ = $original;
if (/;/) {
$potential_start = 0;
$potential_method_spec = "";
$potential_method_char = "";
$in_method_declaration = 0;
s/^[^;\{]*//;
} elsif (/{/) {
my $selector = method_decl_to_selector ($potential_method_spec);
$potential_name = "${potential_method_char}\[${interface_name} ${selector}\]";
$potential_method_spec = "";
$potential_method_char = "";
$in_method_declaration = 0;
$_ = $original;
s/^[^;{]*//;
} elsif (/\@end/) {
$in_method_declaration = 0;
$interface_name = "";
$_ = $original;
} else {
next;
}
}
# start of method declaration
if ((my $method_char, my $method_spec) = m&^([-+])([^0-9;][^;]*);?$&) {
my $original = $_;
if ($interface_name) {
chomp $method_spec;
$method_spec =~ s/\{.*//;
$potential_method_char = $method_char;
$potential_method_spec = $method_spec;
$potential_start = $.;
$in_method_declaration = 1;
} else {
warn "declaring a method but don't have interface on line $. in $file_name\n";
}
$_ = $original;
if (/\{/) {
my $selector = method_decl_to_selector ($potential_method_spec);
$potential_name = "${potential_method_char}\[${interface_name} ${selector}\]";
$potential_method_spec = "";
$potential_method_char = "";
$in_method_declaration = 0;
$_ = $original;
s/^[^{]*//;
} elsif (/\@end/) {
$in_method_declaration = 0;
$interface_name = "";
$_ = $original;
} else {
next;
}
}
# Find function, interface and method names.
while (m&((?:[[:word:]]+::)*operator(?:[ \t]*\(\)|[^()]*)|[[:word:]:~]+|[(){}:;])|\@(?:implementation|interface|protocol)\s+(\w+)[^{]*&g) {
# interface name
if ($2) {
$interface_name = $2;
next;
}
# Open parenthesis.
if ($1 eq "(") {
$potential_name = $word unless $in_parentheses || $skip_til_brace_or_semicolon;
$in_parentheses++;
next;
}
# Close parenthesis.
if ($1 eq ")") {
$in_parentheses--;
next;
}
# C++ constructor initializers
if ($1 eq ":") {
$skip_til_brace_or_semicolon = 1 unless ($in_parentheses || $in_braces);
}
# Open brace.
if ($1 eq "{") {
$skip_til_brace_or_semicolon = 0;
if ($potential_namespace) {
push @namespaces, $potential_namespace;
$potential_namespace = "";
next;
}
# Promote potential name to real function name at the
# start of the outer level set of braces (function body?).
if (!$in_braces and $potential_start) {
$start = $potential_start;
$name = $potential_name;
if (@namespaces && $name && (length($name) < 2 || substr($name,1,1) ne "[")) {
$name = join ('::', @namespaces, $name);
}
}
$in_method_declaration = 0;
$brace_start = $. if (!$in_braces);
$in_braces++;
next;
}
# Close brace.
if ($1 eq "}") {
if (!$in_braces && @namespaces) {
pop @namespaces;
next;
}
$in_braces--;
$brace_end = $. if (!$in_braces);
# End of an outer level set of braces.
# This could be a function body.
if (!$in_braces and $name) {
push @ranges, [ $start, $., $name ];
$name = "";
}
$potential_start = 0;
$potential_name = "";
next;
}
# Semicolon.
if ($1 eq ";") {
$skip_til_brace_or_semicolon = 0;
$potential_start = 0;
$potential_name = "";
$in_method_declaration = 0;
next;
}
# Ignore "const" method qualifier.
if ($1 eq "const") {
next;
}
if ($1 eq "namespace" || $1 eq "class" || $1 eq "struct") {
$next_word_could_be_namespace = 1;
next;
}
# Word.
$word = $1;
if (!$skip_til_brace_or_semicolon) {
if ($next_word_could_be_namespace) {
$potential_namespace = $word;
$next_word_could_be_namespace = 0;
} elsif ($potential_namespace) {
$potential_namespace = "";
}
if (!$in_parentheses) {
$potential_start = 0;
$potential_name = "";
}
if (!$potential_start) {
$potential_start = $.;
$potential_name = "";
}
}
}
}
warn "missing close braces in $file_name (probable start at $brace_start)\n" if ($in_braces > 0);
warn "too many close braces in $file_name (probable start at $brace_end)\n" if ($in_braces < 0);
warn "mismatched parentheses in $file_name\n" if $in_parentheses;
return @ranges;
}
# Read a file and get all the line ranges of the things that look like Java
# classes, interfaces and methods.
#
# A class or interface name is the word that immediately follows
# `class' or `interface' when followed by an open curly brace and not
# a semicolon. It can appear at the top level, or inside another class
# or interface block, but not inside a function block
#
# A class or interface starts at the first character after the first close
# brace or after the function name and ends at the close brace.
#
# A function name is the last word before an open parenthesis before
# an open brace rather than a semicolon. It can appear at top level or
# inside a class or interface block, but not inside a function block.
#
# A function starts at the first character after the first close
# brace or after the function name and ends at the close brace.
#
# Comment handling is simple-minded but will work for all but pathological cases.
#
# Result is a list of triples: [ start_line, end_line, function_name ].
sub get_function_line_ranges_for_java($$)
{
my ($file_handle, $file_name) = @_;
my @current_scopes;
my @ranges;
my $in_comment = 0;
my $in_macro = 0;
my $in_parentheses = 0;
my $in_braces = 0;
my $in_non_block_braces = 0;
my $class_or_interface_just_seen = 0;
my $word = "";
my $potential_start = 0;
my $potential_name = "";
my $potential_name_is_class_or_interface = 0;
my $start = 0;
my $name = "";
my $current_name_is_class_or_interface = 0;
while (<$file_handle>) {
# Handle continued multi-line comment.
if ($in_comment) {
next unless s-.*\*/--;
$in_comment = 0;
}
# Handle continued macro.
if ($in_macro) {
$in_macro = 0 unless /\\$/;
next;
}
# Handle start of macro (or any preprocessor directive).
if (/^\s*\#/) {
$in_macro = 1 if /^([^\\]|\\.)*\\$/;
next;
}
# Handle comments and quoted text.
while (m-(/\*|//|\'|\")-) { # \' and \" keep emacs perl mode happy
my $match = $1;
if ($match eq "/*") {
if (!s-/\*.*?\*/--) {
s-/\*.*--;
$in_comment = 1;
}
} elsif ($match eq "//") {
s-//.*--;
} else { # ' or "
if (!s-$match([^\\]|\\.)*?$match--) {
warn "mismatched quotes at line $. in $file_name\n";
s-$match.*--;
}
}
}
# Find function names.
while (m-(\w+|[(){};])-g) {
# Open parenthesis.
if ($1 eq "(") {
if (!$in_parentheses) {
$potential_name = $word;
$potential_name_is_class_or_interface = 0;
}
$in_parentheses++;
next;
}
# Close parenthesis.
if ($1 eq ")") {
$in_parentheses--;
next;
}
# Open brace.
if ($1 eq "{") {
# Promote potential name to real function name at the
# start of the outer level set of braces (function/class/interface body?).
if (!$in_non_block_braces
and (!$in_braces or $current_name_is_class_or_interface)
and $potential_start) {
if ($name) {
push @ranges, [ $start, ($. - 1),
join ('.', @current_scopes) ];
}
$current_name_is_class_or_interface = $potential_name_is_class_or_interface;
$start = $potential_start;
$name = $potential_name;
push (@current_scopes, $name);
} else {
$in_non_block_braces++;
}
$potential_name = "";
$potential_start = 0;
$in_braces++;
next;
}
# Close brace.
if ($1 eq "}") {
$in_braces--;
# End of an outer level set of braces.
# This could be a function body.
if (!$in_non_block_braces) {
if ($name) {
push @ranges, [ $start, $.,
join ('.', @current_scopes) ];
pop (@current_scopes);
if (@current_scopes) {
$current_name_is_class_or_interface = 1;
$start = $. + 1;
$name = $current_scopes[$#current_scopes-1];
} else {
$current_name_is_class_or_interface = 0;
$start = 0;
$name = "";
}
}
} else {
$in_non_block_braces-- if $in_non_block_braces;
}
$potential_start = 0;
$potential_name = "";
next;
}
# Semicolon.
if ($1 eq ";") {
$potential_start = 0;
$potential_name = "";
next;
}
if ($1 eq "class" or $1 eq "interface") {
$class_or_interface_just_seen = 1;
next;
}
# Word.
$word = $1;
if (!$in_parentheses) {
if ($class_or_interface_just_seen) {
$potential_name = $word;
$potential_start = $.;
$class_or_interface_just_seen = 0;
$potential_name_is_class_or_interface = 1;
next;
}
}
if (!$potential_start) {
$potential_start = $.;
$potential_name = "";
}
$class_or_interface_just_seen = 0;
}
}
warn "mismatched braces in $file_name\n" if $in_braces;
warn "mismatched parentheses in $file_name\n" if $in_parentheses;
return @ranges;
}
# Read a file and get all the line ranges of the things that look like
# JavaScript functions.
#
# A function name is the word that immediately follows `function' when
# followed by an open curly brace. It can appear at the top level, or
# inside other functions.
#
# An anonymous function name is the identifier chain immediately before
# an assignment with the equals operator or object notation that has a
# value starting with `function' followed by an open curly brace.
#
# A getter or setter name is the word that immediately follows `get' or
# `set' when followed by an open curly brace .
#
# Comment handling is simple-minded but will work for all but pathological cases.
#
# Result is a list of triples: [ start_line, end_line, function_name ].
sub get_function_line_ranges_for_javascript($$)
{
my ($fileHandle, $fileName) = @_;
my @currentScopes;
my @currentIdentifiers;
my @currentFunctionNames;
my @currentFunctionDepths;
my @currentFunctionStartLines;
my @ranges;
my $inComment = 0;
my $inQuotedText = "";
my $parenthesesDepth = 0;
my $bracesDepth = 0;
my $functionJustSeen = 0;
my $getterJustSeen = 0;
my $setterJustSeen = 0;
my $assignmentJustSeen = 0;
my $word = "";
while (<$fileHandle>) {
# Handle continued multi-line comment.
if ($inComment) {
next unless s-.*\*/--;
$inComment = 0;
}
# Handle continued quoted text.
if ($inQuotedText ne "") {
next if /\\$/;
s-([^\\]|\\.)*?$inQuotedText--;
$inQuotedText = "";
}
# Handle comments and quoted text.
while (m-(/\*|//|\'|\")-) { # \' and \" keep emacs perl mode happy
my $match = $1;
if ($match eq '/*') {
if (!s-/\*.*?\*/--) {
s-/\*.*--;
$inComment = 1;
}
} elsif ($match eq '//') {
s-//.*--;
} else { # ' or "
if (!s-$match([^\\]|\\.)*?$match--) {
$inQuotedText = $match if /\\$/;
warn "mismatched quotes at line $. in $fileName\n" if $inQuotedText eq "";
s-$match.*--;
}
}
}
# Find function names.
while (m-(\w+|[(){}=:;])-g) {
# Open parenthesis.
if ($1 eq '(') {
$parenthesesDepth++;
next;
}
# Close parenthesis.
if ($1 eq ')') {
$parenthesesDepth--;
next;
}
# Open brace.
if ($1 eq '{') {
push(@currentScopes, join(".", @currentIdentifiers));
@currentIdentifiers = ();
$bracesDepth++;
next;
}
# Close brace.
if ($1 eq '}') {
$bracesDepth--;
if (@currentFunctionDepths and $bracesDepth == $currentFunctionDepths[$#currentFunctionDepths]) {
pop(@currentFunctionDepths);
my $currentFunction = pop(@currentFunctionNames);
my $start = pop(@currentFunctionStartLines);
push(@ranges, [$start, $., $currentFunction]);
}
pop(@currentScopes);
@currentIdentifiers = ();
next;
}
# Semicolon.
if ($1 eq ';') {
@currentIdentifiers = ();
next;
}
# Function.
if ($1 eq 'function') {
$functionJustSeen = 1;
if ($assignmentJustSeen) {
my $currentFunction = join('.', (@currentScopes, @currentIdentifiers));
$currentFunction =~ s/\.{2,}/\./g; # Removes consecutive periods.
push(@currentFunctionNames, $currentFunction);
push(@currentFunctionDepths, $bracesDepth);
push(@currentFunctionStartLines, $.);
}
next;
}
# Getter prefix.
if ($1 eq 'get') {
$getterJustSeen = 1;
next;
}
# Setter prefix.
if ($1 eq 'set') {
$setterJustSeen = 1;
next;
}
# Assignment operator.
if ($1 eq '=' or $1 eq ':') {
$assignmentJustSeen = 1;
next;
}
next if $parenthesesDepth;
# Word.
$word = $1;
$word = "get $word" if $getterJustSeen;
$word = "set $word" if $setterJustSeen;
if (($functionJustSeen and !$assignmentJustSeen) or $getterJustSeen or $setterJustSeen) {
push(@currentIdentifiers, $word);
my $currentFunction = join('.', (@currentScopes, @currentIdentifiers));
$currentFunction =~ s/\.{2,}/\./g; # Removes consecutive periods.
push(@currentFunctionNames, $currentFunction);
push(@currentFunctionDepths, $bracesDepth);
push(@currentFunctionStartLines, $.);
} elsif ($word ne 'if' and $word ne 'for' and $word ne 'do' and $word ne 'while' and $word ne 'which' and $word ne 'var') {
push(@currentIdentifiers, $word);
}
$functionJustSeen = 0;
$getterJustSeen = 0;
$setterJustSeen = 0;
$assignmentJustSeen = 0;
}
}
warn "mismatched braces in $fileName\n" if $bracesDepth;
warn "mismatched parentheses in $fileName\n" if $parenthesesDepth;
return @ranges;
}
# Read a file and get all the line ranges of the things that look like CSS selectors. A selector is
# anything before an opening brace on a line. A selector starts at the line containing the opening
# brace and ends at the closing brace.
# FIXME: Comments are parsed just like uncommented text.
#
# Result is a list of triples: [ start_line, end_line, selector ].
sub get_selector_line_ranges_for_css($$)
{
my ($fileHandle, $fileName) = @_;
my @ranges;
my $currentSelector = "";
my $start = 0;
while (<$fileHandle>) {
if (/^[ \t]*(.*[^ \t])[ \t]*{/) {
$currentSelector = $1;
$start = $.;
}
if (index($_, "}") >= 0) {
unless ($start) {
warn "mismatched braces in $fileName\n";
next;
}
push(@ranges, [$start, $., $currentSelector]);
$currentSelector = "";
$start = 0;
next;
}
}
return @ranges;
}
sub processPaths(\@)
{
my ($paths) = @_;
return ("." => 1) if (!@{$paths});
my %result = ();
for my $file (@{$paths}) {
die "can't handle absolute paths like \"$file\"\n" if File::Spec->file_name_is_absolute($file);
die "can't handle empty string path\n" if $file eq "";
die "can't handle path with single quote in the name like \"$file\"\n" if $file =~ /'/; # ' (keep Xcode syntax highlighting happy)
my $untouchedFile = $file;
$file = canonicalizePath($file);
die "can't handle paths with .. like \"$untouchedFile\"\n" if $file =~ m|/\.\./|;
$result{$file} = 1;
}
return ("." => 1) if ($result{"."});
# Remove any paths that also have a parent listed.
for my $path (keys %result) {
for (my $parent = dirname($path); $parent ne '.'; $parent = dirname($parent)) {
if ($result{$parent}) {
delete $result{$path};
last;
}
}
}
return %result;
}
sub diffFromToString()
{
return "" if $isSVN;
return $gitCommit if $gitCommit =~ m/.+\.\..+/;
return "\"$gitCommit^\" \"$gitCommit\"" if $gitCommit;
return "--cached" if $gitIndex;
return $mergeBase if $mergeBase;
return "HEAD" if $isGit;
}
sub diffCommand(@)
{
my @paths = @_;
my $pathsString = "'" . join("' '", @paths) . "'";
my $command;
if ($isSVN) {
$command = "$SVN diff --diff-cmd diff -x -N $pathsString";
} elsif ($isGit) {
$command = "$GIT diff --no-ext-diff -U0 " . diffFromToString();
$command .= " -- $pathsString" unless $gitCommit or $mergeBase;
}
return $command;
}
sub statusCommand(@)
{
my @files = @_;
my $filesString = "'" . join ("' '", @files) . "'";
my $command;
if ($isSVN) {
$command = "$SVN stat $filesString";
} elsif ($isGit) {
$command = "$GIT diff -r --name-status -M -C " . diffFromToString();
$command .= " -- $filesString" unless $gitCommit;
}
return "$command 2>&1";
}
sub createPatchCommand($)
{
my ($changedFilesString) = @_;
my $command;
if ($isSVN) {
$command = "'$FindBin::Bin/svn-create-patch' $changedFilesString";
} elsif ($isGit) {
$command = "$GIT diff -M -C " . diffFromToString();
$command .= " -- $changedFilesString" unless $gitCommit;
}
return $command;
}
sub diffHeaderFormat()
{
return qr/^Index: (\S+)[\r\n]*$/ if $isSVN;
return qr/^diff --git a\/.+ b\/(.+)$/ if $isGit;
}
sub findOriginalFileFromSvn($)
{
my ($file) = @_;
my $baseUrl;
open INFO, "$SVN info . |" or die;
while (<INFO>) {
if (/^URL: (.+?)[\r\n]*$/) {
$baseUrl = $1;
}
}
close INFO;
my $sourceFile;
open INFO, "$SVN info '$file' |" or die;
while (<INFO>) {
if (/^Copied From URL: (.+?)[\r\n]*$/) {
$sourceFile = File::Spec->abs2rel($1, $baseUrl);
}
}
close INFO;
return $sourceFile;
}
sub determinePropertyChanges($$$)
{
my ($file, $isAdd, $original) = @_;
my %changes;
if ($isAdd) {
my %addedProperties;
my %removedProperties;
open PROPLIST, "$SVN proplist '$file' |" or die;
while (<PROPLIST>) {
$addedProperties{$1} = 1 if /^ (.+?)[\r\n]*$/ && $1 ne 'svn:mergeinfo';
}
close PROPLIST;
if ($original) {
open PROPLIST, "$SVN proplist '$original' |" or die;
while (<PROPLIST>) {
next unless /^ (.+?)[\r\n]*$/;
my $property = $1;
if (exists $addedProperties{$property}) {
delete $addedProperties{$1};
} else {
$removedProperties{$1} = 1;
}
}
}
$changes{"A"} = [sort keys %addedProperties] if %addedProperties;
$changes{"D"} = [sort keys %removedProperties] if %removedProperties;
} else {
open DIFF, "$SVN diff '$file' |" or die;
while (<DIFF>) {
if (/^Property changes on:/) {
while (<DIFF>) {
my $operation;
my $property;
if (/^Added: (\S*)/) {
$operation = "A";
$property = $1;
} elsif (/^Modified: (\S*)/) {
$operation = "M";
$property = $1;
} elsif (/^Deleted: (\S*)/) {
$operation = "D";
$property = $1;
} elsif (/^Name: (\S*)/) {
# Older versions of svn just say "Name" instead of the type
# of property change.
$operation = "C";
$property = $1;
}
if ($operation) {
$changes{$operation} = [] unless exists $changes{$operation};
push @{$changes{$operation}}, $property;
}
}
}
}
close DIFF;
}
return \%changes;
}
sub pluralizeAndList($$@)
{
my ($singular, $plural, @items) = @_;
return if @items == 0;
return "$singular $items[0]" if @items == 1;
return "$plural " . join(", ", @items[0 .. $#items - 1]) . " and " . $items[-1];
}
sub generateFileList(\@\@\%)
{
my ($changedFiles, $conflictFiles, $functionLists) = @_;
print STDERR " Running status to find changed, added, or removed files.\n";
open STAT, "-|", statusCommand(keys %paths) or die "The status failed: $!.\n";
while (<STAT>) {
my $status;
my $propertyStatus;
my $propertyChanges;
my $original;
my $file;
if ($isSVN) {
my $matches;
if (isSVNVersion16OrNewer()) {
$matches = /^([ ACDMR])([ CM]).{5} (.+?)[\r\n]*$/;
$status = $1;
$propertyStatus = $2;
$file = $3;
} else {
$matches = /^([ ACDMR])([ CM]).{4} (.+?)[\r\n]*$/;
$status = $1;
$propertyStatus = $2;
$file = $3;
}
if ($matches) {
$file = normalizePath($file);
$original = findOriginalFileFromSvn($file) if substr($_, 3, 1) eq "+";
my $isAdd = isAddedStatus($status);
$propertyChanges = determinePropertyChanges($file, $isAdd, $original) if isModifiedStatus($propertyStatus) || $isAdd;
} else {
print; # error output from svn stat
}
} elsif ($isGit) {
if (/^([ADM])\t(.+)$/) {
$status = $1;
$propertyStatus = " "; # git doesn't have properties
$file = normalizePath($2);
} elsif (/^([CR])[0-9]{1,3}\t([^\t]+)\t([^\t\n]+)$/) { # for example: R90% newfile oldfile
$status = $1;
$propertyStatus = " ";
$original = normalizePath($2);
$file = normalizePath($3);
} else {
print; # error output from git diff
}
}
next if !$status || isUnmodifiedStatus($status) && isUnmodifiedStatus($propertyStatus);
$file = makeFilePathRelative($file);
if (isModifiedStatus($status) || isAddedStatus($status) || isModifiedStatus($propertyStatus)) {
my @components = File::Spec->splitdir($file);
if ($components[0] eq "LayoutTests") {
$didChangeRegressionTests = 1;
push @addedRegressionTests, $file
if isAddedStatus($status)
&& $file =~ /\.([a-zA-Z]+)$/
&& $supportedTestExtensions{lc($1)}
&& !scalar(grep(/^resources$/i, @components))
&& !scalar(grep(/^script-tests$/i, @components));
}
push @{$changedFiles}, $file if $components[$#components] ne "ChangeLog";
} elsif (isConflictStatus($status) || isConflictStatus($propertyStatus)) {
push @{$conflictFiles}, $file;
}
if (basename($file) ne "ChangeLog") {
my $description = statusDescription($status, $propertyStatus, $original, $propertyChanges);
$functionLists->{$file} = $description if defined $description;
}
}
close STAT;
}
sub isUnmodifiedStatus($)
{
my ($status) = @_;
my %statusCodes = (
" " => 1,
);
return $statusCodes{$status};
}
sub isModifiedStatus($)
{
my ($status) = @_;
my %statusCodes = (
"M" => 1,
);
return $statusCodes{$status};
}
sub isAddedStatus($)
{
my ($status) = @_;
my %statusCodes = (
"A" => 1,
"C" => $isGit,
"R" => 1,
);
return $statusCodes{$status};
}
sub isConflictStatus($)
{
my ($status) = @_;
my %svn = (
"C" => 1,
);
my %git = (
"U" => 1,
);
return 0 if ($gitCommit || $gitIndex); # an existing commit or staged change cannot have conflicts
return $svn{$status} if $isSVN;
return $git{$status} if $isGit;
}
sub statusDescription($$$$)
{
my ($status, $propertyStatus, $original, $propertyChanges) = @_;
my $propertyDescription = defined $propertyChanges ? propertyChangeDescription($propertyChanges) : "";
my %svn = (
"A" => defined $original ? " Copied from \%s." : " Added.",
"D" => " Removed.",
"M" => "",
"R" => defined $original ? " Replaced with \%s." : " Replaced.",
" " => "",
);
my %git = %svn;
$git{"A"} = " Added.";
$git{"C"} = " Copied from \%s.";
$git{"R"} = " Renamed from \%s.";
my $description;
$description = sprintf($svn{$status}, $original) if $isSVN && exists $svn{$status};
$description = sprintf($git{$status}, $original) if $isGit && exists $git{$status};
return unless defined $description;
$description .= $propertyDescription unless isAddedStatus($status);
return $description;
}
sub propertyChangeDescription($)
{
my ($propertyChanges) = @_;
my %operations = (
"A" => "Added",
"M" => "Modified",
"D" => "Removed",
"C" => "Changed",
);
my $description = "";
while (my ($operation, $properties) = each %$propertyChanges) {
my $word = $operations{$operation};
my $list = pluralizeAndList("property", "properties", @$properties);
$description .= " $word $list.";
}
return $description;
}
sub extractLineRange($)
{
my ($string) = @_;
my ($start, $end) = (-1, -1);
if ($isSVN && $string =~ /^\d+(,\d+)?[acd](\d+)(,(\d+))?/) {
$start = $2;
$end = $4 || $2;
} elsif ($isGit && $string =~ /^@@ -\d+(,\d+)? \+(\d+)(,(\d+))? @@/) {
$start = $2;
$end = defined($4) ? $4 + $2 - 1 : $2;
}
return ($start, $end);
}
sub firstDirectoryOrCwd()
{
my $dir = ".";
my @dirs = keys(%paths);
$dir = -d $dirs[0] ? $dirs[0] : dirname($dirs[0]) if @dirs;
return $dir;
}
sub testListForChangeLog(@)
{
my (@tests) = @_;
return "" unless @tests;
my $leadString = " Test" . (@tests == 1 ? "" : "s") . ": ";
my $list = $leadString;
foreach my $i (0..$#tests) {
$list .= " " x length($leadString) if $i;
my $test = $tests[$i];
$test =~ s/^LayoutTests\///;
$list .= "$test\n";
}
$list .= "\n";
return $list;
}
sub reviewerAndDescriptionForGitCommit($)
{
my ($commit) = @_;
my $description = '';
my $reviewer;
my @args = qw(rev-list --pretty);
push @args, '-1' if $commit !~ m/.+\.\..+/;
my $gitLog;
{
local $/ = undef;
open(GIT, "-|", $GIT, @args, $commit) || die;
$gitLog = <GIT>;
close(GIT);
}
my @commitLogs = split(/^[Cc]ommit [a-f0-9]{40}/m, $gitLog);
shift @commitLogs; # Remove initial blank commit log
my $commitLogCount = 0;
foreach my $commitLog (@commitLogs) {
$description .= "\n" if $commitLogCount;
$commitLogCount++;
my $inHeader = 1;
my $commitLogIndent;
my @lines = split(/\n/, $commitLog);
shift @lines; # Remove initial blank line
foreach my $line (@lines) {
if ($inHeader) {
if (!$line) {
$inHeader = 0;
}
next;
} elsif ($line =~ /[Ss]igned-[Oo]ff-[Bb]y: (.+)/) {
if (!$reviewer) {
$reviewer = $1;
} else {
$reviewer .= ", " . $1;
}
} elsif ($line =~ /^\s*$/) {
$description = $description . "\n";
} else {
if (!defined($commitLogIndent)) {
# Let the first line with non-white space determine
# the global indent.
$line =~ /^(\s*)\S/;
$commitLogIndent = length($1);
}
# Strip at most the indent to preserve relative indents.
$line =~ s/^\s{0,$commitLogIndent}//;
$description = $description . (" " x 8) . $line . "\n";
}
}
}
if (!$reviewer) {
$reviewer = $gitReviewer;
}
return ($reviewer, $description);
}
sub normalizeLineEndings($$)
{
my ($string, $endl) = @_;
$string =~ s/\r?\n/$endl/g;
return $string;
}
sub decodeEntities($)
{
my ($text) = @_;
$text =~ s/\</</g;
$text =~ s/\>/>/g;
$text =~ s/\"/\"/g;
$text =~ s/\'/\'/g;
$text =~ s/\&/\&/g;
return $text;
}