01 #!/usr/local/bin/perl -w
02 ###########################################
03 # ptags - A PPI-based ctags for Perl
04 # Mike Schilli, 2005 (m@perlmeister.com)
05 ###########################################
06 use strict;
07 
08 use PPI::Document;
09 use File::Find;
10 use Sysadm::Install qw(:all);
11 use Log::Log4perl qw(:easy);
12 
13 my $outfile = "$ENV{HOME}/.ptags.txt";
14 my %dirs  = ();
15 my @found = ();
16 
17 find \&file_wanted, grep {$_ ne "."} @INC;
18 
19 blurt join("\n", sort @found), $outfile;
20 
21 ###########################################
22 sub file_wanted {
23 ###########################################
24     my $abs = $File::Find::name;
25 
26         # Avoid dupe dirs
27     $File::Find::prune = 1 if -d and 
28         $dirs{$abs}++;
29 
30         # Only Perl modules
31     return unless /\.pm$/;
32 
33     my $d = PPI::Document->load($abs);
34 
35     unless($d) {
36         WARN "Cannot load $abs ($! $@)";
37         return;
38     }
39         # Find packages and 
40         # all named subroutines
41     $d->find(\&document_wanted);
42 }
43 
44 ###########################################
45 sub document_wanted {
46 ###########################################
47     our $package;
48     my  $tag;
49 
50     if(ref($_[1]) eq 
51            'PPI::Statement::Package') {
52         $tag = $_[1]->child(2)->content();
53         $package = $tag;
54 
55     } elsif(ref($_[1]) eq 
56             'PPI::Statement::Sub' and 
57             $_[1]->name()) {
58         $tag = "$package\::" . 
59                $_[1]->name();
60     }
61 
62     return 1 unless defined $tag;
63 
64     push @found, $tag . "\t" . 
65                  $File::Find::name . "\t" .
66                  regex_from_node($_[1]);
67 
68     return 1;
69 }
70 
71 ###########################################
72 sub regex_from_node {
73 ###########################################
74     my($node) = @_;
75 
76     my $regex = $node->content();
77    
78     $regex =~ s/\n.*//gs;
79 
80     while(my $prev = 
81              $node->previous_sibling()) {
82         last if $prev =~ /\n/;
83         $regex = $prev->content() . 
84                  $regex;
85         $node  = $prev;
86     }
87 
88     $regex =~ s#[/.*[\]^\$]#\\$&#g;
89     return "/^$regex/";
90 }