#!/usr/bin/env perl

# pltags - create a tags file for Perl code, for use by vi(m)
#
# Distributed with Vim <http://www.vim.org/>, latest version always available
# at <http://www.mscha.com/mscha.html?pltags#tools>
#
# Version 2.3, 28 February 2002
#
# Written by Michael Schaap <pltags@mscha.com>.  Suggestions for improvement
# are very welcome!
#
# This script will not work with Perl 4 or below!
#
# Revision history:
#  1.0  1997?     Original version, quickly hacked together
#  2.0  1999?     Completely rewritten, better structured and documented,
#		  support for variables, packages, Exuberant Ctags extensions
#  2.1	Jun 2000  Fixed critical bug (typo in comment) ;-)
#		  Support multiple level packages (e.g. Archive::Zip::Member)
#  2.2	Jul 2001  'Glob' wildcards - especially useful under Windows
#		  (thanks to Serge Sivkov and Jason King)
#		  Bug fix: reset package name for each file
#  2.21 Jul 2001  Oops... bug in variable detection (/local../ -> /^local.../)
#  2.3	Feb 2002  Support variables declared with "our"
#		  (thanks to Lutz Mende)

# Complain about undeclared variables
use strict;

# Used modules
use Getopt::Long;

# Options with their defaults
my $do_subs = 1;    # --subs, --nosubs    include subs in tags file?
my $do_vars = 1;    # --vars, --novars    include variables in tags file?
my $do_pkgs = 1;    # --pkgs, --nopkgs    include packages in tags file?
my $do_exts = 1;    # --extensions, --noextensions
		    #			  include Exuberant Ctags extensions

# Global variables
my $VERSION = "2.21";	# pltags version
my $status = 0;		# GetOptions return value
my $file = "";		# File being processed
my @tags = ();		# List of produced tags
my $is_pkg = 0;		# Are we tagging a package?
my $has_subs = 0;	# Has this file any subs yet?
my $package_name = "";	# Name of current package
my $var_continues = 0;	# Variable declaration continues on last line
my $line = "";		# Current line in file
my $stmt = "";		# Current Perl statement
my @vars = ();		# List of variables in declaration
my $var = "";		# Variable in declaration
my $tagline = "";	# Tag file line

# Create a tag file line and push it on the list of found tags
sub MakeTag($$$$$)
{
    my ($tag,		# Tag name
	$type,		# Type of tag
	$is_static,	# Is this a static tag?
	$file,		# File in which tag appears
	$line) = @_;	# Line in which tag appears

    my $tagline = "";   # Created tag line

    # Only process tag if not empty
    if ($tag)
    {
	# Get rid of \n, and escape / and \ in line
	chomp $line;
	$line =~ s/\\/\\\\/g;
	$line =~ s/\//\\\//g;

	# Create a tag line
	$tagline = "$tag\t$file\t/^$line\$/";

	# If we're told to do so, add extensions
	if ($do_exts)
	{
	    $tagline .= ";\"\t$type"
			    . ($is_static ? "\tfile:" : "")
			    . ($package_name ? "\tclass:$package_name" : "");
	}

	# Push it on the stack
	push (@tags, $tagline);
    }
}

# Parse package name from statement
sub PackageName($)
{
    my ($stmt) = @_;    # Statement

    # Look for the argument to "package".  Return it if found, else return ""
    if ($stmt =~ /^package\s+([\w:]+)/)
    {
	my $pkgname = $1;

	# Remove any parent package name(s)
	$pkgname =~ s/.*://;
	return $pkgname;
    }
    else
    {
	return "";
    }
}

# Parse sub name from statement
sub SubName($)
{
    my ($stmt) = @_;    # Statement

    # Look for the argument to "sub".  Return it if found, else return ""
    if ($stmt =~ /^sub\s+([\w:]+)/)
    {
	my $subname = $1;

	# Remove any parent package name(s)
	$subname =~ s/.*://;
	return $subname;
    }
    else
    {
	return "";
    }
}

