cross-reference/genxref

#!/usr/bin/perl
# $Id: genxref,v 1.7 2006/12/07 04:59:38 reed%reedloden.com Exp $

# genxref.pl --	Finds identifiers in a set of C files using an
#		extremely fuzzy algorithm.  It sort of works.
#
#	Arne Georg Gleditsch <argggh@ifi.uio.no>
#	Per Kristian Gjermshus <pergj@ifi.uio.no>
#
#
# This program 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.
#
# This program 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.

# TODO: ns/cmd/xfe/src/MozillaApp.h, XFE_MozillaApp

######################################################################

use lib 'lib';
use integer;
use DB_File;
use strict;

my %fileidx;

my %itype = (('macro',	'M'),
	  ('typedef',	'T'),
	  ('struct',	'S'),
	  ('enum',	'E'),
	  ('union',	'U'),
	  ('function',	'F'),
	  ('funcprot',	'f'),
	  ('class',	'C'),	# (C++)
	  ('classforw',	'c'),	# (C++)
	  ('var',	'V'),
          ('interface', 'I'),
	  ('reference', 'R'),
	 );

my @reserved = ('auto', 'break', 'case', 'char', 'const', 'continue',
	     'default', 'do', 'double', 'else', 'enum', 'extern',
	     'float', 'for', 'goto', 'if', 'int', 'long', 'register',
	     'return', 'short', 'signed', 'sizeof', 'static',
	     'struct', 'switch', 'typedef', 'union', 'unsigned',
	     'void', 'volatile', 'while', 'fortran', 'asm',
	     'inline', 'operator',
	     'class',		# (C++)
# Her bør vi ha flere av disse:
	     '__inline',        # seved
	     '__asm__','__inline__');


my @reservedJS = ( 'abstract',   'as',   'break',   'case',   'catch',   'class',   'const',   'continue',  'default',   'delete',   'do',   'else',   'export',   'extends',   'false',   'final',   'finally',   'for',   'function',   'if',   'import',   'in',   'instanceof',   'is',   'namespace',   'new',   'null',   'package',   'private',   'public',   'return',   'static',   'super',   'switch',   'this ',  'throw',   'true',   'try',   'typeof',   'use',   'var',   'let',    'void',   'while',   'with');

my @reservedXUL = (''); #nothing yet
my @reservedXBL = (''); #nothing yet

my %xref;

my (@ft, @f, @jsfiles, @plfiles, @idlfiles, @xblfiles);

my $ident = '\~?_*[a-zA-Z][a-zA-Z0-9_]*';
my $fnum = 1;

my $plidentp = '[$@%&]';
my ($realpath, $verb, $fix, @extra) = @ARGV;
$realpath ||= '.';
$realpath .= '/';
$verb = 'default' unless defined $verb;
my $suffix = defined $fix ? ".$fix" : '';

my ($totaldefs, $totalrefs) = (0, 0);

