Mededit में पर्ल के लिए ctags की जगह

 #!/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 ); } # ------------------------------------------------------------------------------