Ticket #1209: Outline.pm

File Outline.pm, 6.0 KB (added by bowtie, 3 years ago)

suggested upgrade to Outline.pm

Line 
1package PPIx::EditorTools::Outline;
2
3# ABSTRACT: Collect use pragmata, modules, subroutiones, methods, attributes
4
5use 5.008;
6use strict;
7use warnings;
8use Carp;
9
10use base 'PPIx::EditorTools';
11use Class::XSAccessor accessors => {};
12
13use PPI;
14
15#our $VERSION = '0.14';
16use version; our $VERSION = version->new('0.14.0');
17
18=pod
19
20=head1 SYNOPSIS
21
22  my $outline = PPIx::EditorTools::Outline->new->find(
23        code => "package TestPackage;\nsub x { 1;\n"
24      );
25 print Dumper $outline;
26
27=head1 DESCRIPTION
28
29Return a list of pragmatas, modules, methods, attributes of a C<PPI::Document>.
30
31=head1 METHODS
32
33=over 4
34
35=item new()
36
37Constructor. Generally shouldn't be called with any arguments.
38
39=item find( ppi => PPI::Document $ppi )
40=item find( code => Str $code )
41
42Accepts either a C<PPI::Document> to process or a string containing
43the code (which will be converted into a C<PPI::Document>) to process.
44Return a reference to a hash.
45
46=back
47
48=cut
49
50sub find {
51    my ( $self, %args ) = @_;
52    $self->process_doc(%args);
53
54    my $ppi = $self->ppi;
55
56    return [] unless defined $ppi;
57    $ppi->index_locations;
58
59    # Search for interesting things
60    require PPI::Find;
61    # TODO things not very discriptive
62    my @things = PPI::Find->new(
63        sub {
64
65            # This is a fairly ugly search
66            return 1 if ref $_[0] eq 'PPI::Statement::Package';
67            return 1 if ref $_[0] eq 'PPI::Statement::Include';
68            return 1 if ref $_[0] eq 'PPI::Statement::Sub';
69            return 1 if ref $_[0] eq 'PPI::Statement';
70        }
71    )->in($ppi);
72
73# Define a flag indicating that further Method::Signature/Moose check should run
74    my $check_alternate_sub_decls = 0;
75
76    # Build the outline structure from the search results
77    my @outline       = ();
78    my $cur_pkg       = {};
79    my $not_first_one = 0;
80    foreach my $thing (@things) {
81        if ( ref $thing eq 'PPI::Statement::Package' ) {
82            if ($not_first_one) {
83                if ( not $cur_pkg->{name} ) {
84                    $cur_pkg->{name} = 'main';
85                }
86                push @outline, $cur_pkg;
87                $cur_pkg = {};
88            }
89            $not_first_one   = 1;
90            $cur_pkg->{name} = $thing->namespace;
91            $cur_pkg->{line} = $thing->location->[0];
92        }
93        elsif ( ref $thing eq 'PPI::Statement::Include' ) {
94            next if $thing->type eq 'no';
95            if ( $thing->pragma ) {
96                push @{ $cur_pkg->{pragmata} },
97                    { name => $thing->pragma, line => $thing->location->[0] };
98            }
99            elsif ( $thing->module ) {
100                push @{ $cur_pkg->{modules} },
101                    { name => $thing->module, line => $thing->location->[0] };
102                unless ($check_alternate_sub_decls) {
103                    $check_alternate_sub_decls = 1
104                        if grep { $thing->module eq $_ } (
105                                      'Method::Signatures',
106                                      'MooseX::Declare',
107                                      'MooseX::Method::Signatures' );
108                }
109            }
110        }
111        elsif ( ref $thing eq 'PPI::Statement::Sub' ) {
112            push @{ $cur_pkg->{methods} },
113                { name => $thing->name, line => $thing->location->[0] };
114        }
115        elsif ( ref $thing eq 'PPI::Statement' ) {
116
117            # last resort, let's analyse further down...
118            my $node1 = $thing->first_element;
119            my $node2 = $thing->child(2);
120            next unless defined $node2;
121
122            # Moose attribute declaration
123            if ( $node1->isa('PPI::Token::Word') && $node1->content eq 'has' )
124            {
125                $self->_Moo_Attributes( $node2, $cur_pkg, $thing );
126                next;
127            }
128
129            # MooseX::POE event declaration
130            if (    $node1->isa('PPI::Token::Word')
131                 && $node1->content eq 'event' )
132            {
133                push @{ $cur_pkg->{events} },
134                    { name => $node2->content,
135                      line => $thing->location->[0]
136                    };
137                next;
138            }
139        }
140    }
141
142    if ($check_alternate_sub_decls) {
143        $ppi->find(
144            sub {
145                $_[1]->isa('PPI::Token::Word') or return 0;
146                $_[1]->content
147                    =~ /^(?:func|method|before|after|around|override|augment|class|role)\z/
148                    or return 0;
149                $_[1]->next_sibling->isa('PPI::Token::Whitespace')
150                    or return 0;
151                my $sib_content = $_[1]->next_sibling->next_sibling->content
152                    or return 0;
153
154                $sib_content =~ m/^\b(\w+)\b/;
155                return 0 unless defined $1;
156
157                # test for MooseX::Declare class, role
158                if ( $_[1]->content =~ m/(class|role)/ ) {
159                    $self->_Moo_PkgName( $cur_pkg, $sib_content, $_[1]);
160                    return 1; # break out so we don't write Packae name as method
161                }
162
163                push @{ $cur_pkg->{methods} },
164                    { name => $1, line => $_[1]->line_number };
165
166                return 1;
167            }
168        );
169    }
170
171    if ( not $cur_pkg->{name} ) {
172        $cur_pkg->{name} = 'main';
173    }
174
175    push @outline, $cur_pkg;
176
177    return \@outline;
178}
179
180########
181# Composed Method, internal, Moose Attributes
182# cleans moose attributes up, and single lines them.
183# only runs if PPI finds has
184# prefix all vars with ma_ otherwise same name
185########
186sub _Moo_Attributes {
187    my ( $self, $ma_node2, $ma_cur_pkg, $ma_thing, @args ) = @_;
188
189    # tidy up Moose attributes for Outline display
190    my $ma_has_att = $ma_node2->content;
191    my $space      = q{ };
192    $ma_has_att =~ s/^\[?(qw(\/|\())?$space?//;  # remove leading 'quote word'
193    $ma_has_att =~ s/(\/|\))?\]?$//;             # remove traling 'quote word'
194    $ma_has_att =~ s/(\'$space?)//g;    # remove Single-Quoted String Literals
195    $ma_has_att =~ s/($space?\,$space?)/$space/g;   # remove commers add space
196    # split mulitline attributes to one per line
197    my @ma_atts_found = split /$space/, $ma_has_att,;
198
199    foreach my $ma_att (@ma_atts_found) {
200
201        # add to outline
202        push @{ $ma_cur_pkg->{attributes} },
203            { name => $ma_att, line => $ma_thing->location->[0] };
204    }
205    return;
206}
207
208########
209# Composed Method, internal, Moose Pakage Name
210# write first Class or Role as Package Name if none
211# prefix all vars with mpn_ otherwise same name
212########
213sub _Moo_PkgName {
214    my ( $self, $mpn_cur_pkg, $mpn_sib_content, $mpn_ppi_tuple, @args ) = @_;
215    if ( $mpn_cur_pkg->{name} ) { return 1; } # break if we have a pkg name
216    # add to outline
217    $mpn_cur_pkg->{name} = $mpn_sib_content; # class or role name
218    $mpn_cur_pkg->{line} = $mpn_ppi_tuple->line_number; # class or role location
219    return 1;
220}
221
2221;
223
224__END__
225
226=head1 SEE ALSO
227
228This class inherits from C<PPIx::EditorTools>.
229Also see L<App::EditorTools>, L<Padre>, and L<PPI>.
230
231=cut
232
233# Copyright 2008-2011 The Padre development team as listed in Padre.pm.
234# LICENSE
235# This program is free software; you can redistribute it and/or
236# modify it under the same terms as Perl 5 itself.
237