sub wash {
    my $towash = $_[0];
    return ("\n" x ($towash =~ tr/\n//));
}

sub stripodd {
    my $tostrip = $_[0];
    while ($tostrip =~ s/\{([^\{\}]*)\}/\05$1\06/gs) {}
    $tostrip =~ s/[\{\}]//gs; # remove *before* restoring outermost block
    $tostrip =~ tr/\05\06/\{\}/;
    return($tostrip);
}

sub enumval {
    my $enum_conts = $_[0];
    $enum_conts =~ s/($ident)([^,]*(?:,|$))/"enum \01$itype{'enum'}$1\02 ;".&wash($2)/ges;
    return($enum_conts);
}

sub classes {
    my @c = (shift =~ /($ident)\s*(?:$|,)/gm);
    if (@c) {
	return(join(":", @c)."::");
    } else {
	return('');
    }
}

sub findidentXBL {
    print(STDERR "Starting pass 1 for XBL: Collect identifier definitions.\n");
    my $start = time;
    my $defs = 0;
    my $f = "";
    my $contents = "";
    my @contents;
    my $curfnum = 0;

    foreach $f (@xblfiles) {
        $fileidx{++$fnum} = $f;
        ++$curfnum;

        open(SRCFILE, $realpath.$f);
        {
            local $/ = undef;
            $contents = <SRCFILE>;
        }
        close(SRCFILE);

        print(STDERR
              "(Pass 1 XBL) $f (",length($contents),
              "), file $curfnum of ",$#xblfiles+1,"...\n");

        # XBL
        next unless $contents =~ /<!DOCTYPE\s+bindings/ms;

        # Remove comments.
        # Magic
        $contents =~ s/<\?([^?]*(?:\?[^?>]|))*\?>/&wash($1)/ges;
        # XML Comment
        $contents =~ s/^<!--(?:\w+?\n)-->/&wash($1)/ges;
        # Preprocessor Comment
        $contents =~ s/^\s*\#[^\n]*//g;

        # From here on, \01 and \02 are used to encapsulate found
        # identifiers,

        my ($ct, $ct2, $input);
        $ct = $input = $contents;
        $contents = '';
        my $ct2 = ($ct =~ s/\n//g) || 0;
        my ($ids, $junk, $tailjunk, $junkkind);
        my (@tagstack, @tagattrs);
        # <tag...>
        # </tag>
        my ($class, $func);
        my $l = 1;
        while ($input =~ s{(^.*?<)(/?)(\w+)([^>]*)>}{}ms) {
            my ($pre, $close, $tag, $rest) = ($1, $2, $3, $4);
            $l += ($pre =~ s/\n//g) || 0;
            if ($close) {
                pop @tagstack;
                pop @tagattrs;
                for ($tag) {
                  /^binding$/ && do {
                    $class = undef;
                    last;
                  };
                  /^(?:property|method|field)$/ && do {
                    $func = undef;
                    last;
                  };
                }
                next;
            }
            my %attrs = ();
            push @tagstack, $tag;
            push @tagattrs, \%attrs;
            my %attrlines = ();
            my $attrline = 0;
            while ($rest =~ /(\s+)(\S+)(\s*=\s*)(?:"([^"]*)"|'([^']*)')/g) {
                my ($pre, $attr, $val) = ($1.$3, $2.$5, $4.$6);
                $attrline += ($pre =~ s/\n//g) || 0;
                $attrs{$attr} = $val;
                $attrlines{$attr} = $attrline;
                $attrline += ($val =~ s/\n//g) || 0;
            }
            for ($tag) {
              /^(?:content|children|resources|body|handlers)$/ && do {
                last;
              };
              /^binding$/ && do {
                # Binding (class) declarations
                if (defined $attrs{'id'}) {
                    $class = $attrs{'id'};
                    $contents = $contents . "\04$l\01" .
                      $itype{'classforw'} .
                      $class .
                      "\02";
                }
                last;
              };
              /^implementation$/ && do {
                # Implementation (interface) derivations
                if (defined $attrs{'implements'}) {
                    $contents .=
                      "\04$l\01" .
                      $itype{'class'} .
                      &classes($attrs{'implements'}) .
                      "$class\02";
                }
                last;
              };
              /^(de|con)structor$/ && do {
                if (defined $class) {
                    $contents .=
                      "\04$l\01" .
                      $itype{'function'} .
                      &classes($class) .
                      ($1 eq 'de' ? '~' : '') .
                      $class .
                      "\02";
                }
                last;
              };
              /^([gs])etter$/ && do {
                my $prefix = $1;
                $func =~ /^(.)(.*)/;
                # as an experiment, this declares both the flavors
                $contents .=
                  "\04$l\01" .
                  $itype{'function'} .
                  $prefix . 'et' . uc($1) . $2 .
                  "\02";
                last;
              };
              /^(?:property|method|field)$/ && do {
                if (defined $attrs{'name'}) {
                    $func = $attrs{'name'};
                    $contents .=
                      "\04$l\01" .
                      $itype{'function'} .
                      $func .
                      "\02";
                    foreach my $attr (qw(onget onset)) {
                        if (defined $attrs{$attr}) {
                            $attr =~ /on([gs])et/;
                            my $prefix = $1;
                            $func =~ /(.)(.*)/;
                            $contents .=
                              "\04".($l+$attrlines{$attr})."\01" .
                              $itype{'function'} .
                              $prefix . 'et' . uc($1) . $2 .
                              "\02";
                        }
                    }
                }
                last;
              };
              /^handler$/ && do {
                if (defined $attrs{'event'}) {
                    $func = $attrs{'event'};
                    $contents .=
                      "\04$l\01" .
                      $itype{'function'} .
                      $func .
                      "\02";
                    $func = "on$func";
                    $contents .=
                      "\04$l\01" .
                      $itype{'function'} .
                      $func .
                      "\02";
                }
                last;
              };
              /^parameter$/ && do {
                if (defined $attrs{'name'}) {
                    $contents .=
                      "\04$l\01" .
                      $itype{'reference'} .
                      $attrs{'name'} .
                      "\02";
                }
                last;
              };
            }
            $l += $attrline;
        }

        foreach ($contents =~ /^(.*)/gm) {
            while (/\04(\d+)\01(.)($ident)\02/go) {
                $xref{$3} .= "$2$fnum:$1\t";
                $defs++;
            }
        }
    }

    # Cleanup.
    foreach (@reservedJS) {
        delete($xref{$_});
    }

    $totaldefs = $totaldefs + $defs;

    print(STDERR
          "Completed pass 1 XBL (",(time-$start),"s):",
          " $defs definitions found (total found so far: $totaldefs).\n\n");
}



sub findidentPL {
    print(STDERR "Starting pass 1 for Perl: Collect identifier definitions.\n");

    my $start = time;
    my $defs = 0;
    my $f = "";
    my $contents = "";
    my @contents;
    my $curfnum = 0;

    foreach $f (@plfiles) {
        $fileidx{++$fnum} = $f;
        ++$curfnum;

        open(SRCFILE, $realpath.$f);
        {
            local $/ = undef;
            $contents = <SRCFILE>;
        }
        close(SRCFILE);

        print(STDERR
              "(Pass 1 Perl) $f (",length($contents),
              "), file $curfnum of ",$#plfiles+1,"...\n");

        # Remove comments.
        $contents =~ s/(\n)=(\w+?\n.*?)=cut/&wash($1 . $2)/ges; # Perl Pod
        $contents =~ s/\#[^\n]*//g; # Perl Comment

        # Unwrap continuation lines.
        $contents =~ s/\\\s*\n/\05/gs;
        while ($contents =~ s/\05([^\n\05]+)\05/$1\05\05/gs) {}
        $contents =~ s/(\05+)([^\n]*)/"$2"."\n" x length($1)/gse;

        # Remove nested parentheses.
        while ($contents =~ s/\(([^\)]*)\(/\($1\05/g ||
               $contents =~ s/\05([^\(\)]*)\)/ $1 /g) {}

        # Some heuristics here: Try to recognize "code" and delete
        # everything up to the next block delimiter.
        # $contents =~ s/([\;\}\{])(\s*$ident\s*\([^\)]*\)[^\{\}]*)/
        #       "$1".&wash($2)/goes;
        # $contents =~ s/([\;\{])(\s*\**$ident\s*\=[^\{\}]*)/
        #       "$1".&wash($2)/goes;

        # Parentheses containing commas are probably not interesting.
        $contents =~ s/\(([^\)]*\,[^\)]*)\)/
            "()".&wash($1)/ges;

        # Ranges are uninteresting (and confusing).
        $contents =~ s/\[(.*?)\]/&wash($1)/ges;

        # From here on, \01 and \02 are used to encapsulate found
        # identifiers,

        my $ct = $contents;
        my $ct2 = ($ct =~ s/\n//g) || 0;
        my ($ids, $junk, $tailjunk, $junkkind);
        @contents = split(/[;}]/, $contents);
        $contents = '';
        my $l = 1;
        foreach (@contents) {
            my $line = $ct = $_;
            $ct2 = ($ct =~ s/\n//g) || 0;
            my $bl = $l;
            # Package (class) declarations
            if ($line =~ /^(\s*(?:package)\s+(?:\s*$ident\s*::)*\s*)($ident)(\s*)$/m) {
                ($ct, $ids, $tailjunk) = ($1, $2, $3);
                $l += ($ct =~ s/\n//g) || 0;
                $contents .= "\04$l\01".$itype{'class'}."$ids\02";
            }

            $l = $bl;
            # Variable (var) declarations
            if ($line =~ /^(\s*(?:my|local|our)\s+)($plidentp)($ident(?:\s*,\s*$plidentp$ident)*)(.*?)$/m) {
                ($ct, $ids, $tailjunk, $junkkind) = ($1, $3, $4, $2);
                $l += ($ct =~ s/\n//g) || 0;
                my @idds = split /\b/, $ids;
                while (@idds) {
                    my $lid = shift @idds;
                    $lid =~ /($ident)/;
                    $contents .= "\04$l\01".$itype{'var'}."$1\02";
                    my $spc;
                    do {
                        $spc = shift @idds;
                        $l += $spc =~ s/[\r\n]//g;
                    } while ($spc =~ /[,=]/);
                }
            }

            $l = $bl;
            # Function (function) declarations
            if ($line =~ /^(.*?\s*\b)sub(\s+)($ident|)(\s*.*)$/sm) {
                my ($impl, $ws1, $ws2, $ws3) = ($3, $1, $2, $4);
                $l += $ws1 =~ s/\n//g;
                $l += $ws2 =~ s/\n//g;
                $contents .= "\04$l\01".$itype{'function'}."$impl\02" if $impl;
                $l += $ws3 =~ s/\n//g;
            }

            $l = $bl;
            # constant property () declarations
=useless
            if ($line =~ /($ident)\s*=>/m) {
            }
            $l = $bl;
=cut
            $l += $ct2;
        }

        foreach ($contents =~ /^(.*)/gm) {
            while (/\04(\d+)\01(.)($ident)\02/go) {
                $xref{$3} .= "$2$fnum:$1\t";
                $defs++;
            }
        }
    }

    # Cleanup.
    foreach (@reservedJS) {
        delete($xref{$_});
    }

    $totaldefs = $totaldefs + $defs;

    print(STDERR
	  "Completed pass 1 Perl (",(time-$start),"s):",
	  " $defs definitions found (total found so far: $totaldefs).\n\n");
}

sub findidentJS {
    print(STDERR "Starting pass 1 for Javascript: Collect identifier definitions.\n");

    my $start = time;
    my $defs = 0;
    my $f = "";
    my $contents = "";
    my @contents;
    my $curfnum = 0;

    foreach $f (@jsfiles) {
        $fileidx{++$fnum} = $f;
        ++$curfnum;

        open(SRCFILE, $realpath.$f);
        {
            local $/ = undef;
            $contents = <SRCFILE>;
        }
        close(SRCFILE);

        print(STDERR
              "(Pass 1 JS) $f (",length($contents),
              "), file $curfnum of ",$#jsfiles+1,"...\n");

        # Remove comments.
        $contents =~ s{/\*(.*?)\*/}{&wash($1)}ges;
        $contents =~ s{//[^\n]*}{}g; # C++
        # $contents =~ s{^# [^\n]*|^#($)}{$1}gm; # evil preprocessor

        # Remove license blocks.
        $contents =~ s{(# \*\*\*\*\* BEGIN LICENSE BLOCK \*\*\*\*\*.*?# \*\*\*\*\* END LICENSE BLOCK \*\*\*\*\*)}{&wash($1)}ges;

        # Unwrap continuation lines.
        $contents =~ s/\\\s*\n/\05/gs;
        while ($contents =~ s/\05([^\n\05]+)\05/$1\05\05/gs) {}
        $contents =~ s/(\05+)([^\n]*)/"$2"."\n" x length($1)/gse;

        # Remove nested parentheses.
        # while ($contents =~ s/\(([^\)]*)\(/\($1\05/g ||
        #        $contents =~ s/\05([^\(\)]*)\)/ $1 /g) {}

        # Some heuristics here: Try to recognize "code" and delete
        # everything up to the next block delimiter.
        # $contents =~ s/([\;\}\{])(\s*$ident\s*\([^\)]*\)[^\{\}]*)/
        #       "$1".&wash($2)/goes;
        # $contents =~ s/([\;\{])(\s*\**$ident\s*\=[^\{\}]*)/
        #       "$1".&wash($2)/goes;

        # Parentheses containing commas are probably not interesting.
        # $contents =~ s/\(([^\)]*\,[^\)]*)\)/
        #    "()".&wash($1)/ges;

        # This operator-stuff messes things up. (C++)
        $contents =~ s/operator[\<\>\=\!\+\-\*\%\/]{1,2}/operator/g;

        # Ranges are uninteresting (and confusing).
        $contents =~ s/\[(.*?)\]/&wash($1)/ges;

        # From here on, \01 and \02 are used to encapsulate found
        # identifiers,

=pod
        # Find class definitions. (C++)
        $contents =~ s/((class)\s+($ident)\s*(:[^;\{]*|)({}|(;)))/
            "$2 "."\01".$itype{$2.($6 ? 'forw' : '')}.
                &classes($4).$3."\02 ".$6.&wash($1)/goes;
=cut

        my $pre;
        my $ct = $contents;
        my $ct2 = ($ct =~ s/\n//g) || 0;
        my ($ids, $junk);
        @contents = split(/[;}]/, $contents);
        $contents = '';
        my $l = 1;
        foreach (@contents) {
            my $line = $ct = $_;
            $ct2 = ($ct =~ s/\n//g) || 0;
            if ($line && $line =~ /(var|let|const)|(function|[gs]et)/) {
                my ($var_let_const, $function_get_set) = ($1, $2);
                my $bl = $l;
                if ($var_let_const &&
                    $line =~ /^(.*\b(?:var|let|const)\s+)($ident(?:\s*(?:=[^,;]*|),\s*$ident)*)(.*?(?:\n|$))/s) {
                    ($pre, $ids, $junk) = ($1, $2, $3);
                    $l += ($pre =~ s/\n//g) || 0;
                    my @idds = split /\b/, $ids;
                    while (@idds) {
                        my $lid = shift @idds;
                        $lid =~ /($ident)/;
                        $contents .= "\04$l\01".$itype{'var'}."$1\02";
                        my $spc;
                        do {
                            $spc = shift @idds;
                            $l += $spc =~ s/[\r\n]//g;
                        } while ($spc =~ /[,=]/);
                    }
                    $l = $bl;
                }
                if ($function_get_set &&
                    $line =~ /^(.*\n|)(.*?\s*)((?:$ident\s*[:=]*\s*)*)(?:function|[gs]et)(\s+)($ident|)(\s*.*)(\n|$)/s) {
                    my ($decl, $impl, $ws1, $ws2, $ws3, $ws0) = ($3, $5, $2, $4, $6, $1);
                    $l += $ws0 =~ s/\n//g;
                    $l += $ws1 =~ s/\n//g;
                    if ($decl) {
                        my @idds = split /\b/, $decl;
                        while (@idds) {
                            my $lid = shift @idds;
                            if ($lid =~ /($ident)/) {
                                $contents .= "\04$l\01".$itype{'function'}."$1\02";
                            } else {
                                $l += $lid =~ s/\n//g;
                            }
                        }
                    }
                    $l += $ws2 =~ s/\n//g;
                    $contents .= "\04$l\01".$itype{'function'}."$impl\02" if $impl;
                    $l += $ws3 =~ s/\n//g;
                    $l = $bl;
                }
            }
            $l += $ct2;
        }

        foreach ($contents =~ /^(.*)/gm) {
            while (/\04(\d+)\01(.)($ident)\02/go) {
                $xref{$3} .= "$2$fnum:$1\t";
                $defs++;
            }
        }
    }

    # Cleanup.
    foreach (@reservedJS) {
        delete($xref{$_});
    }

    $totaldefs = $totaldefs + $defs;

    print(STDERR
	  "Completed pass 1 Javascript (",(time-$start),"s):",
	  " $defs definitions found (total found so far: $totaldefs).\n\n");
}

sub c_clean {
    my $contents = $_[0];
    # We don't care so much about proper style,
    # from our perspective, most operators are equivalent to ,
    $contents =~ s{[-+<>=%&|?^]+}{,}g;

    # Find macro (un)definitions.
    my $l = 0;
    my $defs;
    foreach ($contents =~ /^(.*)/gm) {
	$l++;
	if (/^[ \t]*\#\s*(define|undef)\s+($ident)/o) {
	    $xref{$2} .= "$itype{'macro'}$fnum:$l\t";
	    $defs++;
	}
    }

    # We want to do some funky heuristics with preprocessor blocks
    # later, so mark them. (FIXME: #elif)
    $contents =~ s/^[ \t]*\#\s*if.*/\01/gm;
    $contents =~ s/^[ \t]*\#\s*else.*/\02/gm;
    $contents =~ s/^[ \t]*\#\s*endif.*/\03/gm;

    # Strip all preprocessor directives.
    $contents =~ s/^[ \t]*\#(.*)//gm;

    # Now, remove all odd block markers ({,}) we find inside
    # #else..#endif blocks.  (And pray they matched one in the
    # preceding #if..#else block.)
    while ($contents =~ s/\02([^\01\02\03]*\03)/&stripodd($1)/ges ||
	   $contents =~ s/\01([^\01\02\03]*)\03/&stripodd($1)/ges) {}

    while ($contents =~ /([\01\02\03\04\05])/gs) {
	print(STDERR "\t ** stray ".($1 eq "\01"
				     ? "#if"
				     : ($1 eq "\02"
					? "#else"
					: ($1 eq "\03"
					   ? "#endif"
					   : "control sequence"
					   )
					)
				     )." found.\n");
    }
    $contents =~ s/[\01\02\03\04\05]//gs;

    # Special treatment of enum and struct: inhibit removal of such blocks
    $contents =~ s/(\s+enum\s+)($ident|)(\s*)\{([^\}]*)\}(\s*)($ident|)/
	"$1 ".($2 ? "\01".$itype{enum}.$2."\02 " : "").$3.&enumval($4).$5.($6 ? "\01".$itype{enum}.$6."\02 " : "")/goes;

    $contents =~ s/(\s+struct\s+)($ident|)(\s*)\{([^\}]*)\}(\s*)($ident|)/
	$1.$2.$3."{}".$4.$5.($6 ? "\01".$itype{typedef}.$6."\02 " : "")/goes;

=pod
    # Remove all but outermost blocks.  (No local variables.)
    while ($contents =~ s/\{([^\{\}]*)\}/
	   "\05".&wash($1)/ges) {}
    $contents =~ s/\05/\{\}/gs;
=cut

    # This operator-stuff messes things up. (C++)
    $contents =~ s/operator[\<\>\=\!\+\-\*\%\/]{1,2}/operator/g;

    # Ranges are uninteresting (and confusing).
    $contents =~ s/\[(.*?)\]/&wash($1)/ges;

    # And so are assignments.
    $contents =~ s/\=(.*?);/";".&wash($1)/ges;

    return $contents;
}

sub java_clean {
    my $contents = $_[0];
    while ($contents =~ s/(\{[^\{]*)\{([^\{\}]*)\}/
	   $1."\05".&wash($2)/ges) {}
    $contents =~ s/\05/\{\}/gs;

    # Remove imports
    $contents =~ s/(^\s*import.*;)/&wash($1)/gem;

    # Remove packages
    $contents =~ s/(^\s*package.*;)/&wash($1)/gem;

    return $contents;
}

sub c_classes {
    my $contents = $_[0];
# XXX this has issues w/ whitespace
    # Find struct, enum and union definitions with params (function returning struct etc)
    $contents =~ s/((struct|enum|union)\s+($ident|)\s+($ident|)\s*([{;]))/
	"$2 ".($3 ? "\01".$itype{$2}.$3."\02 " : " ").$4.$5.&wash($1)/gmoes;

    # Find struct, enum and union definitions.
    $contents =~ s/((struct|enum|union)\s+($ident|)\s*([{;]))/
	"$2 ".($3 ? "\01".$itype{$2}.$3."\02 " : "").$4.&wash($1)/gmoes;

    # Find class definitions. (C++)
    $contents =~ s/((class)\s+($ident)\s*(:[^;\{]*|)([{;]))/
	"$2 "."\01".$itype{$2.($5 eq ';' ? 'forw' : '')}.
	    &classes($4).$3."\02 ".$5.&wash($1)/gmoes;

    return $contents;
}

sub java_classes {
    my $contents = $_[0];

    # Find Java classes
    $contents =~ s/((class)\s+($ident)\s*(extends\s+([\.\w]+)\s*|)(implements\s+([\.\w]+)|))/
	"$2 "."\01".$itype{$2}.&classes($5.", ".$7).$3."\02 ".
	    &wash($1)/goes;

    # Find Java interfaces
    $contents =~ s/((interface)\s+($ident)\s*(extends\s+([\.\w]+)|))/
	"$2 "."\01".$itype{$2}.&classes($5).$3."\02 ".&wash($1)/goes;
    return $contents;
}

sub idl_decl {
    return 'NS_DECL_'.(uc shift);
}

sub idl_interfaces {
    my $contents = $_[0];
    # Find IDL interfaces

    $contents =~ s/((interface)\s+($ident)\s*(:[^;\{]*|)(\{|(;)))/
	"$2 ".($6 ? '' : "\01".$itype{macro}.idl_decl($3)."\02 ").
        "\01".$itype{$2.($6 ? 'forw' : '')}.
	    &classes($4).$3."\02 ".$6.&wash($1)/goes;

    return $contents;
}

sub findidentIDL {
    print(STDERR "Starting pass 1 for IDL: Collect identifier definitions.\n");
    my $start = time;
    my $defs = 0;
    my $f = "";
    my $contents = "";
    my @contents;
    my $curfnum = 0;

    foreach $f (@idlfiles) {
        $fileidx{++$fnum} = $f;
        ++$curfnum;

        open(SRCFILE, $realpath.$f);
        $_ = $/; undef($/); $contents = <SRCFILE>; $/ = $_;
        close(SRCFILE);

        print(STDERR
              "(Pass 1 IDL) $f (",length($contents),
              "), file $curfnum of ",$#idlfiles+1,"...\n");

        # Remove comments.
        $contents =~ s/\/\*(.*?)\*\//&wash($1)/ges;
        $contents =~ s/\/\/[^\n]*//g; # C++

        # Remove annotations
        # XXX uuids should eventually be stored somehow
        $contents =~ s/\[[^]]*\]//gs;

        # Unwrap continuation lines.
        $contents =~ s/\\\s*\n/\05/gs;
        while ($contents =~ s/\05([^\n\05]+)\05/$1\05\05/gs) {}
        $contents =~ s/(\05+)([^\n]*)/"$2"."\n" x length($1)/gse;

        $contents = c_clean($contents);

        # Remove nested parentheses.
        while ($contents =~ s/\(([^\)]*)\(/\($1\05/g ||
               $contents =~ s/\05([^\(\)]*)\)/ $1 /g) {}

        # From here on, \01 and \02 are used to encapsulate found
        # identifiers,

        $contents = idl_interfaces($contents);

        @contents = split(/[;\}]/, $contents);
        $contents = '';

        foreach (@contents) {
# readonly attribute
# const

#                s/^(\s*)(struct|enum|union|inline)/$1/;
# we don't care about [noscript] and similar friends
# they're too complicated
                s/\[([^]]*)\]/&wash($1)/ge;

                if (/$ident[^a-zA-Z0-9_]+$ident/) { # It takes two, baby.

                    my $t = /^\s*typedef/s;     # Is this a type definition?

                    s/((readonly\s+|)attribute\s+|)
                       # ($1) readonly
                                     # ($2) attribute
                      (\s*$ident\s*)
                       # ($3) return or attribute type
                      ($ident)
                       # ($4) Match the identifier
                        ([\s\)]*
                         # ($5) Tokens allowed after identifier
                         (\([^\)]*\)
                          # ($6) Function parameters?
                          |)            # No function parameters
                         (\s*(?:$|,)))/
                          # ($7) Allowed termination chars.
                             &wash($3)."\01".
                             # identifier marker
                                 ($t
                                  # if type definition...
                                  ? $itype{'typedef'}
                                    # ..mark as such
                                  : ($6
                                     # $6 is empty unless function definition.
                                     ? $itype{'funcprot'}
                                       # function prototype.
                                     : $itype{'var'}
                                       # Variable.
                                    )
                                  )."$4\02 ".&wash($5 . $7)/goesx;
                }

            $contents .= $_;
        }

        my $l = 0;
        foreach ($contents =~ /^(.*)/gm) {
            $l++;
            while (/\01(.)(?:([^\01\02]+?)\s*::\s*|)($ident)\02/go) {
                $xref{$3} .= "$1$fnum:$l".($2 ? ":$2" : "")."\t";
                $defs++;
            }
        }
    }

    # Remove reserved from xref
    foreach (@reserved) {
        delete($xref{$_});
    }

    $totaldefs = $totaldefs + $defs;
    print(STDERR
          "Completed pass 1 IDL (",(time-$start),"s):",
          " $defs definitions found (total found so far: $totaldefs).\n\n");

}

sub findident {
    print(STDERR "Starting pass 1 for C/C++: Collect identifier definitions.\n");

    my $start = time;
    my $defs = 0;
    my $f = "";
    my $contents = "";
    my @contents;
    my $curfnum = 0;

    foreach $f (@f) {
	my ($java) = ($ft[$fnum] == 1);
	$fileidx{++$fnum} = $f;
        ++$curfnum;

	open(SRCFILE, $realpath.$f);
	$_ = $/; undef($/); $contents = <SRCFILE>; $/ = $_;
	close(SRCFILE);

	print(STDERR
	      "(Pass 1 C/C++) $f (",length($contents),
              "), file $curfnum of ",$#f+1,"...");

	# Remove comments.
	$contents =~ s/\/\*(.*?)\*\//&wash($1)/ges;
	$contents =~ s/\/\/[^\n]*//g; # C++

	# Unwrap continuation lines.
	$contents =~ s/\\\n/\05/gs;
	while ($contents =~ s/\05([^\n\05]+)\05/$1\05\05/gs) {}
	$contents =~ s/(\05+)([^\n]*)/"$2"."\n" x length($1)/gse;

	if ($java) {
	    $contents = java_clean($contents);
	} else {
	    $contents = c_clean($contents);
	}

	# Remove nested parentheses.
	while ($contents =~ s/\(([^\)]*)\(/\($1\05/g ||
	       $contents =~ s/\05([^\(\)]*)\)/ $1 /g) {}

	# Some heuristics here: Try to recognize "code" and delete
	# everything up to the next block delimiter.
	# $contents =~ s/([\;\}\{])(\s*$ident\s*\([^\)]*\)[^\{\}]*)/
	# 	"$1".&wash($2)/goes;
	# $contents =~ s/([\;\{])(\s*\**$ident\s*\=[^\{\}]*)/
	# 	"$1".&wash($2)/goes;

	# Parentheses containing commas are probably not interesting.
	$contents =~ s/\(([^\)]*\,[^\)]*)\)/
	    "()".&wash($1)/ges;

	# From here on, \01 and \02 are used to encapsulate found
	# identifiers,

	if ($java) {
	    $contents = java_classes($contents);
	} else {
	    $contents = c_classes($contents);
	}

	@contents = split(/[;\}]/, $contents);
	$contents = '';

	foreach (@contents) {
	    if (!$java) {
		my $t = /\n\s*typedef/s;	# Is this a type definition?

		s/(\n\s*)(?:typedef|struct|enum|union|inline|static|__inline)/$1/g;

		if (/$ident[^a-zA-Z0-9_]+$ident/) { # It takes two, baby.

		    s/($ident(?:\s*::\s*$ident|))	# ($1) Match the identifier
			([\s\)]*		# ($2) Tokens allowed after identifier
			 (\([^\)]*\)	# ($3) Function parameters?
			  (?:\s*:[^\{]*|)	# inheritage specification (C++)
			  |)		# No function parameters
			 \s*($|,|\{))/	# ($4) Allowed termination chars.
			     "\01".		# identifier marker
				 ($t			# if type definition...
				  ? $itype{'typedef'} # ..mark as such
				  : ($3		# $3 is empty unless function definition.
				     ? ($4 eq '{' 		# Terminating token indicates
					? $itype{'function'} 	# function or
					: $itype{'funcprot'}) # function prototype.
					  : $itype{'var'}) 	# Variable.
				  )."$1\02 ".&wash($2)/goesx;
		}
	    } else {
		s/($ident)\s*\([^\)]*\)([^\{]*)($|\{)/
		    "\01".($3 eq '{' ? $itype{'function'} : $itype{'funcprot'})."$1\02 ".
			&wash($2)/goesx;	# capture what's between the identifier & the '{' - it may contain newlines!
		s/($ident)\s*(=.*)$/
		    "\01".$itype{'var'}."$1\02 ".&wash($2)/goesx;
	    }

	    $contents .= $_;
	}

	my $l = 0;
	my $ldefs = 0;
	foreach ($contents =~ /^(.*)/gm) {
	    $l++;
	    while (/\01(.)(?:(.+?)\s*::\s*|)($ident)\02/go) {
                $xref{$3} .= "$1$fnum:$l".($2 ? ":$2" : "")."\t";
		$defs++;
		$ldefs++;
	    }
	}
	print(STDERR " $ldefs defs\n");
    }

    # Remove reserved from xref
    foreach (@reserved) {
	delete($xref{$_});
    }

    $totaldefs = $totaldefs + $defs;
    print(STDERR
	  "Completed pass 1 C/C++ (",(time-$start),"s):",
	  " $defs definitions found (total found so far: $totaldefs).\n\n");
}


sub findusagePL {
    print(STDERR "Starting pass 2 Perl: Generate reference statistics.\n");

    my $start = time;
    my $refs = 0;
    my $f;
    my $curfnum = 0;

    foreach $f (@plfiles) {
        ++$fnum;
        ++$curfnum;

	my $lcount = 0;
	my %tref = ();

	open(SRCFILE, $realpath.$f);
	$_ = $/; undef($/); my $contents = <SRCFILE>; $/ = $_;
	close(SRCFILE);

	print(STDERR
	      "(Pass 2 Perl) $f (",length($contents),
              "), file $curfnum of ",$#plfiles+1,"...\n");

        # Remove comments.
        $contents =~ s/(\n)=(\w+?\n.*?)=cut/&wash($1 . $2)/ges; # Perl Pod
        $contents =~ s/\#[^\n]*//g; # Perl Comment

	# FIXME: "var"

	my @lines = split(/\n/, $contents);
	my $line;

	foreach $line (@lines) {
	    $lcount++;
	    foreach ($line =~ /(?:^|[^a-zA-Z_\#]|$plidentp)($ident)\b/og) {
		$tref{$_} .= "$lcount," if $xref{$_};
	    }
	}

	while (($a, $b) = each(%tref)) {
	    chop($b);
	    $xref{$a} .= "R$fnum:$b\t";
	    $refs++;
	}
    }
    $totalrefs = $totalrefs + $refs;
    print(STDERR
	  "Completed pass 2 (",(time-$start),"s):",
	  " $refs references to known identifiers found (total: $totalrefs).\n\n");
}

sub findusageJS {
    print(STDERR "Starting pass 2 Javascript: Generate reference statistics.\n");

    my $start = time;
    my $refs = 0;
    my $f;
    my $curfnum = 0;

    foreach $f (@jsfiles) {
	++$fnum;
	++$curfnum;
	my $lcount = 0;
	my %tref = ();

	open(SRCFILE, $realpath.$f);
	$_ = $/; undef($/); my $contents = <SRCFILE>; $/ = $_;
	close(SRCFILE);

	print(STDERR
	      "(Pass 2 JS) $f (",length($contents),
              "), file $curfnum of ",$#jsfiles+1,"...\n");

	# Remove comments
	$contents =~ s/\/\*(.*?)\*\//&wash($1)/ges;
	$contents =~ s/\/\/[^\n]*//g;

        # Remove license blocks.
        $contents =~ s{(# \*\*\*\*\* BEGIN LICENSE BLOCK \*\*\*\*\*.*?# \*\*\*\*\* END LICENSE BLOCK \*\*\*\*\*)}{&wash($1)}ges;

	# FIXME: "var"

	my @lines = split(/\n/, $contents);
	my $line;

	foreach $line (@lines) {
	    $lcount++;
	    foreach ($line =~ /(?:^|[^a-zA-Z_\#])($ident)\b/og) {
		$tref{$_} .= "$lcount," if $xref{$_};
	    }
	}

	while (($a, $b) = each(%tref)) {
	    chop($b);
	    $xref{$a} .= "R$fnum:$b\t";
	    $refs++;
	}
    }
    $totalrefs = $totalrefs + $refs;
    print(STDERR
	  "Completed pass 2 (",(time-$start),"s):",
	  " $refs references to known identifiers found (total: $totalrefs).\n\n");
}

sub findusageIDL {
    print(STDERR "Starting pass 2 IDL: Generate reference statistics.\n");

    my $start = time;
    my $refs = 0;
    my $f;
    my $curfnum = 0;

    foreach $f (@idlfiles) {
        ++$fnum;
        ++$curfnum;
        my $lcount = 0;
        my %tref = ();

        open(SRCFILE, $realpath.$f);
        $_ = $/; undef($/); my $contents = <SRCFILE>; $/ = $_;
        close(SRCFILE);

        print(STDERR
              "(Pass 2 IDL) $f (",length($contents),
              "), file $curfnum of ",$#f+1,"...\n");
=ignore
        # Remove comments
        $contents =~ s/\/\*(.*?)\*\//&wash($1)/ges;
        $contents =~ s/\/\/[^\n]*//g;

        # Remove include statements
        $contents =~ s/^[ \t]*\#include[ \t]+[^\n]*//gm;

        # FIXME: "var"

        my @lines = split(/\n/, $contents);
        my $line;

        foreach $line (@lines) {
            $lcount++;
            foreach ($line =~ /(?:^|[^a-zA-Z_\#])($ident)\b/og) {
                $tref{$_} .= "$lcount," if $xref{$_};
            }
        }

        while (($a, $b) = each(%tref)) {
            chop($b);
            $xref{$a} .= "R$fnum:$b\t";
            $refs++;
        }
=cut
    }
    $totalrefs = $totalrefs + $refs;
    print(STDERR
          "Completed pass 2 IDL (",(time-$start),"s):",
          " $refs references to known identifiers found (total: $totalrefs).\n\n");
}

sub findusage {
    print(STDERR "Starting pass 2 C/C++: Generate reference statistics.\n");

    my $start = time;
    my $refs = 0;
    my $f;
    my $curfnum = 0;

    foreach $f (@f) {
        ++$fnum;
        ++$curfnum;
	my $lcount = 0;
	my %tref = ();

	open(SRCFILE, $realpath.$f);
	$_ = $/; undef($/); my $contents = <SRCFILE>; $/ = $_;
	close(SRCFILE);

	print(STDERR
	      "(Pass 2 C/C++) $f (",length($contents),
              "), file $curfnum of ",$#f+1,"...\n");

	# Remove comments
	$contents =~ s/\/\*(.*?)\*\//&wash($1)/ges;
	$contents =~ s/\/\/[^\n]*//g;

	# Remove include statements
	$contents =~ s/^[ \t]*\#include[ \t]+[^\n]*//gm;

	# FIXME: "var"

	my @lines = split(/\n/, $contents);
	my $line;

	foreach $line (@lines) {
	    $lcount++;
	    foreach ($line =~ /(?:^|[^a-zA-Z_\#])($ident)\b/og) {
		$tref{$_} .= "$lcount," if $xref{$_};
	    }
	}

	while (($a, $b) = each(%tref)) {
	    chop($b);
	    $xref{$a} .= "R$fnum:$b\t";
	    $refs++;
	}
    }
    $totalrefs = $totalrefs + $refs;
    print(STDERR
	  "Completed pass 2 C/C++ (",(time-$start),"s):",
	  " $refs references to known identifiers found (total: $totalrefs).\n\n");
}

sub dumpdb {
    print STDERR "Starting stage 3: Dump database to disk.\n";

    my $start = time;
    my %xrefdb;
    tie (%xrefdb, "DB_File" , "xref.out.$$", O_RDWR|O_CREAT, 0664, $DB_HASH)
        || die("Could not open \"xref\" for writing");

    my $i = 0;
    my $k;
    my $v;
    while (($k, $v) = each(%xref)) {
	$i++;
	delete($xref{$k});
	$xrefdb{$k} = $v;
	unless ($i % 100) {
	    print(STDERR "(Pass 3) identifier $i of maximum $totaldefs...\n");
	}
    }

    untie(%xrefdb);
    rename("xref.out.$$", "xref$suffix") || die "Couldn't rename xref.out.$$ to xref$suffix";
    print(STDERR
	  "Completed stage 3 (",(time-$start),"s):",
	  " Information on $i identifiers dumped to disk.\n\n");

    dbmclose(%fileidx);

    rename("fileidx.out.$$", "fileidx$suffix")
        || die "Couldn't rename fileidx.out.$$ to fileidx$suffix";
}

sub renumber {
    my ($line, $fadjust) = @_;
#                $xref{$3} .= "$2$fnum:$1\t";
    my @refs = split /\t/, $line;
    $line = '';
    foreach my $v (@refs) {
       $v =~ /(.)(\d+):(.*)/;
       my ($kind, $fileno, $lineno) = ($1, $fadjust + $2, $3);
       $line .= "$kind$fileno:$lineno\t";
    }
    return $line;
}

sub merge {
    print STDERR "Starting stage 4: Merging database to disk.\n";

    my $start = time;
    tie (%fileidx, "DB_File", "fileidx.out.$$", O_RDWR|O_CREAT, 0660, $DB_HASH)
        || die("Could not open \"fileidx.out.$$\" for writing");

    my %xrefdb;
    tie (%xrefdb, "DB_File" , "xref.out.$$", O_RDWR|O_CREAT, 0664, $DB_HASH)
        || die("Could not open \"xref\" for writing");

    my ($i, $k, $v);
    my $fadjust = 0;
    my $limit = scalar @extra;
    for (my $e = 0; $e < $limit; ++$e) {
        my $fix = $extra[$e];
        my ($prefix, $suffix) = ("$fix/", ".$fix");
        my %idx;
        tie (%idx, "DB_File", "fileidx$suffix", O_RDONLY, undef, $DB_HASH)
            || die("Could not open \"fileidx$suffix\" for reading");
        my $f = -1;
        while (($k, $v) = each(%idx)) {
            $f = $k if ($k > $f);
            $fileidx{$k + $fadjust} = "$prefix$v";
            unless ($i % 100) {
                print(STDERR "(Pass 4) file $i [$fix] of $e / $limit files...\n");
            }
        }
        untie (%idx);

        tie (%xref, "DB_File" , "xref$suffix", O_RDONLY, undef, $DB_HASH)
            || die("Could not open \"xref$suffix\" for reading");

        while (($k, $v) = each(%xref)) {
            $i++;
            $xrefdb{$k} .= renumber($v, $fadjust);
            unless ($i % 100) {
                print(STDERR "(Pass 4) identifier $i [$fix] of $e / $limit files...\n");
            }
        }
        untie (%xref);
        $fadjust += $f + 1;
    }
    untie(%xrefdb);
    rename("xref.out.$$", "xref") || die "Couldn't rename xref.out.$$ to xref";
    print(STDERR
          "Completed stage 4 (",(time-$start),"s):",
          "Information on $i identifiers dumped to disk.\n\n");
    untie(%fileidx);
    rename("fileidx.out.$$", "fileidx")
        || die "Couldn't rename fileidx.out.$$ to fileidx";
    foreach my $fix (@extra) {
        my ($suffix) = (".$fix");
    }
}

sub buildList {
    my ($fspre, $fspost) = ('', '');
    if ($suffix ne '') {
        $fspost = "! -type l ! -path '*/.git/*' ! -path '*/.hg/*' ! -path '*/.svn/*' ! -path '*/CVS/*'";
    } else {
        $fspre = '-L';
    }
    open(FILES, "find $fspre $realpath $fspost -type f -print |");
    print(STDERR "Starting pass 0: Checking for files to index.\n",
                 "Looking in $realpath.\n");

    while (my $file = <FILES>) {
        $file =~ s/^\Q$realpath\E|\s+$//og;
        #   Duplicated in lib/LXR/Common.pm
       if ($file =~ /\.(?:(hh?|cpp?|c[cs]?|fin|tbl|ipdlh?)|(java)|(jsm?)(?:\.in|)|(p[lm]|cgi)(?:\.in|)|(idl)|(xml))$/i) {
           if ($1) {
               push @ft, 0;
               push @f, $file;
           } elsif ($2) {
               push @ft, 1;
               push @f, $file;
           } elsif ($3) {
               if (($file =~ m!/Regress/!) || ($file =~ m!kraken/tests/kraken!)) {
                   print(STDERR "Skipping $file\n");
               } else {
                   push @jsfiles, $file;
               }
           } elsif ($4) {
               push @plfiles, $file;
           } elsif ($5) {
               push @idlfiles, $file;
           } elsif ($6) {
               push @xblfiles, $file;
           }
        }
    }
    close FILES;
}

# Stage 0: build file list
# Stage 1: find identifiers
# - this is pass 1 over the file content
# Stage 2: find references
# - this is pass 2 over the file content
# Stage 3: dump the database
# - we run from 0..3 for a "default" action
# Stage 4: merge databases
# - we only do this stage for a "merge" action
sub buildIndex {
    tie (%fileidx, "DB_File", "fileidx.out.$$", O_RDWR|O_CREAT, 0660, $DB_HASH)
        || die("Could not open \"fileidx.out.$$\" for writing");

    buildList();
    print 'Stage 0 IDL file count is : ' . scalar(@idlfiles) . '
Stage 0 C/C++ file count is : ' . scalar(@f) . '
Stage 0 JS file count is : ' . scalar(@jsfiles) . '
Stage 0 PL file count is : ' . scalar(@plfiles) . '
';

    $fnum = 0;

    # we need to search for IDL identifiers first because they can be
    # the only prototype
    # XXX i'm not certain this is necessary, oh well.
    &findidentIDL;
    print "Stage 1 IDL XREF keycount is : " . scalar(keys %xref) . "\n";
    &findident;
    print "Stage 1 C/C++ XREF keycount is : " . scalar(keys %xref) . "\n";
    &findidentJS;
    print "Stage 1 C/C++/JS XREF keycount is : " . scalar(keys %xref) . "\n";
    &findidentPL;
    print "Stage 1 C/C++/JS/PL XREF keycount is : " . scalar(keys %xref) . "\n";
    &findidentXBL;
    print "Stage 1 C/C++/JS/PL/XBL XREF keycount is : " . scalar(keys %xref) . "\n";

    $fnum = 0;

    &findusageIDL;
    print "Stage 2 IDL XREF keycount is : " . scalar(keys %xref) . "\n";
    &findusage;
    print "Stage 2 C/C++ XREF keycount is : " . scalar(keys %xref) . "\n";
    &findusageJS;
    print "Stage 2 C/C++/JS XREF keycount is : " . scalar(keys %xref) . "\n";
    &findusagePL;
    print "Stage 2 C/C++/JS/PL keycount is : " . scalar(keys %xref) . "\n";

    &dumpdb;
}

for ($verb) {
    /^default$/ && do {
        # Build database for directory.
        # Files are parsed using whole file regexp's.
        # This is SLOW.
        buildIndex();
        last;
    };
    /^merge$/ && do {
        # Merge databases
        unshift @extra, $fix;
        merge();
        last;
    };
}