Замена ctags для Perl в mooedit - http://habrahabr.ru/post/208754/

perltags.pl

#!/usr/bin/perl

# ------------------------------------------------------------------------------
use 5.010;
use strict;
use PPI;

my %variables;
my %scheduled;
my %subs;

# ------------------------------------------------------------------------------
die "Usage: $0 file\n" unless $ARGV[0];
my $doc    = PPI::Document->new( $ARGV[0] );
die "'$ARGV[0]', PPI::Document error!\n" unless $doc;

# ------------------------------------------------------------------------------
my @tokens = $doc->children;
foreach my $token ( @tokens )
{
    given ( $token->class )
    {
        process_statement( $token ) when 'PPI::Statement';
        process_variable( $token ) when 'PPI::Statement::Variable';
        process_sub( $token ) when 'PPI::Statement::Sub';
        process_scheduled( $token ) when 'PPI::Statement::Scheduled';
    }
}

print_names( \%variables, 'v' );
print_names( \%subs,      'f' );
print_names( \%scheduled, 'p' );

# ------------------------------------------------------------------------------
sub add_name
{
    my ( $list, $token, $content ) = @_;
    # $content здесь на всякий случай, мало ли захочется где-то, потом,  получить полную строку
    my $name = $token->content;
    $list->{$name} = () unless exists $list->{$name};
    $list->{$name}->{ $token->line_number } = $content;
}

# ------------------------------------------------------------------------------
sub print_names
{
    my ( $list, $type ) = @_;

    foreach my $name (
        sort {
            my $an = $a =~ /^[\$\%\@](.+)$/ ? $1 : $a;
            my $bn = $b =~ /^[\$\%\@](.+)$/ ? $1 : $b;
            lc $an cmp lc $bn;
        } keys $list )
    {
        foreach my $line ( sort { $a <=> $b } keys $list->{$name} )
        {
            print "$name:$line\t$ARGV[0]\t$line;\"\t$type\n";
        }
    }
}

# ------------------------------------------------------------------------------
# @EXPORT = qw(aaa), @EXPORT_OK = qw(bbb);
# ------------------------------------------------------------------------------
sub process_statement
{
    my ( $tok ) = @_;

    my @tokens = $tok->children;
    return unless $#tokens > 0;
    foreach my $token ( @tokens )
    {
        add_name( \%variables, $token, $tok->content )
          if $token->class eq 'PPI::Token::Symbol';
    }
}

# ------------------------------------------------------------------------------
# sub aaa($$$);
# sub aaa{};
# ------------------------------------------------------------------------------
sub process_sub
{
    my ( $tok ) = @_;

    my @tokens = $tok->children;
    return unless $#tokens > 1;
    shift @tokens;
    foreach my $token ( @tokens )
    {
        next
          if $token->class eq 'PPI::Token::Whitespace'
          or $token->class eq 'PPI::Token::Comment'
          or $token->class eq 'PPI::Token::Pod';
        # первый значащий токен после 'sub' должен быть PPI::Token::Word:
        return unless $token->class eq 'PPI::Token::Word';
        add_name( \%subs, $token, $tok->content );
        last;
    }
}

# ------------------------------------------------------------------------------
# my $aaa;
# our ($aaa, $bbb);
# ------------------------------------------------------------------------------
sub process_variable
{
    my ( $tok ) = @_;

    my @tokens = $tok->children;
    foreach my $token ( @tokens )
    {
        # список или выражение - ищем имена рекурсивно:
        process_variable( $token ), next if $token->class eq 'PPI::Structure::List';
        process_variable( $token ), next if $token->class eq 'PPI::Statement::Expression';
        add_name( \%variables, $token, $tok->content )
          if $token->class eq 'PPI::Token::Symbol';
    }
}

# ------------------------------------------------------------------------------
# BEGIN {}; CHECK, UNITCHECK, INIT, END
# ------------------------------------------------------------------------------
sub process_scheduled
{
    my ( $tok ) = @_;

    my @tokens = $tok->children;
    return unless $#tokens > 0;
    add_name( \%scheduled, $tokens[0], $tok->content );
}

# ------------------------------------------------------------------------------