1 #!/usr/bin/perl -w

     2 # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 2  -*-

     3 

     4 #

     5 #  Copyright (C) 2000, 2001 Eazel, Inc.

     6 #  Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Apple Inc.  All rights reserved.

     7 #  Copyright (C) 2009 Torch Mobile, Inc.

     8 #  Copyright (C) 2009 Cameron McCormack <cam@mcc.id.au>

     9 #

    10 #  prepare-ChangeLog is free software; you can redistribute it and/or

    11 #  modify it under the terms of the GNU General Public

    12 #  License as published by the Free Software Foundation; either

    13 #  version 2 of the License, or (at your option) any later version.

    14 #

    15 #  prepare-ChangeLog is distributed in the hope that it will be useful,

    16 #  but WITHOUT ANY WARRANTY; without even the implied warranty of

    17 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

    18 #  General Public License for more details.

    19 #

    20 #  You should have received a copy of the GNU General Public

    21 #  License along with this program; if not, write to the Free

    22 #  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

    23 #

    24 

    25 

    26 # Perl script to create a ChangeLog entry with names of files

    27 # and functions from a diff.

    28 #

    29 # Darin Adler <darin@bentspoon.com>, started 20 April 2000

    30 # Java support added by Maciej Stachowiak <mjs@eazel.com>

    31 # Objective-C, C++ and Objective-C++ support added by Maciej Stachowiak <mjs@apple.com>

    32 # Git support added by Adam Roben <aroben@apple.com>

    33 # --git-index flag added by Joe Mason <joe.mason@torchmobile.com>

    34 

    35 

    36 #

    37 # TODO:

    38 #   List functions that have been removed too.

    39 #   Decide what a good logical order is for the changed files

    40 #     other than a normal text "sort" (top level first?)

    41 #     (group directories?) (.h before .c?)

    42 #   Handle yacc source files too (other languages?).

    43 #   Help merge when there are ChangeLog conflicts or if there's

    44 #     already a partly written ChangeLog entry.

    45 #   Add command line option to put the ChangeLog into a separate file.

    46 #   Add SVN version numbers for commit (can't do that until

    47 #     the changes are checked in, though).

    48 #   Work around diff stupidity where deleting a function that starts

    49 #     with a comment makes diff think that the following function

    50 #     has been changed (if the following function starts with a comment

    51 #     with the same first line, such as /**)

    52 #   Work around diff stupidity where deleting an entire function and

    53 #     the blank lines before it makes diff think you've changed the

    54 #     previous function.

    55 

    56 use strict;

    57 use warnings;

    58 

    59 use File::Basename;

    60 use File::Spec;

    61 use FindBin;

    62 use Getopt::Long;

    63 use lib $FindBin::Bin;

    64 use POSIX qw(strftime);

    65 use VCSUtils;

    66 

    67 sub changeLogDate($);

    68 sub changeLogEmailAddressFromArgs($);

    69 sub changeLogNameFromArgs($);

    70 sub firstDirectoryOrCwd();

    71 sub diffFromToString();

    72 sub diffCommand(@);

    73 sub statusCommand(@);

    74 sub createPatchCommand($);

    75 sub diffHeaderFormat();

    76 sub findOriginalFileFromSvn($);

    77 sub determinePropertyChanges($$$);

    78 sub pluralizeAndList($$@);

    79 sub generateFileList(\@\@\%);

    80 sub isUnmodifiedStatus($);

    81 sub isModifiedStatus($);

    82 sub isAddedStatus($);

    83 sub isConflictStatus($);

    84 sub statusDescription($$$$);

    85 sub propertyChangeDescription($);

    86 sub extractLineRange($);

    87 sub testListForChangeLog(@);

    88 sub get_function_line_ranges($$);

    89 sub get_function_line_ranges_for_c($$);

    90 sub get_function_line_ranges_for_java($$);

    91 sub get_function_line_ranges_for_javascript($$);

    92 sub get_selector_line_ranges_for_css($$);

    93 sub method_decl_to_selector($);

    94 sub processPaths(\@);

    95 sub reviewerAndDescriptionForGitCommit($);

    96 sub normalizeLineEndings($$);

    97 sub decodeEntities($);

    98 

    99 # Project time zone for Cupertino, CA, US

   100 my $changeLogTimeZone = "PST8PDT";

   101 

   102 my $bugNumber;

   103 my $name;

   104 my $emailAddress;

   105 my $mergeBase = 0;

   106 my $gitCommit = 0;

   107 my $gitIndex = "";

   108 my $gitReviewer = "";

   109 my $openChangeLogs = 0;

   110 my $writeChangeLogs = 1;

   111 my $showHelp = 0;

   112 my $spewDiff = $ENV{"PREPARE_CHANGELOG_DIFF"};

   113 my $updateChangeLogs = 1;

   114 my $parseOptionsResult =

   115     GetOptions("diff|d!" => \$spewDiff,

   116                "bug:i" => \$bugNumber,

   117                "name:s" => \$name,

   118                "email:s" => \$emailAddress,

   119                "merge-base:s" => \$mergeBase,

   120                "git-commit:s" => \$gitCommit,

   121                "git-index" => \$gitIndex,

   122                "git-reviewer:s" => \$gitReviewer,

   123                "help|h!" => \$showHelp,

   124                "open|o!" => \$openChangeLogs,

   125                "write!" => \$writeChangeLogs,

   126                "update!" => \$updateChangeLogs);

   127 if (!$parseOptionsResult || $showHelp) {

   128     print STDERR basename($0) . " [--bug] [-d|--diff] [-h|--help] [-o|--open] [--git-commit=<committish>] [--git-reviewer=<name>] [svndir1 [svndir2 ...]]\n";

   129     print STDERR "  --bug          Fill in the ChangeLog bug information from the given bug.\n";

   130     print STDERR "  -d|--diff      Spew diff to stdout when running\n";

   131     print STDERR "  --merge-base   Populate the ChangeLogs with the diff to this branch\n";

   132     print STDERR "  --git-commit   Populate the ChangeLogs from the specified git commit\n";

   133     print STDERR "  --git-index    Populate the ChangeLogs from the git index only\n";

   134     print STDERR "  --git-reviewer When populating the ChangeLogs from a git commit claim that the spcified name reviewed the change.\n";

   135     print STDERR "                 This option is useful when the git commit lacks a Signed-Off-By: line\n";

   136     print STDERR "  -h|--help      Show this help message\n";

   137     print STDERR "  -o|--open      Open ChangeLogs in an editor when done\n";

   138     print STDERR "  --[no-]update  Update ChangeLogs from svn before adding entry (default: update)\n";

   139     print STDERR "  --[no-]write   Write ChangeLogs to disk (otherwise send new entries to stdout) (default: write)\n";

   140     exit 1;

   141 }

   142 

   143 die "--git-commit and --git-index are incompatible." if ($gitIndex && $gitCommit);

   144 

   145 my %paths = processPaths(@ARGV);

   146 

   147 my $isGit = isGitDirectory(firstDirectoryOrCwd());

   148 my $isSVN = isSVNDirectory(firstDirectoryOrCwd());

   149 

   150 $isSVN || $isGit || die "Couldn't determine your version control system.";

   151 

   152 my $SVN = "svn";

   153 my $GIT = "git";

   154 

   155 # Find the list of modified files

   156 my @changed_files;

   157 my $changed_files_string;

   158 my %changed_line_ranges;

   159 my %function_lists;

   160 my @conflict_files;

   161 

   162 

   163 my %supportedTestExtensions = map { $_ => 1 } qw(html shtml svg xml xhtml pl php);

   164 my @addedRegressionTests = ();

   165 my $didChangeRegressionTests = 0;

   166 

   167 generateFileList(@changed_files, @conflict_files, %function_lists);

   168 

   169 if (!@changed_files && !@conflict_files && !keys %function_lists) {

   170     print STDERR "  No changes found.\n";

   171     exit 1;

   172 }

   173 

   174 if (@conflict_files) {

   175     print STDERR "  The following files have conflicts. Run prepare-ChangeLog again after fixing the conflicts:\n";

   176     print STDERR join("\n", @conflict_files), "\n";

   177     exit 1;

   178 }

   179 

   180 if (@changed_files) {

   181     $changed_files_string = "'" . join ("' '", @changed_files) . "'";

   182 

   183     # For each file, build a list of modified lines.

   184     # Use line numbers from the "after" side of each diff.

   185     print STDERR "  Reviewing diff to determine which lines changed.\n";

   186     my $file;

   187     open DIFF, "-|", diffCommand(@changed_files) or die "The diff failed: $!.\n";

   188     while (<DIFF>) {

   189         $file = makeFilePathRelative($1) if $_ =~ diffHeaderFormat();

   190         if (defined $file) {

   191             my ($start, $end) = extractLineRange($_);

   192             if ($start >= 0 && $end >= 0) {

   193                 push @{$changed_line_ranges{$file}}, [ $start, $end ];

   194             } elsif (/DO_NOT_COMMIT/) {

   195                 print STDERR "WARNING: file $file contains the string DO_NOT_COMMIT, line $.\n";

   196             }

   197         }

   198     }

   199     close DIFF;

   200 }

   201 

   202 # For each source file, convert line range to function list.

   203 if (%changed_line_ranges) {

   204     print STDERR "  Extracting affected function names from source files.\n";

   205     foreach my $file (keys %changed_line_ranges) {

   206         # Only look for function names in certain source files.

   207         next unless $file =~ /\.(c|cpp|m|mm|h|java|js)/;

   208     

   209         # Find all the functions in the file.

   210         open SOURCE, $file or next;

   211         my @function_ranges = get_function_line_ranges(\*SOURCE, $file);

   212         close SOURCE;

   213     

   214         # Find all the modified functions.

   215         my @functions;

   216         my %saw_function;

   217         my @change_ranges = (@{$changed_line_ranges{$file}}, []);

   218         my @change_range = (0, 0);

   219         FUNCTION: foreach my $function_range_ref (@function_ranges) {

   220             my @function_range = @$function_range_ref;

   221     

   222             # Advance to successive change ranges.

   223             for (;; @change_range = @{shift @change_ranges}) {

   224                 last FUNCTION unless @change_range;

   225     

   226                 # If past this function, move on to the next one.

   227                 next FUNCTION if $change_range[0] > $function_range[1];

   228     

   229                 # If an overlap with this function range, record the function name.

   230                 if ($change_range[1] >= $function_range[0]

   231                     and $change_range[0] <= $function_range[1]) {

   232                     if (!$saw_function{$function_range[2]}) {

   233                         $saw_function{$function_range[2]} = 1;

   234                         push @functions, $function_range[2];

   235                     }

   236                     next FUNCTION;

   237                 }

   238             }

   239         }

   240     

   241         # Format the list of functions now.

   242 

   243         if (@functions) {

   244             $function_lists{$file} = "" if !defined $function_lists{$file};

   245             $function_lists{$file} .= "\n        (" . join("):\n        (", @functions) . "):";

   246         }

   247     }

   248 }

   249 

   250 # Get some parameters for the ChangeLog we are about to write.

   251 my $date = changeLogDate($changeLogTimeZone);

   252 $name = changeLogNameFromArgs($name);

   253 $emailAddress = changeLogEmailAddressFromArgs($emailAddress);

   254 

   255 print STDERR "  Change author: $name <$emailAddress>.\n";

   256 

   257 my $bugDescription;

   258 my $bugURL;

   259 if ($bugNumber) {

   260     $bugURL = "https://bugs.webkit.org/show_bug.cgi?id=$bugNumber";

   261     my $bugXMLURL = "$bugURL&ctype=xml";

   262     # Perl has no built in XML processing, so we'll fetch and parse with curl and grep

   263     # Pass --insecure because some cygwin installs have no certs we don't

   264     # care about validating that bugs.webkit.org is who it says it is here.

   265     my $descriptionLine = `curl --insecure --silent "$bugXMLURL" | grep short_desc`;

   266     if ($descriptionLine !~ /<short_desc>(.*)<\/short_desc>/) {

   267         print STDERR "  Bug $bugNumber has no bug description. Maybe you set wrong bug ID?\n";

   268         print STDERR "  The bug URL: $bugXMLURL\n";

   269         exit 1;

   270     }

   271     $bugDescription = decodeEntities($1);

   272     print STDERR "  Description from bug $bugNumber:\n    \"$bugDescription\".\n";

   273 }

   274 

   275 # Remove trailing parenthesized notes from user name (bit of hack).

   276 $name =~ s/\(.*?\)\s*$//g;

   277 

   278 # Find the change logs.

   279 my %has_log;

   280 my %files;

   281 foreach my $file (sort keys %function_lists) {

   282     my $prefix = $file;

   283     my $has_log = 0;

   284     while ($prefix) {

   285         $prefix =~ s-/[^/]+/?$-/- or $prefix = "";

   286         $has_log = $has_log{$prefix};

   287         if (!defined $has_log) {

   288             $has_log = -f "${prefix}ChangeLog";

   289             $has_log{$prefix} = $has_log;

   290         }

   291         last if $has_log;

   292     }

   293     if (!$has_log) {

   294         print STDERR "No ChangeLog found for $file.\n";

   295     } else {

   296         push @{$files{$prefix}}, $file;

   297     }

   298 }

   299 

   300 # Build the list of ChangeLog prefixes in the correct project order

   301 my @prefixes;

   302 my %prefixesSort;

   303 foreach my $prefix (keys %files) {

   304     my $prefixDir = substr($prefix, 0, length($prefix) - 1); # strip trailing /

   305     my $sortKey = lc $prefix;

   306     $sortKey = "top level" unless length $sortKey;

   307 

   308     if ($prefixDir eq "top level") {

   309         $sortKey = "";

   310     } elsif ($prefixDir eq "Tools") {

   311         $sortKey = "-, just after top level";

   312     } elsif ($prefixDir eq "WebBrowser") {

   313         $sortKey = lc "WebKit, WebBrowser after";

   314     } elsif ($prefixDir eq "WebCore") {

   315         $sortKey = lc "WebFoundation, WebCore after";

   316     } elsif ($prefixDir eq "LayoutTests") {

   317         $sortKey = lc "~, LayoutTests last";

   318     }

   319 

   320     $prefixesSort{$sortKey} = $prefix;

   321 }

   322 foreach my $prefixSort (sort keys %prefixesSort) {

   323     push @prefixes, $prefixesSort{$prefixSort};

   324 }

   325 

   326 # Get the latest ChangeLog files from svn.

   327 my @logs = ();

   328 foreach my $prefix (@prefixes) {

   329     push @logs, File::Spec->catfile($prefix || ".", "ChangeLog");

   330 }

   331 

   332 if (@logs && $updateChangeLogs && $isSVN) {

   333     print STDERR "  Running 'svn update' to update ChangeLog files.\n";

   334     open ERRORS, "-|", $SVN, "update", @logs

   335         or die "The svn update of ChangeLog files failed: $!.\n";

   336     my @conflictedChangeLogs;

   337     while (my $line = <ERRORS>) {

   338         print STDERR "    ", $line;

   339         push @conflictedChangeLogs, $1 if $line =~ m/^C\s+(.+?)[\r\n]*$/;

   340     }

   341     close ERRORS;

   342 

   343     if (@conflictedChangeLogs) {

   344         print STDERR "  Attempting to merge conflicted ChangeLogs.\n";

   345         my $resolveChangeLogsPath = File::Spec->catfile(dirname($0), "resolve-ChangeLogs");

   346         open RESOLVE, "-|", $resolveChangeLogsPath, "--no-warnings", @conflictedChangeLogs

   347             or die "Could not open resolve-ChangeLogs script: $!.\n";

   348         print STDERR "    $_" while <RESOLVE>;

   349         close RESOLVE;

   350     }

   351 }

   352 

   353 # Generate new ChangeLog entries and (optionally) write out new ChangeLog files.

   354 foreach my $prefix (@prefixes) {

   355     my $endl = "\n";

   356     my @old_change_log;

   357 

   358     if ($writeChangeLogs) {

   359         my $changeLogPath = File::Spec->catfile($prefix || ".", "ChangeLog");

   360         print STDERR "  Editing the ${changeLogPath} file.\n";

   361         open OLD_CHANGE_LOG, ${changeLogPath} or die "Could not open ${changeLogPath} file: $!.\n";

   362         # It's less efficient to read the whole thing into memory than it would be

   363         # to read it while we prepend to it later, but I like doing this part first.

   364         @old_change_log = <OLD_CHANGE_LOG>;

   365         close OLD_CHANGE_LOG;

   366         # We want to match the ChangeLog's line endings in case it doesn't match

   367         # the native line endings for this version of perl.

   368         if ($old_change_log[0] =~ /(\r?\n)$/g) {

   369             $endl = "$1";

   370         }

   371         open CHANGE_LOG, "> ${changeLogPath}" or die "Could not write ${changeLogPath}\n.";

   372     } else {

   373         open CHANGE_LOG, ">-" or die "Could not write to STDOUT\n.";

   374         print substr($prefix, 0, length($prefix) - 1) . ":\n\n" unless (scalar @prefixes) == 1;

   375     }

   376 

   377     print CHANGE_LOG normalizeLineEndings("$date  $name  <$emailAddress>\n\n", $endl);

   378 

   379     my ($reviewer, $description) = reviewerAndDescriptionForGitCommit($gitCommit) if $gitCommit;

   380     $reviewer = "NOBODY (OO" . "PS!)" if !$reviewer;

   381 

   382     print CHANGE_LOG normalizeLineEndings("        Reviewed by $reviewer.\n\n", $endl);

   383     print CHANGE_LOG normalizeLineEndings($description . "\n", $endl) if $description;

   384 

   385     $bugDescription = "Need a short description and bug URL (OOPS!)" unless $bugDescription;

   386     print CHANGE_LOG normalizeLineEndings("        $bugDescription\n", $endl) if $bugDescription;

   387     print CHANGE_LOG normalizeLineEndings("        $bugURL\n", $endl) if $bugURL;

   388     print CHANGE_LOG normalizeLineEndings("\n", $endl);

   389 

   390     if ($prefix =~ m/WebCore/ || `pwd` =~ m/WebCore/) {

   391         if ($didChangeRegressionTests) {

   392             print CHANGE_LOG normalizeLineEndings(testListForChangeLog(sort @addedRegressionTests), $endl);

   393         } else {

   394             print CHANGE_LOG normalizeLineEndings("        No new tests. (OOPS!)\n\n", $endl);

   395         }

   396     }

   397 

   398     foreach my $file (sort @{$files{$prefix}}) {

   399         my $file_stem = substr $file, length $prefix;

   400         print CHANGE_LOG normalizeLineEndings("        * $file_stem:$function_lists{$file}\n", $endl);

   401     }

   402 

   403     if ($writeChangeLogs) {

   404         print CHANGE_LOG normalizeLineEndings("\n", $endl), @old_change_log;

   405     } else {

   406         print CHANGE_LOG "\n";

   407     }

   408 

   409     close CHANGE_LOG;

   410 }

   411 

   412 if ($writeChangeLogs) {

   413     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";

   414 }

   415 

   416 # Write out another diff.

   417 if ($spewDiff && @changed_files) {

   418     print STDERR "  Running diff to help you write the ChangeLog entries.\n";

   419     local $/ = undef; # local slurp mode

   420     open DIFF, "-|", createPatchCommand($changed_files_string) or die "The diff failed: $!.\n";

   421     print <DIFF>;

   422     close DIFF;

   423 }

   424 

   425 # Open ChangeLogs.

   426 if ($openChangeLogs && @logs) {

   427     print STDERR "  Opening the edited ChangeLog files.\n";

   428     my $editor = $ENV{"CHANGE_LOG_EDIT_APPLICATION"};

   429     if ($editor) {

   430         system "open", "-a", $editor, @logs;

   431     } else {

   432         system "open", "-e", @logs;

   433     }

   434 }

   435 

   436 # Done.

   437 exit;

   438 

   439 

   440 sub changeLogDate($)

   441 {

   442     my ($timeZone) = @_;

   443     my $savedTimeZone = $ENV{'TZ'};

   444     # Set TZ temporarily so that localtime() is in that time zone

   445     $ENV{'TZ'} = $timeZone;

   446     my $date = strftime("%Y-%m-%d", localtime());

   447     if (defined $savedTimeZone) {

   448          $ENV{'TZ'} = $savedTimeZone;

   449     } else {

   450          delete $ENV{'TZ'};

   451     }

   452     return $date;

   453 }

   454 

   455 sub changeLogNameFromArgs($)

   456 {

   457     my ($nameFromArgs) = @_;

   458     # Silently allow --git-commit to win, we could warn if $nameFromArgs is defined.

   459     return `$GIT log --max-count=1 --pretty=\"format:%an\" \"$gitCommit\"` if $gitCommit;

   460 

   461     return $nameFromArgs || changeLogName();

   462 }

   463 

   464 sub changeLogEmailAddressFromArgs($)

   465 {

   466     my ($emailAddressFromArgs) = @_;

   467     # Silently allow --git-commit to win, we could warn if $emailAddressFromArgs is defined.

   468     return `$GIT log --max-count=1 --pretty=\"format:%ae\" \"$gitCommit\"` if $gitCommit;

   469 

   470     return $emailAddressFromArgs || changeLogEmailAddress();

   471 }

   472 

   473 sub get_function_line_ranges($$)

   474 {

   475     my ($file_handle, $file_name) = @_;

   476 

   477     if ($file_name =~ /\.(c|cpp|m|mm|h)$/) {

   478         return get_function_line_ranges_for_c ($file_handle, $file_name);

   479     } elsif ($file_name =~ /\.java$/) {

   480         return get_function_line_ranges_for_java ($file_handle, $file_name);

   481     } elsif ($file_name =~ /\.js$/) {

   482         return get_function_line_ranges_for_javascript ($file_handle, $file_name);

   483     } elsif ($file_name =~ /\.css$/) {

   484         return get_selector_line_ranges_for_css ($file_handle, $file_name);

   485     }

   486     return ();

   487 }

   488 

   489 

   490 sub method_decl_to_selector($)

   491 {

   492     (my $method_decl) = @_;

   493 

   494     $_ = $method_decl;

   495 

   496     if ((my $comment_stripped) = m-([^/]*)(//|/*).*-) {

   497         $_ = $comment_stripped;

   498     }

   499 

   500     s/,\s*...//;

   501 

   502     if (/:/) {

   503         my @components = split /:/;

   504         pop @components if (scalar @components > 1);

   505         $_ = (join ':', map {s/.*[^[:word:]]//; scalar $_;} @components) . ':';

   506     } else {

   507         s/\s*$//;

   508         s/.*[^[:word:]]//;

   509     }

   510 

   511     return $_;

   512 }

   513 

   514 

   515 

   516 # Read a file and get all the line ranges of the things that look like C functions.

   517 # A function name is the last word before an open parenthesis before the outer

   518 # level open brace. A function starts at the first character after the last close

   519 # brace or semicolon before the function name and ends at the close brace.

   520 # Comment handling is simple-minded but will work for all but pathological cases.

   521 #

   522 # Result is a list of triples: [ start_line, end_line, function_name ].

   523 

   524 sub get_function_line_ranges_for_c($$)

   525 {

   526     my ($file_handle, $file_name) = @_;

   527 

   528     my @ranges;

   529 

   530     my $in_comment = 0;

   531     my $in_macro = 0;

   532     my $in_method_declaration = 0;

   533     my $in_parentheses = 0;

   534     my $in_braces = 0;

   535     my $brace_start = 0;

   536     my $brace_end = 0;

   537     my $skip_til_brace_or_semicolon = 0;

   538 

   539     my $word = "";

   540     my $interface_name = "";

   541 

   542     my $potential_method_char = "";

   543     my $potential_method_spec = "";

   544 

   545     my $potential_start = 0;

   546     my $potential_name = "";

   547 

   548     my $start = 0;

   549     my $name = "";

   550 

   551     my $next_word_could_be_namespace = 0;

   552     my $potential_namespace = "";

   553     my @namespaces;

   554 

   555     while (<$file_handle>) {

   556         # Handle continued multi-line comment.

   557         if ($in_comment) {

   558             next unless s-.*\*/--;

   559             $in_comment = 0;

   560         }

   561 

   562         # Handle continued macro.

   563         if ($in_macro) {

   564             $in_macro = 0 unless /\\$/;

   565             next;

   566         }

   567 

   568         # Handle start of macro (or any preprocessor directive).

   569         if (/^\s*\#/) {

   570             $in_macro = 1 if /^([^\\]|\\.)*\\$/;

   571             next;

   572         }

   573 

   574         # Handle comments and quoted text.

   575         while (m-(/\*|//|\'|\")-) { # \' and \" keep emacs perl mode happy

   576             my $match = $1;

   577             if ($match eq "/*") {

   578                 if (!s-/\*.*?\*/--) {

   579                     s-/\*.*--;

   580                     $in_comment = 1;

   581                 }

   582             } elsif ($match eq "//") {

   583                 s-//.*--;

   584             } else { # ' or "

   585                 if (!s-$match([^\\]|\\.)*?$match--) {

   586                     warn "mismatched quotes at line $. in $file_name\n";

   587                     s-$match.*--;

   588                 }

   589             }

   590         }

   591 

   592 

   593         # continued method declaration

   594         if ($in_method_declaration) {

   595               my $original = $_;

   596               my $method_cont = $_;

   597 

   598               chomp $method_cont;

   599               $method_cont =~ s/[;\{].*//;

   600               $potential_method_spec = "${potential_method_spec} ${method_cont}";

   601 

   602               $_ = $original;

   603               if (/;/) {

   604                   $potential_start = 0;

   605                   $potential_method_spec = "";

   606                   $potential_method_char = "";

   607                   $in_method_declaration = 0;

   608                   s/^[^;\{]*//;

   609               } elsif (/{/) {

   610                   my $selector = method_decl_to_selector ($potential_method_spec);

   611                   $potential_name = "${potential_method_char}\[${interface_name} ${selector}\]";

   612                   

   613                   $potential_method_spec = "";

   614                   $potential_method_char = "";

   615                   $in_method_declaration = 0;

   616   

   617                   $_ = $original;

   618                   s/^[^;{]*//;

   619               } elsif (/\@end/) {

   620                   $in_method_declaration = 0;

   621                   $interface_name = "";

   622                   $_ = $original;

   623               } else {

   624                   next;

   625               }

   626         }

   627 

   628         

   629         # start of method declaration

   630         if ((my $method_char, my $method_spec) = m&^([-+])([^0-9;][^;]*);?$&) {

   631             my $original = $_;

   632 

   633             if ($interface_name) {

   634                 chomp $method_spec;

   635                 $method_spec =~ s/\{.*//;

   636 

   637                 $potential_method_char = $method_char;

   638                 $potential_method_spec = $method_spec;

   639                 $potential_start = $.;

   640                 $in_method_declaration = 1;

   641             } else { 

   642                 warn "declaring a method but don't have interface on line $. in $file_name\n";

   643             }

   644             $_ = $original;

   645             if (/\{/) {

   646               my $selector = method_decl_to_selector ($potential_method_spec);

   647               $potential_name = "${potential_method_char}\[${interface_name} ${selector}\]";

   648               

   649               $potential_method_spec = "";

   650               $potential_method_char = "";

   651               $in_method_declaration = 0;

   652               $_ = $original;

   653               s/^[^{]*//;

   654             } elsif (/\@end/) {

   655               $in_method_declaration = 0;

   656               $interface_name = "";

   657               $_ = $original;

   658             } else {

   659               next;

   660             }

   661         }

   662 

   663 

   664         # Find function, interface and method names.

   665         while (m&((?:[[:word:]]+::)*operator(?:[ \t]*\(\)|[^()]*)|[[:word:]:~]+|[(){}:;])|\@(?:implementation|interface|protocol)\s+(\w+)[^{]*&g) {

   666             # interface name

   667             if ($2) {

   668                 $interface_name = $2;

   669                 next;

   670             }

   671 

   672             # Open parenthesis.

   673             if ($1 eq "(") {

   674                 $potential_name = $word unless $in_parentheses || $skip_til_brace_or_semicolon;

   675                 $in_parentheses++;

   676                 next;

   677             }

   678 

   679             # Close parenthesis.

   680             if ($1 eq ")") {

   681                 $in_parentheses--;

   682                 next;

   683             }

   684 

   685             # C++ constructor initializers

   686             if ($1 eq ":") {

   687                   $skip_til_brace_or_semicolon = 1 unless ($in_parentheses || $in_braces);

   688             }

   689 

   690             # Open brace.

   691             if ($1 eq "{") {

   692                 $skip_til_brace_or_semicolon = 0;

   693 

   694                 if ($potential_namespace) {

   695                     push @namespaces, $potential_namespace;

   696                     $potential_namespace = "";

   697                     next;

   698                 }

   699 

   700                 # Promote potential name to real function name at the

   701                 # start of the outer level set of braces (function body?).

   702                 if (!$in_braces and $potential_start) {

   703                     $start = $potential_start;

   704                     $name = $potential_name;

   705                     if (@namespaces && (length($name) < 2 || substr($name,1,1) ne "[")) {

   706                         $name = join ('::', @namespaces, $name);

   707                     }

   708                 }

   709 

   710                 $in_method_declaration = 0;

   711 

   712                 $brace_start = $. if (!$in_braces);

   713                 $in_braces++;

   714                 next;

   715             }

   716 

   717             # Close brace.

   718             if ($1 eq "}") {

   719                 if (!$in_braces && @namespaces) {

   720                     pop @namespaces;

   721                     next;

   722                 }

   723 

   724                 $in_braces--;

   725                 $brace_end = $. if (!$in_braces);

   726 

   727                 # End of an outer level set of braces.

   728                 # This could be a function body.

   729                 if (!$in_braces and $name) {

   730                     push @ranges, [ $start, $., $name ];

   731                     $name = "";

   732                 }

   733 

   734                 $potential_start = 0;

   735                 $potential_name = "";

   736                 next;

   737             }

   738 

   739             # Semicolon.

   740             if ($1 eq ";") {

   741                 $skip_til_brace_or_semicolon = 0;

   742                 $potential_start = 0;

   743                 $potential_name = "";

   744                 $in_method_declaration = 0;

   745                 next;

   746             }

   747 

   748             # Ignore "const" method qualifier.

   749             if ($1 eq "const") {

   750                 next;

   751             }

   752 

   753             if ($1 eq "namespace" || $1 eq "class" || $1 eq "struct") {

   754                 $next_word_could_be_namespace = 1;

   755                 next;

   756             }

   757 

   758             # Word.

   759             $word = $1;

   760             if (!$skip_til_brace_or_semicolon) {

   761                 if ($next_word_could_be_namespace) {

   762                     $potential_namespace = $word;

   763                     $next_word_could_be_namespace = 0;

   764                 } elsif ($potential_namespace) {

   765                     $potential_namespace = "";

   766                 }

   767 

   768                 if (!$in_parentheses) {

   769                     $potential_start = 0;

   770                     $potential_name = "";

   771                 }

   772                 if (!$potential_start) {

   773                     $potential_start = $.;

   774                     $potential_name = "";

   775                 }

   776             }

   777         }

   778     }

   779 

   780     warn "missing close braces in $file_name (probable start at $brace_start)\n" if ($in_braces > 0);

   781     warn "too many close braces in $file_name (probable start at $brace_end)\n" if ($in_braces < 0);

   782 

   783     warn "mismatched parentheses in $file_name\n" if $in_parentheses;

   784 

   785     return @ranges;

   786 }

   787 

   788 

   789 

   790 # Read a file and get all the line ranges of the things that look like Java

   791 # classes, interfaces and methods.

   792 #

   793 # A class or interface name is the word that immediately follows

   794 # `class' or `interface' when followed by an open curly brace and not

   795 # a semicolon. It can appear at the top level, or inside another class

   796 # or interface block, but not inside a function block

   797 #

   798 # A class or interface starts at the first character after the first close

   799 # brace or after the function name and ends at the close brace.

   800 #

   801 # A function name is the last word before an open parenthesis before

   802 # an open brace rather than a semicolon. It can appear at top level or

   803 # inside a class or interface block, but not inside a function block.

   804 #

   805 # A function starts at the first character after the first close

   806 # brace or after the function name and ends at the close brace.

   807 #

   808 # Comment handling is simple-minded but will work for all but pathological cases.

   809 #

   810 # Result is a list of triples: [ start_line, end_line, function_name ].

   811 

   812 sub get_function_line_ranges_for_java($$)

   813 {

   814     my ($file_handle, $file_name) = @_;

   815 

   816     my @current_scopes;

   817 

   818     my @ranges;

   819 

   820     my $in_comment = 0;

   821     my $in_macro = 0;

   822     my $in_parentheses = 0;

   823     my $in_braces = 0;

   824     my $in_non_block_braces = 0;

   825     my $class_or_interface_just_seen = 0;

   826 

   827     my $word = "";

   828 

   829     my $potential_start = 0;

   830     my $potential_name = "";

   831     my $potential_name_is_class_or_interface = 0;

   832 

   833     my $start = 0;

   834     my $name = "";

   835     my $current_name_is_class_or_interface = 0;

   836 

   837     while (<$file_handle>) {

   838         # Handle continued multi-line comment.

   839         if ($in_comment) {

   840             next unless s-.*\*/--;

   841             $in_comment = 0;

   842         }

   843 

   844         # Handle continued macro.

   845         if ($in_macro) {

   846             $in_macro = 0 unless /\\$/;

   847             next;

   848         }

   849 

   850         # Handle start of macro (or any preprocessor directive).

   851         if (/^\s*\#/) {

   852             $in_macro = 1 if /^([^\\]|\\.)*\\$/;

   853             next;

   854         }

   855 

   856         # Handle comments and quoted text.

   857         while (m-(/\*|//|\'|\")-) { # \' and \" keep emacs perl mode happy

   858             my $match = $1;

   859             if ($match eq "/*") {

   860                 if (!s-/\*.*?\*/--) {

   861                     s-/\*.*--;

   862                     $in_comment = 1;

   863                 }

   864             } elsif ($match eq "//") {

   865                 s-//.*--;

   866             } else { # ' or "

   867                 if (!s-$match([^\\]|\\.)*?$match--) {

   868                     warn "mismatched quotes at line $. in $file_name\n";

   869                     s-$match.*--;

   870                 }

   871             }

   872         }

   873 

   874         # Find function names.

   875         while (m-(\w+|[(){};])-g) {

   876             # Open parenthesis.

   877             if ($1 eq "(") {

   878                 if (!$in_parentheses) {

   879                     $potential_name = $word;

   880                     $potential_name_is_class_or_interface = 0;

   881                 }

   882                 $in_parentheses++;

   883                 next;

   884             }

   885 

   886             # Close parenthesis.

   887             if ($1 eq ")") {

   888                 $in_parentheses--;

   889                 next;

   890             }

   891 

   892             # Open brace.

   893             if ($1 eq "{") {

   894                 # Promote potential name to real function name at the

   895                 # start of the outer level set of braces (function/class/interface body?).

   896                 if (!$in_non_block_braces

   897                     and (!$in_braces or $current_name_is_class_or_interface)

   898                     and $potential_start) {

   899                     if ($name) {

   900                           push @ranges, [ $start, ($. - 1),

   901                                           join ('.', @current_scopes) ];

   902                     }

   903 

   904 

   905                     $current_name_is_class_or_interface = $potential_name_is_class_or_interface;

   906 

   907                     $start = $potential_start;

   908                     $name = $potential_name;

   909 

   910                     push (@current_scopes, $name);

   911                 } else {

   912                     $in_non_block_braces++;

   913                 }

   914 

   915                 $potential_name = "";

   916                 $potential_start = 0;

   917 

   918                 $in_braces++;

   919                 next;

   920             }

   921 

   922             # Close brace.

   923             if ($1 eq "}") {

   924                 $in_braces--;

   925 

   926                 # End of an outer level set of braces.

   927                 # This could be a function body.

   928                 if (!$in_non_block_braces) {

   929                     if ($name) {

   930                         push @ranges, [ $start, $.,

   931                                         join ('.', @current_scopes) ];

   932 

   933                         pop (@current_scopes);

   934 

   935                         if (@current_scopes) {

   936                             $current_name_is_class_or_interface = 1;

   937 

   938                             $start = $. + 1;

   939                             $name =  $current_scopes[$#current_scopes-1];

   940                         } else {

   941                             $current_name_is_class_or_interface = 0;

   942                             $start = 0;

   943                             $name =  "";

   944                         }

   945                     }

   946                 } else {

   947                     $in_non_block_braces-- if $in_non_block_braces;

   948                 }

   949 

   950                 $potential_start = 0;

   951                 $potential_name = "";

   952                 next;

   953             }

   954 

   955             # Semicolon.

   956             if ($1 eq ";") {

   957                 $potential_start = 0;

   958                 $potential_name = "";

   959                 next;

   960             }

   961 

   962             if ($1 eq "class" or $1 eq "interface") {

   963                 $class_or_interface_just_seen = 1;

   964                 next;

   965             }

   966 

   967             # Word.

   968             $word = $1;

   969             if (!$in_parentheses) {

   970                 if ($class_or_interface_just_seen) {

   971                     $potential_name = $word;

   972                     $potential_start = $.;

   973                     $class_or_interface_just_seen = 0;

   974                     $potential_name_is_class_or_interface = 1;

   975                     next;

   976                 }

   977             }

   978             if (!$potential_start) {

   979                 $potential_start = $.;

   980                 $potential_name = "";

   981             }

   982             $class_or_interface_just_seen = 0;

   983         }

   984     }

   985 

   986     warn "mismatched braces in $file_name\n" if $in_braces;

   987     warn "mismatched parentheses in $file_name\n" if $in_parentheses;

   988 

   989     return @ranges;

   990 }

   991 

   992 

   993 

   994 # Read a file and get all the line ranges of the things that look like

   995 # JavaScript functions.

   996 #

   997 # A function name is the word that immediately follows `function' when

   998 # followed by an open curly brace. It can appear at the top level, or

   999 # inside other functions.

  1000 #

  1001 # An anonymous function name is the identifier chain immediately before

  1002 # an assignment with the equals operator or object notation that has a

  1003 # value starting with `function' followed by an open curly brace.

  1004 #

  1005 # A getter or setter name is the word that immediately follows `get' or

  1006 # `set' when followed by an open curly brace .

  1007 #

  1008 # Comment handling is simple-minded but will work for all but pathological cases.

  1009 #

  1010 # Result is a list of triples: [ start_line, end_line, function_name ].

  1011 

  1012 sub get_function_line_ranges_for_javascript($$)

  1013 {

  1014     my ($fileHandle, $fileName) = @_;

  1015 

  1016     my @currentScopes;

  1017     my @currentIdentifiers;

  1018     my @currentFunctionNames;

  1019     my @currentFunctionDepths;

  1020     my @currentFunctionStartLines;

  1021 

  1022     my @ranges;

  1023 

  1024     my $inComment = 0;

  1025     my $inQuotedText = "";

  1026     my $parenthesesDepth = 0;

  1027     my $bracesDepth = 0;

  1028 

  1029     my $functionJustSeen = 0;

  1030     my $getterJustSeen = 0;

  1031     my $setterJustSeen = 0;

  1032     my $assignmentJustSeen = 0;

  1033 

  1034     my $word = "";

  1035 

  1036     while (<$fileHandle>) {

  1037         # Handle continued multi-line comment.

  1038         if ($inComment) {

  1039             next unless s-.*\*/--;

  1040             $inComment = 0;

  1041         }

  1042 

  1043         # Handle continued quoted text.

  1044         if ($inQuotedText ne "") {

  1045             next if /\\$/;

  1046             s-([^\\]|\\.)*?$inQuotedText--;

  1047             $inQuotedText = "";

  1048         }

  1049 

  1050         # Handle comments and quoted text.

  1051         while (m-(/\*|//|\'|\")-) { # \' and \" keep emacs perl mode happy

  1052             my $match = $1;

  1053             if ($match eq '/*') {

  1054                 if (!s-/\*.*?\*/--) {

  1055                     s-/\*.*--;

  1056                     $inComment = 1;

  1057                 }

  1058             } elsif ($match eq '//') {

  1059                 s-//.*--;

  1060             } else { # ' or "

  1061                 if (!s-$match([^\\]|\\.)*?$match--) {

  1062                     $inQuotedText = $match if /\\$/;

  1063                     warn "mismatched quotes at line $. in $fileName\n" if $inQuotedText eq "";

  1064                     s-$match.*--;

  1065                 }

  1066             }

  1067         }

  1068 

  1069         # Find function names.

  1070         while (m-(\w+|[(){}=:;])-g) {

  1071             # Open parenthesis.

  1072             if ($1 eq '(') {

  1073                 $parenthesesDepth++;

  1074                 next;

  1075             }

  1076 

  1077             # Close parenthesis.

  1078             if ($1 eq ')') {

  1079                 $parenthesesDepth--;

  1080                 next;

  1081             }

  1082 

  1083             # Open brace.

  1084             if ($1 eq '{') {

  1085                 push(@currentScopes, join(".", @currentIdentifiers));

  1086                 @currentIdentifiers = ();

  1087 

  1088                 $bracesDepth++;

  1089                 next;

  1090             }

  1091 

  1092             # Close brace.

  1093             if ($1 eq '}') {

  1094                 $bracesDepth--;

  1095 

  1096                 if (@currentFunctionDepths and $bracesDepth == $currentFunctionDepths[$#currentFunctionDepths]) {

  1097                     pop(@currentFunctionDepths);

  1098 

  1099                     my $currentFunction = pop(@currentFunctionNames);

  1100                     my $start = pop(@currentFunctionStartLines);

  1101 

  1102                     push(@ranges, [$start, $., $currentFunction]);

  1103                 }

  1104 

  1105                 pop(@currentScopes);

  1106                 @currentIdentifiers = ();

  1107 

  1108                 next;

  1109             }

  1110 

  1111             # Semicolon.

  1112             if ($1 eq ';') {

  1113                 @currentIdentifiers = ();

  1114                 next;

  1115             }

  1116 

  1117             # Function.

  1118             if ($1 eq 'function') {

  1119                 $functionJustSeen = 1;

  1120 

  1121                 if ($assignmentJustSeen) {

  1122                     my $currentFunction = join('.', (@currentScopes, @currentIdentifiers));

  1123                     $currentFunction =~ s/\.{2,}/\./g; # Removes consecutive periods.

  1124 

  1125                     push(@currentFunctionNames, $currentFunction);

  1126                     push(@currentFunctionDepths, $bracesDepth);

  1127                     push(@currentFunctionStartLines, $.);

  1128                 }

  1129 

  1130                 next;

  1131             }

  1132 

  1133             # Getter prefix.

  1134             if ($1 eq 'get') {

  1135                 $getterJustSeen = 1;