# Parse all variable names from statement
sub VarNames($)
{
    my ($stmt) = @_;

    # Remove my or local from statement, if present
    $stmt =~ s/^(my|our|local)\s+//;

    # Remove any assignment piece
    $stmt =~ s/\s*=.*//;

    # Now find all variable names, i.e. "words" preceded by $, @ or %
    @vars = ($stmt =~ /[\$\@\%]([\w:]+)\b/g);

    # Remove any parent package name(s)
    map(s/.*://, @vars);

    return (@vars);
}

############### Start ###############

print "\npltags $VERSION by Michael Schaap <mscha\@mscha.com>\n\n";

# Get options
$status = GetOptions("subs!" => \$do_subs,
		     "vars!" => \$do_vars,
		     "pkgs!" => \$do_pkgs,
		     "extensions!" => \$do_exts);

# Usage if error in options or no arguments given
unless ($status && @ARGV)
{
    print "\n" unless ($status);
    print "  Usage: $0 [options] filename ...\n\n";
    print "  Where options can be:\n";
    print "    --subs (--nosubs)     (don't) include sub declarations in tag file\n";
    print "    --vars (--novars)     (don't) include variable declarations in tag file\n";
    print "    --pkgs (--nopkgs)     (don't) include package declarations in tag file\n";
    print "    --extensions (--noextensions)\n";
    print "                          (don't) include Exuberant Ctags / Vim style\n";
    print "                          extensions in tag file\n\n";
    print "  Default options: ";
    print ($do_subs ? "--subs " : "--nosubs ");
    print ($do_vars ? "--vars " : "--novars ");
    print ($do_pkgs ? "--pkgs " : "--nopkgs ");
    print ($do_exts ? "--extensions\n\n" : "--noextensions\n\n");
    print "  Example: $0 *.pl *.pm ../shared/*.pm\n\n";
    exit;
}

# Loop through files on command line - 'glob' any wildcards, since Windows
# doesn't do this for us
foreach $file (map { glob } @ARGV)
{
    # Skip if this is not a file we can open.  Also skip tags files and backup
    # files
    next unless ((-f $file) && (-r $file) && ($file !~ /tags$/)
		 && ($file !~ /~$/));

    print "Tagging file $file...\n";

    $is_pkg = 0;
    $package_name = "";
    $has_subs = 0;
    $var_continues = 0;

    open (IN, $file) or die "Can't open file '$file': $!";

    # Loop through file
    foreach $line (<IN>)
    {
	# Statement is line with comments and whitespace trimmed
	($stmt = $line) =~ s/#.*//;
	$stmt =~ s/^\s*//;
	$stmt =~ s/\s*$//;

	# Nothing left? Never mind.
	next unless ($stmt);

	# This is a variable declaration if one was started on the previous
	# line, or if this line starts with my or local
	if ($var_continues or ($stmt =~/^my\b/)
			    or ($stmt =~/^our\b/) or ($stmt =~/^local\b/))
	{
	    # The declaration continues if the line does not end with ;
	    $var_continues = ($stmt !~ /;$/);

	    # Loop through all variable names in the declaration
	    foreach $var (VarNames($stmt))
	    {
		# Make a tag for this variable unless we're told not to.  We
		# assume that a variable is always static, unless it appears
		# in a package before any sub.	(Not necessarily true, but
		# it's ok for most purposes and Vim works fine even if it is
		# incorrect)
		if ($do_vars)
		{
		    MakeTag($var, "v", (!$is_pkg or $has_subs), $file, $line);
		}
	    }
	}

	# This is a package declaration if the line starts with package
	elsif ($stmt =~/^package\b/)
	{
	    # Get name of the package
	    $package_name = PackageName($stmt);

	    if ($package_name)
	    {
		# Remember that we're doing a package
		$is_pkg = 1;

		# Make a tag for this package unless we're told not to.  A
		# package is never static.
		if ($do_pkgs)
		{
		    MakeTag($package_name, "p", 0, $file, $line);
		}
	    }
	}

	# This is a sub declaration if the line starts with sub
	elsif ($stmt =~/^sub\b/)
	{
	    # Remember that this file has subs
	    $has_subs = 1;

	    # Make a tag for this sub unless we're told not to.  We assume
	    # that a sub is static, unless it appears in a package.  (Not
	    # necessarily true, but it's ok for most purposes and Vim works
	    # fine even if it is incorrect)
	    if ($do_subs)
	    {
		MakeTag(SubName($stmt), "s", (!$is_pkg), $file, $line);
	    }
	}
    }
    close (IN);
}

# Do we have any tags?  If so, write them to the tags file
if (@tags)
{
    # Add some tag file extensions if we're told to
    if ($do_exts)
    {
	push (@tags, "!_TAG_FILE_FORMAT\t2\t/extended format/");
	push (@tags, "!_TAG_FILE_SORTED\t1\t/0=unsorted, 1=sorted/");
	push (@tags, "!_TAG_PROGRAM_AUTHOR\tMichael Schaap\t/mscha\@mscha.com/");
	push (@tags, "!_TAG_PROGRAM_NAME\tpltags\t//");
	push (@tags, "!_TAG_PROGRAM_VERSION\t$VERSION\t/supports multiple tags and extended format/");
    }

    print "\nWriting tags file.\n";

    open (OUT, ">tags") or die "Can't open tags file: $!";

    foreach $tagline (sort @tags)
    {
	print OUT "$tagline\n";
    }

    close (OUT);
}
else
{
    print "\nNo tags found.\n";
}