| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package Perl::ToPerl6::Document; | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 1 |  |  | 1 |  | 19 | use 5.006001; | 
|  | 1 |  |  |  |  | 3 |  | 
| 4 | 1 |  |  | 1 |  | 5 | use strict; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 20 |  | 
| 5 | 1 |  |  | 1 |  | 5 | use warnings; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 30 |  | 
| 6 |  |  |  |  |  |  |  | 
| 7 | 1 |  |  | 1 |  | 5 | use Carp qw< confess >; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 49 |  | 
| 8 |  |  |  |  |  |  |  | 
| 9 | 1 |  |  | 1 |  | 11 | use List::Util qw< reduce >; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 59 |  | 
| 10 | 1 |  |  | 1 |  | 6 | use Scalar::Util qw< blessed refaddr weaken >; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 51 |  | 
| 11 | 1 |  |  | 1 |  | 782 | use version; | 
|  | 1 |  |  |  |  | 1857 |  | 
|  | 1 |  |  |  |  | 6 |  | 
| 12 |  |  |  |  |  |  |  | 
| 13 | 1 |  |  | 1 |  | 63 | use PPI::Document; | 
|  | 1 |  |  |  |  | 3 |  | 
|  | 1 |  |  |  |  | 31 |  | 
| 14 | 1 |  |  | 1 |  | 5 | use PPI::Document::File; | 
|  | 1 |  |  |  |  | 4 |  | 
|  | 1 |  |  |  |  | 29 |  | 
| 15 | 1 |  |  | 1 |  | 772 | use PPIx::Utilities::Node qw< split_ppi_node_by_namespace >; | 
|  | 1 |  |  |  |  | 2197 |  | 
|  | 1 |  |  |  |  | 468 |  | 
| 16 |  |  |  |  |  |  |  | 
| 17 | 1 |  |  | 1 |  | 601 | use Perl::ToPerl6::Annotation; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 31 |  | 
| 18 | 1 |  |  | 1 |  | 498 | use Perl::ToPerl6::Exception::Parse qw< throw_parse >; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 18 |  | 
| 19 | 1 |  |  | 1 |  | 51 | use Perl::ToPerl6::Utils qw< :booleans :characters shebang_line >; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 45 |  | 
| 20 |  |  |  |  |  |  |  | 
| 21 | 1 |  |  | 1 |  | 1043 | use PPIx::Regexp 0.010 qw< >; | 
|  | 1 |  |  |  |  | 93223 |  | 
|  | 1 |  |  |  |  | 1965 |  | 
| 22 |  |  |  |  |  |  |  | 
| 23 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 24 |  |  |  |  |  |  |  | 
| 25 |  |  |  |  |  |  | our $AUTOLOAD; | 
| 26 |  |  |  |  |  |  | sub AUTOLOAD { | 
| 27 | 0 |  |  | 0 |  |  | my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms; | 
| 28 | 0 | 0 |  |  |  |  | return if $function_name eq 'DESTROY'; | 
| 29 | 0 |  |  |  |  |  | my $self = shift; | 
| 30 | 0 |  |  |  |  |  | return $self->{_doc}->$function_name(@_); | 
| 31 |  |  |  |  |  |  | } | 
| 32 |  |  |  |  |  |  |  | 
| 33 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 34 |  |  |  |  |  |  |  | 
| 35 |  |  |  |  |  |  | sub new { | 
| 36 | 0 |  |  | 0 | 1 |  | my ($class, @args) = @_; | 
| 37 |  |  |  |  |  |  |  | 
| 38 | 0 |  |  |  |  |  | my $self = bless {}, $class; | 
| 39 |  |  |  |  |  |  |  | 
| 40 | 0 |  |  |  |  |  | $self->_init_common(); | 
| 41 | 0 |  |  |  |  |  | $self->_init_from_external_source(@args); | 
| 42 |  |  |  |  |  |  |  | 
| 43 | 0 |  |  |  |  |  | return $self; | 
| 44 |  |  |  |  |  |  | } | 
| 45 |  |  |  |  |  |  |  | 
| 46 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 47 |  |  |  |  |  |  |  | 
| 48 |  |  |  |  |  |  | sub _new_for_parent_document { | 
| 49 | 0 |  |  | 0 |  |  | my ($class, $ppi_document, $parent_document) = @_; | 
| 50 |  |  |  |  |  |  |  | 
| 51 | 0 |  |  |  |  |  | my $self = bless {}, $class; | 
| 52 |  |  |  |  |  |  |  | 
| 53 | 0 |  |  |  |  |  | $self->_init_common(); | 
| 54 |  |  |  |  |  |  |  | 
| 55 | 0 |  |  |  |  |  | $self->{_doc}       = $ppi_document; | 
| 56 | 0 |  |  |  |  |  | $self->{_is_module} = $parent_document->is_module(); | 
| 57 |  |  |  |  |  |  |  | 
| 58 | 0 |  |  |  |  |  | return $self; | 
| 59 |  |  |  |  |  |  | } | 
| 60 |  |  |  |  |  |  |  | 
| 61 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 62 |  |  |  |  |  |  |  | 
| 63 |  |  |  |  |  |  | sub _init_common { | 
| 64 | 0 |  |  | 0 |  |  | my ($self) = @_; | 
| 65 |  |  |  |  |  |  |  | 
| 66 | 0 |  |  |  |  |  | $self->{_annotations} = []; | 
| 67 | 0 |  |  |  |  |  | $self->{_suppressed_transformations} = []; | 
| 68 | 0 |  |  |  |  |  | $self->{_disabled_line_map} = {}; | 
| 69 |  |  |  |  |  |  |  | 
| 70 | 0 |  |  |  |  |  | return; | 
| 71 |  |  |  |  |  |  | } | 
| 72 |  |  |  |  |  |  |  | 
| 73 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 74 |  |  |  |  |  |  |  | 
| 75 |  |  |  |  |  |  | sub _init_from_external_source { | 
| 76 | 0 |  |  | 0 |  |  | my $self = shift; | 
| 77 | 0 |  |  |  |  |  | my %args; | 
| 78 |  |  |  |  |  |  |  | 
| 79 | 0 | 0 |  |  |  |  | if (@_ == 1) { | 
| 80 | 0 |  |  |  |  |  | warnings::warnif( | 
| 81 |  |  |  |  |  |  | 'deprecated', | 
| 82 |  |  |  |  |  |  | 'Perl::ToPerl6::Document->new($source) deprecated, use Perl::ToPerl6::Document->new(-source => $source) instead.' | 
| 83 |  |  |  |  |  |  | ); | 
| 84 | 0 |  |  |  |  |  | %args = ('-source' => shift); | 
| 85 |  |  |  |  |  |  | } else { | 
| 86 | 0 |  |  |  |  |  | %args = @_; | 
| 87 |  |  |  |  |  |  | } | 
| 88 |  |  |  |  |  |  |  | 
| 89 | 0 |  |  |  |  |  | my $source_code = $args{'-source'}; | 
| 90 |  |  |  |  |  |  |  | 
| 91 |  |  |  |  |  |  | # $source_code can be a file name, or a reference to a | 
| 92 |  |  |  |  |  |  | # PPI::Document, or a reference to a scalar containing source | 
| 93 |  |  |  |  |  |  | # code.  In the last case, PPI handles the translation for us. | 
| 94 |  |  |  |  |  |  |  | 
| 95 | 0 | 0 |  |  |  |  | my $ppi_document = | 
|  |  | 0 |  |  |  |  |  | 
| 96 |  |  |  |  |  |  | _is_ppi_doc($source_code) | 
| 97 |  |  |  |  |  |  | ? $source_code | 
| 98 |  |  |  |  |  |  | : ref $source_code | 
| 99 |  |  |  |  |  |  | ? PPI::Document->new($source_code) | 
| 100 |  |  |  |  |  |  | : PPI::Document::File->new($source_code); | 
| 101 |  |  |  |  |  |  |  | 
| 102 |  |  |  |  |  |  | # Bail on error | 
| 103 | 0 | 0 |  |  |  |  | if (not defined $ppi_document) { | 
| 104 | 0 |  |  |  |  |  | my $errstr   = PPI::Document::errstr(); | 
| 105 | 0 | 0 |  |  |  |  | my $file     = ref $source_code ? undef : $source_code; | 
| 106 | 0 |  |  |  |  |  | throw_parse | 
| 107 |  |  |  |  |  |  | message     => qq<Can't parse code: $errstr>, | 
| 108 |  |  |  |  |  |  | file_name   => $file; | 
| 109 |  |  |  |  |  |  | } | 
| 110 |  |  |  |  |  |  |  | 
| 111 | 0 |  |  |  |  |  | $self->{_doc} = $ppi_document; | 
| 112 | 0 |  |  |  |  |  | $self->index_locations(); | 
| 113 | 0 |  |  |  |  |  | $self->_disable_shebang_fix(); | 
| 114 | 0 |  |  |  |  |  | $self->{_filename_override} = $args{'-filename-override'}; | 
| 115 | 0 |  |  |  |  |  | $self->{_is_module} = $self->_determine_is_module(\%args); | 
| 116 |  |  |  |  |  |  |  | 
| 117 | 0 |  |  |  |  |  | return; | 
| 118 |  |  |  |  |  |  | } | 
| 119 |  |  |  |  |  |  |  | 
| 120 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 121 |  |  |  |  |  |  |  | 
| 122 |  |  |  |  |  |  | sub _is_ppi_doc { | 
| 123 | 0 |  |  | 0 |  |  | my ($ref) = @_; | 
| 124 | 0 |  | 0 |  |  |  | return blessed($ref) && $ref->isa('PPI::Document'); | 
| 125 |  |  |  |  |  |  | } | 
| 126 |  |  |  |  |  |  |  | 
| 127 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 128 |  |  |  |  |  |  |  | 
| 129 |  |  |  |  |  |  | sub ppi_document { | 
| 130 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 131 | 0 |  |  |  |  |  | return $self->{_doc}; | 
| 132 |  |  |  |  |  |  | } | 
| 133 |  |  |  |  |  |  |  | 
| 134 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 135 |  |  |  |  |  |  |  | 
| 136 |  |  |  |  |  |  | sub isa { | 
| 137 | 0 |  |  | 0 | 1 |  | my ($self, @args) = @_; | 
| 138 |  |  |  |  |  |  | return $self->SUPER::isa(@args) | 
| 139 | 0 |  | 0 |  |  |  | || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) ); | 
| 140 |  |  |  |  |  |  | } | 
| 141 |  |  |  |  |  |  |  | 
| 142 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 143 |  |  |  |  |  |  |  | 
| 144 |  |  |  |  |  |  | sub find { | 
| 145 | 0 |  |  | 0 | 1 |  | my ($self, $wanted, @more_args) = @_; | 
| 146 |  |  |  |  |  |  |  | 
| 147 |  |  |  |  |  |  | # This method can only find elements by their class names.  For | 
| 148 |  |  |  |  |  |  | # other types of searches, delegate to the PPI::Document | 
| 149 | 0 | 0 | 0 |  |  |  | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { | 
|  |  |  | 0 |  |  |  |  | 
| 150 | 0 |  |  |  |  |  | return $self->{_doc}->find($wanted, @more_args); | 
| 151 |  |  |  |  |  |  | } | 
| 152 |  |  |  |  |  |  |  | 
| 153 |  |  |  |  |  |  | # Build the class cache if it doesn't exist.  This happens at most | 
| 154 |  |  |  |  |  |  | # once per Perl::ToPerl6::Document instance.  %elements of will be | 
| 155 |  |  |  |  |  |  | # populated as a side-effect of calling the $finder_sub coderef | 
| 156 |  |  |  |  |  |  | # that is produced by the caching_finder() closure. | 
| 157 | 0 | 0 |  |  |  |  | if ( !$self->{_elements_of} ) { | 
| 158 |  |  |  |  |  |  |  | 
| 159 | 0 |  |  |  |  |  | my %cache = ( 'PPI::Document' => [ $self ] ); | 
| 160 |  |  |  |  |  |  |  | 
| 161 |  |  |  |  |  |  | # The cache refers to $self, and $self refers to the cache.  This | 
| 162 |  |  |  |  |  |  | # creates a circular reference that leaks memory (i.e.  $self is not | 
| 163 |  |  |  |  |  |  | # destroyed until execution is complete).  By weakening the reference, | 
| 164 |  |  |  |  |  |  | # we allow perl to collect the garbage properly. | 
| 165 | 0 |  |  |  |  |  | weaken( $cache{'PPI::Document'}->[0] ); | 
| 166 |  |  |  |  |  |  |  | 
| 167 | 0 |  |  |  |  |  | my $finder_coderef = _caching_finder( \%cache ); | 
| 168 | 0 |  |  |  |  |  | $self->{_doc}->find( $finder_coderef ); | 
| 169 | 0 |  |  |  |  |  | $self->{_elements_of} = \%cache; | 
| 170 |  |  |  |  |  |  | } | 
| 171 |  |  |  |  |  |  |  | 
| 172 |  |  |  |  |  |  | # find() must return false-but-defined on fail | 
| 173 | 0 |  | 0 |  |  |  | return $self->{_elements_of}->{$wanted} || q{}; | 
| 174 |  |  |  |  |  |  | } | 
| 175 |  |  |  |  |  |  |  | 
| 176 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 177 |  |  |  |  |  |  |  | 
| 178 |  |  |  |  |  |  | sub find_first { | 
| 179 | 0 |  |  | 0 | 1 |  | my ($self, $wanted, @more_args) = @_; | 
| 180 |  |  |  |  |  |  |  | 
| 181 |  |  |  |  |  |  | # This method can only find elements by their class names.  For | 
| 182 |  |  |  |  |  |  | # other types of searches, delegate to the PPI::Document | 
| 183 | 0 | 0 | 0 |  |  |  | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { | 
|  |  |  | 0 |  |  |  |  | 
| 184 | 0 |  |  |  |  |  | return $self->{_doc}->find_first($wanted, @more_args); | 
| 185 |  |  |  |  |  |  | } | 
| 186 |  |  |  |  |  |  |  | 
| 187 | 0 |  |  |  |  |  | my $result = $self->find($wanted); | 
| 188 | 0 | 0 |  |  |  |  | return $result ? $result->[0] : $result; | 
| 189 |  |  |  |  |  |  | } | 
| 190 |  |  |  |  |  |  |  | 
| 191 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 192 |  |  |  |  |  |  |  | 
| 193 |  |  |  |  |  |  | sub find_any { | 
| 194 | 0 |  |  | 0 | 1 |  | my ($self, $wanted, @more_args) = @_; | 
| 195 |  |  |  |  |  |  |  | 
| 196 |  |  |  |  |  |  | # This method can only find elements by their class names.  For | 
| 197 |  |  |  |  |  |  | # other types of searches, delegate to the PPI::Document | 
| 198 | 0 | 0 | 0 |  |  |  | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { | 
|  |  |  | 0 |  |  |  |  | 
| 199 | 0 |  |  |  |  |  | return $self->{_doc}->find_any($wanted, @more_args); | 
| 200 |  |  |  |  |  |  | } | 
| 201 |  |  |  |  |  |  |  | 
| 202 | 0 |  |  |  |  |  | my $result = $self->find($wanted); | 
| 203 | 0 | 0 |  |  |  |  | return $result ? 1 : $result; | 
| 204 |  |  |  |  |  |  | } | 
| 205 |  |  |  |  |  |  |  | 
| 206 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 207 |  |  |  |  |  |  |  | 
| 208 |  |  |  |  |  |  | sub namespaces { | 
| 209 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 210 |  |  |  |  |  |  |  | 
| 211 | 0 |  |  |  |  |  | return keys %{ $self->_nodes_by_namespace() }; | 
|  | 0 |  |  |  |  |  |  | 
| 212 |  |  |  |  |  |  | } | 
| 213 |  |  |  |  |  |  |  | 
| 214 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 215 |  |  |  |  |  |  |  | 
| 216 |  |  |  |  |  |  | sub subdocuments_for_namespace { | 
| 217 | 0 |  |  | 0 | 1 |  | my ($self, $namespace) = @_; | 
| 218 |  |  |  |  |  |  |  | 
| 219 | 0 |  |  |  |  |  | my $subdocuments = $self->_nodes_by_namespace()->{$namespace}; | 
| 220 |  |  |  |  |  |  |  | 
| 221 | 0 | 0 |  |  |  |  | return $subdocuments ? @{$subdocuments} : (); | 
|  | 0 |  |  |  |  |  |  | 
| 222 |  |  |  |  |  |  | } | 
| 223 |  |  |  |  |  |  |  | 
| 224 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 225 |  |  |  |  |  |  |  | 
| 226 |  |  |  |  |  |  | sub ppix_regexp_from_element { | 
| 227 | 0 |  |  | 0 | 1 |  | my ( $self, $element ) = @_; | 
| 228 |  |  |  |  |  |  |  | 
| 229 | 0 | 0 | 0 |  |  |  | if ( blessed( $element ) && $element->isa( 'PPI::Element' ) ) { | 
| 230 | 0 |  |  |  |  |  | my $addr = refaddr( $element ); | 
| 231 |  |  |  |  |  |  | return $self->{_ppix_regexp_from_element}{$addr} | 
| 232 | 0 | 0 |  |  |  |  | if exists $self->{_ppix_regexp_from_element}{$addr}; | 
| 233 | 0 |  |  |  |  |  | return ( $self->{_ppix_regexp_from_element}{$addr} = | 
| 234 |  |  |  |  |  |  | PPIx::Regexp->new( $element, | 
| 235 |  |  |  |  |  |  | default_modifiers => | 
| 236 |  |  |  |  |  |  | $self->_find_use_re_modifiers_in_scope_from_element( | 
| 237 |  |  |  |  |  |  | $element ), | 
| 238 |  |  |  |  |  |  | ) ); | 
| 239 |  |  |  |  |  |  | } else { | 
| 240 | 0 |  |  |  |  |  | return PPIx::Regexp->new( $element ); | 
| 241 |  |  |  |  |  |  | } | 
| 242 |  |  |  |  |  |  | } | 
| 243 |  |  |  |  |  |  |  | 
| 244 |  |  |  |  |  |  | sub _find_use_re_modifiers_in_scope_from_element { | 
| 245 | 0 |  |  | 0 |  |  | my ( $self, $elem ) = @_; | 
| 246 | 0 |  |  |  |  |  | my @found; | 
| 247 | 0 | 0 |  |  |  |  | foreach my $use_re ( @{ $self->find( 'PPI::Statement::Include' ) || [] } ) | 
|  | 0 |  |  |  |  |  |  | 
| 248 |  |  |  |  |  |  | { | 
| 249 | 0 | 0 |  |  |  |  | 're' eq $use_re->module() | 
| 250 |  |  |  |  |  |  | or next; | 
| 251 | 0 | 0 |  |  |  |  | $self->element_is_in_lexical_scope_after_statement_containing( | 
| 252 |  |  |  |  |  |  | $elem, $use_re ) | 
| 253 |  |  |  |  |  |  | or next; | 
| 254 | 0 | 0 |  |  |  |  | my $prefix = 'no' eq $use_re->type() ? q{-} : $EMPTY; | 
| 255 |  |  |  |  |  |  | push @found, | 
| 256 | 0 |  |  |  |  |  | map { "$prefix$_" } | 
| 257 | 0 |  |  |  |  |  | grep { m{ \A / }smx } | 
| 258 |  |  |  |  |  |  | map { | 
| 259 | 0 | 0 |  |  |  |  | $_->isa( 'PPI::Token::Quote' ) ? $_->string() : | 
|  | 0 | 0 |  |  |  |  |  | 
| 260 |  |  |  |  |  |  | $_->isa( 'PPI::Token::QuoteLike::Words' ) ?  $_->literal() : | 
| 261 |  |  |  |  |  |  | $_->content() } | 
| 262 |  |  |  |  |  |  | $use_re->schildren(); | 
| 263 |  |  |  |  |  |  | } | 
| 264 | 0 |  |  |  |  |  | return \@found; | 
| 265 |  |  |  |  |  |  | } | 
| 266 |  |  |  |  |  |  |  | 
| 267 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 268 |  |  |  |  |  |  |  | 
| 269 |  |  |  |  |  |  | # This got hung on the Perl::ToPerl6::Document, rather than living in | 
| 270 |  |  |  |  |  |  | # Perl::ToPerl6::Utils::PPI, because of the possibility that caching of scope | 
| 271 |  |  |  |  |  |  | # objects would turn out to be desirable. | 
| 272 |  |  |  |  |  |  |  | 
| 273 |  |  |  |  |  |  | sub element_is_in_lexical_scope_after_statement_containing { | 
| 274 | 0 |  |  | 0 | 1 |  | my ( $self, $inner_elem, $outer_elem ) = @_; | 
| 275 |  |  |  |  |  |  |  | 
| 276 |  |  |  |  |  |  | # If the outer element defines a scope, we're true if and only if | 
| 277 |  |  |  |  |  |  | # the outer element contains the inner element. | 
| 278 | 0 | 0 |  |  |  |  | $outer_elem->scope() | 
| 279 |  |  |  |  |  |  | and return $inner_elem->descendant_of( $outer_elem ); | 
| 280 |  |  |  |  |  |  |  | 
| 281 |  |  |  |  |  |  | # In the more general case: | 
| 282 |  |  |  |  |  |  |  | 
| 283 |  |  |  |  |  |  | # The last element of the statement containing the outer element | 
| 284 |  |  |  |  |  |  | # must be before the inner element. If not, we know we're false, | 
| 285 |  |  |  |  |  |  | # without walking the parse tree. | 
| 286 |  |  |  |  |  |  |  | 
| 287 | 0 | 0 |  |  |  |  | my $stmt = $outer_elem->statement() | 
| 288 |  |  |  |  |  |  | or return; | 
| 289 | 0 | 0 |  |  |  |  | my $last_elem = $stmt->last_element() | 
| 290 |  |  |  |  |  |  | or return; | 
| 291 |  |  |  |  |  |  |  | 
| 292 | 0 | 0 |  |  |  |  | my $stmt_loc = $last_elem->location() | 
| 293 |  |  |  |  |  |  | or return; | 
| 294 |  |  |  |  |  |  |  | 
| 295 | 0 | 0 |  |  |  |  | my $inner_loc = $inner_elem->location() | 
| 296 |  |  |  |  |  |  | or return; | 
| 297 |  |  |  |  |  |  |  | 
| 298 | 0 | 0 |  |  |  |  | $stmt_loc->[0] > $inner_loc->[0] | 
| 299 |  |  |  |  |  |  | and return; | 
| 300 | 0 | 0 | 0 |  |  |  | $stmt_loc->[0] == $inner_loc->[0] | 
| 301 |  |  |  |  |  |  | and $stmt_loc->[1] > $inner_loc->[1] | 
| 302 |  |  |  |  |  |  | and return; | 
| 303 |  |  |  |  |  |  |  | 
| 304 |  |  |  |  |  |  | # Since we know the inner element is after the outer element, find | 
| 305 |  |  |  |  |  |  | # the element that defines the scope of the statement that contains | 
| 306 |  |  |  |  |  |  | # the outer element. | 
| 307 |  |  |  |  |  |  |  | 
| 308 | 0 |  |  |  |  |  | my $parent = $stmt; | 
| 309 | 0 |  |  |  |  |  | while ( ! $parent->scope() ) { | 
| 310 | 0 | 0 |  |  |  |  | $parent = $parent->parent() | 
| 311 |  |  |  |  |  |  | or return; | 
| 312 |  |  |  |  |  |  | } | 
| 313 |  |  |  |  |  |  |  | 
| 314 |  |  |  |  |  |  | # We're true if and only if the scope of the outer element contains | 
| 315 |  |  |  |  |  |  | # the inner element. | 
| 316 |  |  |  |  |  |  |  | 
| 317 | 0 |  |  |  |  |  | return $inner_elem->descendant_of( $parent ); | 
| 318 |  |  |  |  |  |  |  | 
| 319 |  |  |  |  |  |  | } | 
| 320 |  |  |  |  |  |  |  | 
| 321 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 322 |  |  |  |  |  |  |  | 
| 323 |  |  |  |  |  |  | sub filename { | 
| 324 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 325 |  |  |  |  |  |  |  | 
| 326 | 0 | 0 |  |  |  |  | if (defined $self->{_filename_override}) { | 
| 327 | 0 |  |  |  |  |  | return $self->{_filename_override}; | 
| 328 |  |  |  |  |  |  | } | 
| 329 |  |  |  |  |  |  | else { | 
| 330 | 0 |  |  |  |  |  | my $doc = $self->{_doc}; | 
| 331 | 0 | 0 |  |  |  |  | return $doc->can('filename') ? $doc->filename() : undef; | 
| 332 |  |  |  |  |  |  | } | 
| 333 |  |  |  |  |  |  | } | 
| 334 |  |  |  |  |  |  |  | 
| 335 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 336 |  |  |  |  |  |  |  | 
| 337 |  |  |  |  |  |  | sub highest_explicit_perl_version { | 
| 338 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 339 |  |  |  |  |  |  |  | 
| 340 |  |  |  |  |  |  | my $highest_explicit_perl_version = | 
| 341 | 0 |  |  |  |  |  | $self->{_highest_explicit_perl_version}; | 
| 342 |  |  |  |  |  |  |  | 
| 343 | 0 | 0 |  |  |  |  | if ( not exists $self->{_highest_explicit_perl_version} ) { | 
| 344 | 0 |  |  |  |  |  | my $includes = $self->find( \&_is_a_version_statement ); | 
| 345 |  |  |  |  |  |  |  | 
| 346 | 0 | 0 |  |  |  |  | if ($includes) { | 
| 347 |  |  |  |  |  |  | # Note: this doesn't use List::Util::max() because that function | 
| 348 |  |  |  |  |  |  | # doesn't use the overloaded ">=" etc of a version object.  The | 
| 349 |  |  |  |  |  |  | # reduce() style lets version.pm take care of all comparing. | 
| 350 |  |  |  |  |  |  | # | 
| 351 |  |  |  |  |  |  | # For reference, max() ends up looking at the string converted to | 
| 352 |  |  |  |  |  |  | # an NV, or something like that.  An underscore like "5.005_04" | 
| 353 |  |  |  |  |  |  | # provokes a warning and is chopped off at "5.005" thus losing the | 
| 354 |  |  |  |  |  |  | # minor part from the comparison. | 
| 355 |  |  |  |  |  |  | # | 
| 356 |  |  |  |  |  |  | # An underscore "5.005_04" is supposed to mean an alpha release | 
| 357 |  |  |  |  |  |  | # and shouldn't be used in a perl version.  But it's shown in | 
| 358 |  |  |  |  |  |  | # perlfunc under "use" (as a number separator), and appears in | 
| 359 |  |  |  |  |  |  | # several modules supplied with perl 5.10.0 (like version.pm | 
| 360 |  |  |  |  |  |  | # itself!).  At any rate if version.pm can understand it then | 
| 361 |  |  |  |  |  |  | # that's enough for here. | 
| 362 |  |  |  |  |  |  | $highest_explicit_perl_version = | 
| 363 | 0 | 0 |  | 0 |  |  | reduce { $a >= $b ? $a : $b } | 
| 364 | 0 |  |  |  |  |  | map    { version->new( $_->version() ) } | 
| 365 | 0 |  |  |  |  |  | @{$includes}; | 
|  | 0 |  |  |  |  |  |  | 
| 366 |  |  |  |  |  |  | } | 
| 367 |  |  |  |  |  |  | else { | 
| 368 | 0 |  |  |  |  |  | $highest_explicit_perl_version = undef; | 
| 369 |  |  |  |  |  |  | } | 
| 370 |  |  |  |  |  |  |  | 
| 371 |  |  |  |  |  |  | $self->{_highest_explicit_perl_version} = | 
| 372 | 0 |  |  |  |  |  | $highest_explicit_perl_version; | 
| 373 |  |  |  |  |  |  | } | 
| 374 |  |  |  |  |  |  |  | 
| 375 | 0 | 0 |  |  |  |  | return $highest_explicit_perl_version if $highest_explicit_perl_version; | 
| 376 | 0 |  |  |  |  |  | return; | 
| 377 |  |  |  |  |  |  | } | 
| 378 |  |  |  |  |  |  |  | 
| 379 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 380 |  |  |  |  |  |  |  | 
| 381 |  |  |  |  |  |  | sub uses_module { | 
| 382 | 0 |  |  | 0 | 1 |  | my ($self, $module_name) = @_; | 
| 383 |  |  |  |  |  |  |  | 
| 384 | 0 |  |  |  |  |  | return exists $self->_modules_used()->{$module_name}; | 
| 385 |  |  |  |  |  |  | } | 
| 386 |  |  |  |  |  |  |  | 
| 387 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 388 |  |  |  |  |  |  |  | 
| 389 |  |  |  |  |  |  | sub process_annotations { | 
| 390 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 391 |  |  |  |  |  |  |  | 
| 392 | 0 |  |  |  |  |  | my @annotations = Perl::ToPerl6::Annotation->create_annotations($self); | 
| 393 | 0 |  |  |  |  |  | $self->add_annotation(@annotations); | 
| 394 | 0 |  |  |  |  |  | return $self; | 
| 395 |  |  |  |  |  |  | } | 
| 396 |  |  |  |  |  |  |  | 
| 397 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 398 |  |  |  |  |  |  |  | 
| 399 |  |  |  |  |  |  | sub line_is_disabled_for_transformer { | 
| 400 | 0 |  |  | 0 | 1 |  | my ($self, $line, $transformer) = @_; | 
| 401 | 0 |  | 0 |  |  |  | my $transformer_name = ref $transformer || $transformer; | 
| 402 |  |  |  |  |  |  |  | 
| 403 |  |  |  |  |  |  | # HACK: This Transformer is special.  If it is active, it cannot be | 
| 404 |  |  |  |  |  |  | # disabled by a "## no mogrify" annotation.  Rather than create a general | 
| 405 |  |  |  |  |  |  | # hook in Transformer.pm for enabling this behavior, we chose to hack | 
| 406 |  |  |  |  |  |  | # it here, since this isn't the kind of thing that most transformers do | 
| 407 |  |  |  |  |  |  |  | 
| 408 | 0 | 0 |  |  |  |  | return 0 if $transformer_name eq | 
| 409 |  |  |  |  |  |  | 'Perl::ToPerl6::Transformer::Miscellanea::ProhibitUnrestrictedNoCritic'; | 
| 410 |  |  |  |  |  |  |  | 
| 411 | 0 | 0 |  |  |  |  | return 0 unless $line; | 
| 412 | 0 | 0 |  |  |  |  | return 1 if $self->{_disabled_line_map}->{$line}->{$transformer_name}; | 
| 413 | 0 | 0 |  |  |  |  | return 1 if $self->{_disabled_line_map}->{$line}->{ALL}; | 
| 414 | 0 |  |  |  |  |  | return 0; | 
| 415 |  |  |  |  |  |  | } | 
| 416 |  |  |  |  |  |  |  | 
| 417 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 418 |  |  |  |  |  |  |  | 
| 419 |  |  |  |  |  |  | sub add_annotation { | 
| 420 | 0 |  |  | 0 | 1 |  | my ($self, @annotations) = @_; | 
| 421 |  |  |  |  |  |  |  | 
| 422 |  |  |  |  |  |  | # Add annotation to our private map for quick lookup | 
| 423 | 0 |  |  |  |  |  | for my $annotation (@annotations) { | 
| 424 |  |  |  |  |  |  |  | 
| 425 | 0 |  |  |  |  |  | my ($start, $end) = $annotation->effective_range(); | 
| 426 | 0 | 0 |  |  |  |  | my @affected_transformers = $annotation->disables_all_transformers ? | 
| 427 |  |  |  |  |  |  | qw(ALL) : $annotation->disabled_transformers(); | 
| 428 |  |  |  |  |  |  |  | 
| 429 |  |  |  |  |  |  | # TODO: Find clever way to do this with hash slices | 
| 430 | 0 |  |  |  |  |  | for my $line ($start .. $end) { | 
| 431 | 0 |  |  |  |  |  | for my $transformer (@affected_transformers) { | 
| 432 | 0 |  |  |  |  |  | $self->{_disabled_line_map}->{$line}->{$transformer} = 1; | 
| 433 |  |  |  |  |  |  | } | 
| 434 |  |  |  |  |  |  | } | 
| 435 |  |  |  |  |  |  | } | 
| 436 |  |  |  |  |  |  |  | 
| 437 | 0 |  |  |  |  |  | push @{ $self->{_annotations} }, @annotations; | 
|  | 0 |  |  |  |  |  |  | 
| 438 | 0 |  |  |  |  |  | return $self; | 
| 439 |  |  |  |  |  |  | } | 
| 440 |  |  |  |  |  |  |  | 
| 441 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 442 |  |  |  |  |  |  |  | 
| 443 |  |  |  |  |  |  | sub annotations { | 
| 444 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 445 | 0 |  |  |  |  |  | return @{ $self->{_annotations} }; | 
|  | 0 |  |  |  |  |  |  | 
| 446 |  |  |  |  |  |  | } | 
| 447 |  |  |  |  |  |  |  | 
| 448 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 449 |  |  |  |  |  |  |  | 
| 450 |  |  |  |  |  |  | sub add_suppressed_transformation { | 
| 451 | 0 |  |  | 0 | 1 |  | my ($self, $transformation) = @_; | 
| 452 | 0 |  |  |  |  |  | push @{$self->{_suppressed_transformations}}, $transformation; | 
|  | 0 |  |  |  |  |  |  | 
| 453 | 0 |  |  |  |  |  | return $self; | 
| 454 |  |  |  |  |  |  | } | 
| 455 |  |  |  |  |  |  |  | 
| 456 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 457 |  |  |  |  |  |  |  | 
| 458 |  |  |  |  |  |  | sub suppressed_transformations { | 
| 459 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 460 | 0 |  |  |  |  |  | return @{ $self->{_suppressed_transformations} }; | 
|  | 0 |  |  |  |  |  |  | 
| 461 |  |  |  |  |  |  | } | 
| 462 |  |  |  |  |  |  |  | 
| 463 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 464 |  |  |  |  |  |  |  | 
| 465 |  |  |  |  |  |  | sub is_program { | 
| 466 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 467 |  |  |  |  |  |  |  | 
| 468 | 0 |  |  |  |  |  | return not $self->is_module(); | 
| 469 |  |  |  |  |  |  | } | 
| 470 |  |  |  |  |  |  |  | 
| 471 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 472 |  |  |  |  |  |  |  | 
| 473 |  |  |  |  |  |  | sub is_module { | 
| 474 | 0 |  |  | 0 | 1 |  | my ($self) = @_; | 
| 475 |  |  |  |  |  |  |  | 
| 476 | 0 |  |  |  |  |  | return $self->{_is_module}; | 
| 477 |  |  |  |  |  |  | } | 
| 478 |  |  |  |  |  |  |  | 
| 479 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 480 |  |  |  |  |  |  | # PRIVATE functions & methods | 
| 481 |  |  |  |  |  |  |  | 
| 482 |  |  |  |  |  |  | sub _is_a_version_statement { | 
| 483 | 0 |  |  | 0 |  |  | my (undef, $element) = @_; | 
| 484 |  |  |  |  |  |  |  | 
| 485 | 0 | 0 |  |  |  |  | return 0 if not $element->isa('PPI::Statement::Include'); | 
| 486 | 0 | 0 |  |  |  |  | return 1 if $element->version(); | 
| 487 | 0 |  |  |  |  |  | return 0; | 
| 488 |  |  |  |  |  |  | } | 
| 489 |  |  |  |  |  |  |  | 
| 490 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 491 |  |  |  |  |  |  |  | 
| 492 |  |  |  |  |  |  | sub _caching_finder { | 
| 493 | 0 |  |  | 0 |  |  | my $cache_ref = shift;  # These vars will persist for the life | 
| 494 | 0 |  |  |  |  |  | my %isa_cache = ();     # of the code ref that this sub returns | 
| 495 |  |  |  |  |  |  |  | 
| 496 |  |  |  |  |  |  |  | 
| 497 |  |  |  |  |  |  | # Gather up all the PPI elements and sort by @ISA.  Note: if any | 
| 498 |  |  |  |  |  |  | # instances used multiple inheritance, this implementation would | 
| 499 |  |  |  |  |  |  | # lead to multiple copies of $element in the $elements_of lists. | 
| 500 |  |  |  |  |  |  | # However, PPI::* doesn't do multiple inheritance, so we are safe | 
| 501 |  |  |  |  |  |  |  | 
| 502 |  |  |  |  |  |  | return sub { | 
| 503 | 0 |  |  | 0 |  |  | my (undef, $element) = @_; | 
| 504 | 0 |  |  |  |  |  | my $classes = $isa_cache{ref $element}; | 
| 505 | 0 | 0 |  |  |  |  | if ( !$classes ) { | 
| 506 | 0 |  |  |  |  |  | $classes = [ ref $element ]; | 
| 507 |  |  |  |  |  |  | # Use a C-style loop because we append to the classes array inside | 
| 508 | 0 |  |  |  |  |  | for ( my $i = 0; $i < @{$classes}; $i++ ) { | 
|  | 0 |  |  |  |  |  |  | 
| 509 | 1 |  |  | 1 |  | 12 | no strict 'refs'; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 620 |  | 
| 510 | 0 |  |  |  |  |  | push @{$classes}, @{"$classes->[$i]::ISA"}; | 
|  | 0 |  |  |  |  |  |  | 
|  | 0 |  |  |  |  |  |  | 
| 511 | 0 |  | 0 |  |  |  | $cache_ref->{$classes->[$i]} ||= []; | 
| 512 |  |  |  |  |  |  | } | 
| 513 | 0 |  |  |  |  |  | $isa_cache{$classes->[0]} = $classes; | 
| 514 |  |  |  |  |  |  | } | 
| 515 |  |  |  |  |  |  |  | 
| 516 | 0 |  |  |  |  |  | for my $class ( @{$classes} ) { | 
|  | 0 |  |  |  |  |  |  | 
| 517 | 0 |  |  |  |  |  | push @{$cache_ref->{$class}}, $element; | 
|  | 0 |  |  |  |  |  |  | 
| 518 |  |  |  |  |  |  | } | 
| 519 |  |  |  |  |  |  |  | 
| 520 | 0 |  |  |  |  |  | return 0; # 0 tells find() to keep traversing, but not to store this $element | 
| 521 | 0 |  |  |  |  |  | }; | 
| 522 |  |  |  |  |  |  | } | 
| 523 |  |  |  |  |  |  |  | 
| 524 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 525 |  |  |  |  |  |  |  | 
| 526 |  |  |  |  |  |  | sub _disable_shebang_fix { | 
| 527 | 0 |  |  | 0 |  |  | my ($self) = @_; | 
| 528 |  |  |  |  |  |  |  | 
| 529 |  |  |  |  |  |  | # When you install a program using ExtUtils::MakeMaker or Module::Build, it | 
| 530 |  |  |  |  |  |  | # inserts some magical code into the top of the file (just after the | 
| 531 |  |  |  |  |  |  | # shebang).  This code allows people to call your program using a shell, | 
| 532 |  |  |  |  |  |  | # like `sh my_script`.  Unfortunately, this code causes several Transformer | 
| 533 |  |  |  |  |  |  | # transformations, so we disable them as if they had "## no mogrify" annotations. | 
| 534 |  |  |  |  |  |  |  | 
| 535 | 0 |  | 0 |  |  |  | my $first_stmnt = $self->schild(0) || return; | 
| 536 |  |  |  |  |  |  |  | 
| 537 |  |  |  |  |  |  | # Different versions of MakeMaker and Build use slightly different shebang | 
| 538 |  |  |  |  |  |  | # fixing strings.  This matches most of the ones I've found in my own Perl | 
| 539 |  |  |  |  |  |  | # distribution, but it may not be bullet-proof. | 
| 540 |  |  |  |  |  |  |  | 
| 541 | 0 |  |  |  |  |  | my $fixin_rx = qr<^eval 'exec .* \$0 \$[{]1[+]"\$@"}'\s*[\r\n]\s*if.+;>ms; ## no mogrify (ExtendedFormatting) | 
| 542 | 0 | 0 |  |  |  |  | if ( $first_stmnt =~ $fixin_rx ) { | 
| 543 | 0 |  |  |  |  |  | my $line = $first_stmnt->location->[0]; | 
| 544 | 0 |  |  |  |  |  | $self->{_disabled_line_map}->{$line}->{ALL} = 1; | 
| 545 | 0 |  |  |  |  |  | $self->{_disabled_line_map}->{$line + 1}->{ALL} = 1; | 
| 546 |  |  |  |  |  |  | } | 
| 547 |  |  |  |  |  |  |  | 
| 548 | 0 |  |  |  |  |  | return $self; | 
| 549 |  |  |  |  |  |  | } | 
| 550 |  |  |  |  |  |  |  | 
| 551 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 552 |  |  |  |  |  |  |  | 
| 553 |  |  |  |  |  |  | sub _determine_is_module { | 
| 554 | 0 |  |  | 0 |  |  | my ($self, $args) = @_; | 
| 555 |  |  |  |  |  |  |  | 
| 556 | 0 |  |  |  |  |  | my $file_name = $self->filename(); | 
| 557 | 0 | 0 | 0 |  |  |  | if ( | 
| 558 |  |  |  |  |  |  | defined $file_name | 
| 559 |  |  |  |  |  |  | and ref $args->{'-program-extensions'} eq 'ARRAY' | 
| 560 |  |  |  |  |  |  | ) { | 
| 561 | 0 |  |  |  |  |  | foreach my $ext ( @{ $args->{'-program-extensions'} } ) { | 
|  | 0 |  |  |  |  |  |  | 
| 562 | 0 | 0 |  |  |  |  | my $regex = | 
| 563 |  |  |  |  |  |  | ref $ext eq 'Regexp' | 
| 564 |  |  |  |  |  |  | ? $ext | 
| 565 | 0 |  |  |  |  |  | : qr< @{ [ quotemeta $ext ] } \z >xms; | 
| 566 |  |  |  |  |  |  |  | 
| 567 | 0 | 0 |  |  |  |  | return $FALSE if $file_name =~ m/$regex/smx; | 
| 568 |  |  |  |  |  |  | } | 
| 569 |  |  |  |  |  |  | } | 
| 570 |  |  |  |  |  |  |  | 
| 571 | 0 | 0 |  |  |  |  | return $FALSE if shebang_line($self); | 
| 572 | 0 | 0 | 0 |  |  |  | return $FALSE if defined $file_name && $file_name =~ m/ [.] PL \z /smx; | 
| 573 |  |  |  |  |  |  |  | 
| 574 | 0 |  |  |  |  |  | return $TRUE; | 
| 575 |  |  |  |  |  |  | } | 
| 576 |  |  |  |  |  |  |  | 
| 577 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 578 |  |  |  |  |  |  |  | 
| 579 |  |  |  |  |  |  | sub _nodes_by_namespace { | 
| 580 | 0 |  |  | 0 |  |  | my ($self) = @_; | 
| 581 |  |  |  |  |  |  |  | 
| 582 | 0 |  |  |  |  |  | my $nodes = $self->{_nodes_by_namespace}; | 
| 583 |  |  |  |  |  |  |  | 
| 584 | 0 | 0 |  |  |  |  | return $nodes if $nodes; | 
| 585 |  |  |  |  |  |  |  | 
| 586 | 0 |  |  |  |  |  | my $ppi_document = $self->ppi_document(); | 
| 587 | 0 | 0 |  |  |  |  | if (not $ppi_document) { | 
| 588 | 0 |  |  |  |  |  | return $self->{_nodes_by_namespace} = {}; | 
| 589 |  |  |  |  |  |  | } | 
| 590 |  |  |  |  |  |  |  | 
| 591 | 0 |  |  |  |  |  | my $raw_nodes_map = split_ppi_node_by_namespace($ppi_document); | 
| 592 |  |  |  |  |  |  |  | 
| 593 | 0 |  |  |  |  |  | my %wrapped_nodes; | 
| 594 | 0 |  |  |  |  |  | while ( my ($namespace, $raw_nodes) = each %{$raw_nodes_map} ) { | 
|  | 0 |  |  |  |  |  |  | 
| 595 |  |  |  |  |  |  | $wrapped_nodes{$namespace} = [ | 
| 596 | 0 |  |  |  |  |  | map { __PACKAGE__->_new_for_parent_document($_, $self) } | 
| 597 | 0 |  |  |  |  |  | @{$raw_nodes} | 
|  | 0 |  |  |  |  |  |  | 
| 598 |  |  |  |  |  |  | ]; | 
| 599 |  |  |  |  |  |  | } | 
| 600 |  |  |  |  |  |  |  | 
| 601 | 0 |  |  |  |  |  | return $self->{_nodes_by_namespace} = \%wrapped_nodes; | 
| 602 |  |  |  |  |  |  | } | 
| 603 |  |  |  |  |  |  |  | 
| 604 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 605 |  |  |  |  |  |  |  | 
| 606 |  |  |  |  |  |  | # Note: must use exists on return value to determine membership because all | 
| 607 |  |  |  |  |  |  | # the values are false, unlike the result of hashify(). | 
| 608 |  |  |  |  |  |  | sub _modules_used { | 
| 609 | 0 |  |  | 0 |  |  | my ($self) = @_; | 
| 610 |  |  |  |  |  |  |  | 
| 611 | 0 |  |  |  |  |  | my $mapping = $self->{_modules_used}; | 
| 612 |  |  |  |  |  |  |  | 
| 613 | 0 | 0 |  |  |  |  | return $mapping if $mapping; | 
| 614 |  |  |  |  |  |  |  | 
| 615 | 0 |  |  |  |  |  | my $includes = $self->find('PPI::Statement::Include'); | 
| 616 | 0 | 0 |  |  |  |  | if (not $includes) { | 
| 617 | 0 |  |  |  |  |  | return $self->{_modules_used} = {}; | 
| 618 |  |  |  |  |  |  | } | 
| 619 |  |  |  |  |  |  |  | 
| 620 | 0 |  |  |  |  |  | my %mapping; | 
| 621 | 0 |  |  |  |  |  | for my $module ( | 
| 622 | 0 | 0 |  |  |  |  | grep { $_ } map  { $_->module() || $_->pragma() } @{$includes} | 
|  | 0 |  |  |  |  |  |  | 
|  | 0 |  |  |  |  |  |  | 
| 623 |  |  |  |  |  |  | ) { | 
| 624 |  |  |  |  |  |  | # Significanly ess memory than $h{$k} => 1.  Thanks Mr. Lembark. | 
| 625 | 0 |  |  |  |  |  | $mapping{$module} = (); | 
| 626 |  |  |  |  |  |  | } | 
| 627 |  |  |  |  |  |  |  | 
| 628 | 0 |  |  |  |  |  | return $self->{_modules_used} = \%mapping; | 
| 629 |  |  |  |  |  |  | } | 
| 630 |  |  |  |  |  |  |  | 
| 631 |  |  |  |  |  |  | #----------------------------------------------------------------------------- | 
| 632 |  |  |  |  |  |  |  | 
| 633 |  |  |  |  |  |  | 1; | 
| 634 |  |  |  |  |  |  |  | 
| 635 |  |  |  |  |  |  | __END__ | 
| 636 |  |  |  |  |  |  |  | 
| 637 |  |  |  |  |  |  | =pod | 
| 638 |  |  |  |  |  |  |  | 
| 639 |  |  |  |  |  |  | =for stopwords pre-caches | 
| 640 |  |  |  |  |  |  |  | 
| 641 |  |  |  |  |  |  | =head1 NAME | 
| 642 |  |  |  |  |  |  |  | 
| 643 |  |  |  |  |  |  | Perl::ToPerl6::Document - Caching wrapper around a PPI::Document. | 
| 644 |  |  |  |  |  |  |  | 
| 645 |  |  |  |  |  |  |  | 
| 646 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 647 |  |  |  |  |  |  |  | 
| 648 |  |  |  |  |  |  | use PPI::Document; | 
| 649 |  |  |  |  |  |  | use Perl::ToPerl6::Document; | 
| 650 |  |  |  |  |  |  | my $doc = PPI::Document->new('Foo.pm'); | 
| 651 |  |  |  |  |  |  | $doc = Perl::ToPerl6::Document->new(-source => $doc); | 
| 652 |  |  |  |  |  |  | ## Then use the instance just like a PPI::Document | 
| 653 |  |  |  |  |  |  |  | 
| 654 |  |  |  |  |  |  |  | 
| 655 |  |  |  |  |  |  | =head1 DESCRIPTION | 
| 656 |  |  |  |  |  |  |  | 
| 657 |  |  |  |  |  |  | Perl::ToPerl6 does a lot of iterations over the PPI document tree via | 
| 658 |  |  |  |  |  |  | the C<PPI::Document::find()> method.  To save some time, this class | 
| 659 |  |  |  |  |  |  | pre-caches a lot of the common C<find()> calls in a single traversal. | 
| 660 |  |  |  |  |  |  | Then, on subsequent requests we return the cached data. | 
| 661 |  |  |  |  |  |  |  | 
| 662 |  |  |  |  |  |  | This is implemented as a facade, where method calls are handed to the | 
| 663 |  |  |  |  |  |  | stored C<PPI::Document> instance. | 
| 664 |  |  |  |  |  |  |  | 
| 665 |  |  |  |  |  |  |  | 
| 666 |  |  |  |  |  |  | =head1 CAVEATS | 
| 667 |  |  |  |  |  |  |  | 
| 668 |  |  |  |  |  |  | This facade does not implement the overloaded operators from | 
| 669 |  |  |  |  |  |  | L<PPI::Document|PPI::Document> (that is, the C<use overload ...> | 
| 670 |  |  |  |  |  |  | work). Therefore, users of this facade must not rely on that syntactic | 
| 671 |  |  |  |  |  |  | sugar.  So, for example, instead of C<my $source = "$doc";> you should | 
| 672 |  |  |  |  |  |  | write C<< my $source = $doc->content(); >> | 
| 673 |  |  |  |  |  |  |  | 
| 674 |  |  |  |  |  |  | Perhaps there is a CPAN module out there which implements a facade | 
| 675 |  |  |  |  |  |  | better than we do here? | 
| 676 |  |  |  |  |  |  |  | 
| 677 |  |  |  |  |  |  |  | 
| 678 |  |  |  |  |  |  | =head1 INTERFACE SUPPORT | 
| 679 |  |  |  |  |  |  |  | 
| 680 |  |  |  |  |  |  | This is considered to be a public class.  Any changes to its interface | 
| 681 |  |  |  |  |  |  | will go through a deprecation cycle. | 
| 682 |  |  |  |  |  |  |  | 
| 683 |  |  |  |  |  |  |  | 
| 684 |  |  |  |  |  |  | =head1 CONSTRUCTOR | 
| 685 |  |  |  |  |  |  |  | 
| 686 |  |  |  |  |  |  | =over | 
| 687 |  |  |  |  |  |  |  | 
| 688 |  |  |  |  |  |  | =item C<< new(-source => $source_code, '-filename-override' => $filename, '-program-extensions' => [program_extensions]) >> | 
| 689 |  |  |  |  |  |  |  | 
| 690 |  |  |  |  |  |  | Create a new instance referencing a PPI::Document instance.  The | 
| 691 |  |  |  |  |  |  | C<$source_code> can be the name of a file, a reference to a scalar | 
| 692 |  |  |  |  |  |  | containing actual source code, or a L<PPI::Document|PPI::Document> or | 
| 693 |  |  |  |  |  |  | L<PPI::Document::File|PPI::Document::File>. | 
| 694 |  |  |  |  |  |  |  | 
| 695 |  |  |  |  |  |  | In the event that C<$source_code> is a reference to a scalar containing actual | 
| 696 |  |  |  |  |  |  | source code or a L<PPI::Document|PPI::Document>, the resulting | 
| 697 |  |  |  |  |  |  | L<Perl::ToPerl6::Document|Perl::ToPerl6::Document> will not have a filename. | 
| 698 |  |  |  |  |  |  | This may cause L<Perl::ToPerl6::Document|Perl::ToPerl6::Document> to incorrectly | 
| 699 |  |  |  |  |  |  | classify the source code as a module or script.  To avoid this problem, you | 
| 700 |  |  |  |  |  |  | can optionally set the C<-filename-override> to force the | 
| 701 |  |  |  |  |  |  | L<Perl::ToPerl6::Document|Perl::ToPerl6::Document> to have a particular | 
| 702 |  |  |  |  |  |  | C<$filename>.  Do not use this option if C<$source_code> is already the name | 
| 703 |  |  |  |  |  |  | of a file, or is a reference to a L<PPI::Document::File|PPI::Document::File>. | 
| 704 |  |  |  |  |  |  |  | 
| 705 |  |  |  |  |  |  | The '-program-extensions' argument is optional, and is a reference to a list | 
| 706 |  |  |  |  |  |  | of strings and/or regular expressions. The strings will be made into regular | 
| 707 |  |  |  |  |  |  | expressions matching the end of a file name, and any document whose file name | 
| 708 |  |  |  |  |  |  | matches one of the regular expressions will be considered a program. | 
| 709 |  |  |  |  |  |  |  | 
| 710 |  |  |  |  |  |  | If -program-extensions is not specified, or if it does not determine the | 
| 711 |  |  |  |  |  |  | document type, the document will be considered to be a program if the source | 
| 712 |  |  |  |  |  |  | has a shebang line or its file name (if any) matches C<< m/ [.] PL \z /smx >>. | 
| 713 |  |  |  |  |  |  |  | 
| 714 |  |  |  |  |  |  | =back | 
| 715 |  |  |  |  |  |  |  | 
| 716 |  |  |  |  |  |  | =head1 METHODS | 
| 717 |  |  |  |  |  |  |  | 
| 718 |  |  |  |  |  |  | =over | 
| 719 |  |  |  |  |  |  |  | 
| 720 |  |  |  |  |  |  | =item C<< ppi_document() >> | 
| 721 |  |  |  |  |  |  |  | 
| 722 |  |  |  |  |  |  | Accessor for the wrapped PPI::Document instance.  Note that altering | 
| 723 |  |  |  |  |  |  | this instance in any way can cause unpredictable failures in | 
| 724 |  |  |  |  |  |  | Perl::ToPerl6's subsequent analysis because some caches may fall out of | 
| 725 |  |  |  |  |  |  | date. | 
| 726 |  |  |  |  |  |  |  | 
| 727 |  |  |  |  |  |  |  | 
| 728 |  |  |  |  |  |  | =item C<< find($wanted) >> | 
| 729 |  |  |  |  |  |  |  | 
| 730 |  |  |  |  |  |  | =item C<< find_first($wanted) >> | 
| 731 |  |  |  |  |  |  |  | 
| 732 |  |  |  |  |  |  | =item C<< find_any($wanted) >> | 
| 733 |  |  |  |  |  |  |  | 
| 734 |  |  |  |  |  |  | Caching wrappers around the PPI methods.  If C<$wanted> is a simple PPI class | 
| 735 |  |  |  |  |  |  | name, then the cache is employed. Otherwise we forward the call to the | 
| 736 |  |  |  |  |  |  | corresponding method of the C<PPI::Document> instance. | 
| 737 |  |  |  |  |  |  |  | 
| 738 |  |  |  |  |  |  |  | 
| 739 |  |  |  |  |  |  | =item C<< namespaces() >> | 
| 740 |  |  |  |  |  |  |  | 
| 741 |  |  |  |  |  |  | Returns a list of the namespaces (package names) in the document. | 
| 742 |  |  |  |  |  |  |  | 
| 743 |  |  |  |  |  |  |  | 
| 744 |  |  |  |  |  |  | =item C<< subdocuments_for_namespace($namespace) >> | 
| 745 |  |  |  |  |  |  |  | 
| 746 |  |  |  |  |  |  | Returns a list of sub-documents containing the elements in the given | 
| 747 |  |  |  |  |  |  | namespace.  For example, given that the current document is for the source | 
| 748 |  |  |  |  |  |  |  | 
| 749 |  |  |  |  |  |  | foo(); | 
| 750 |  |  |  |  |  |  | package Foo; | 
| 751 |  |  |  |  |  |  | package Bar; | 
| 752 |  |  |  |  |  |  | package Foo; | 
| 753 |  |  |  |  |  |  |  | 
| 754 |  |  |  |  |  |  | this method will return two L<Perl::ToPerl6::Document|Perl::ToPerl6::Document>s | 
| 755 |  |  |  |  |  |  | for a parameter of C<"Foo">.  For more, see | 
| 756 |  |  |  |  |  |  | L<PPIx::Utilities::Node/split_ppi_node_by_namespace>. | 
| 757 |  |  |  |  |  |  |  | 
| 758 |  |  |  |  |  |  |  | 
| 759 |  |  |  |  |  |  | =item C<< ppix_regexp_from_element($element) >> | 
| 760 |  |  |  |  |  |  |  | 
| 761 |  |  |  |  |  |  | Caching wrapper around C<< PPIx::Regexp->new($element) >>.  If | 
| 762 |  |  |  |  |  |  | C<$element> is a C<PPI::Element> the cache is employed, otherwise it | 
| 763 |  |  |  |  |  |  | just returns the results of C<< PPIx::Regexp->new() >>.  In either case, | 
| 764 |  |  |  |  |  |  | it returns C<undef> unless the argument is something that | 
| 765 |  |  |  |  |  |  | L<PPIx::Regexp|PPIx::Regexp> actually understands. | 
| 766 |  |  |  |  |  |  |  | 
| 767 |  |  |  |  |  |  | =item C<< element_is_in_lexical_scope_after_statement_containing( $inner, $outer ) >> | 
| 768 |  |  |  |  |  |  |  | 
| 769 |  |  |  |  |  |  | Is the C<$inner> element in lexical scope after the statement containing | 
| 770 |  |  |  |  |  |  | the C<$outer> element? | 
| 771 |  |  |  |  |  |  |  | 
| 772 |  |  |  |  |  |  | In the case where C<$outer> is itself a scope-defining element, returns true | 
| 773 |  |  |  |  |  |  | if C<$outer> contains C<$inner>. In any other case, C<$inner> must be | 
| 774 |  |  |  |  |  |  | after the last element of the statement containing C<$outer>, and the | 
| 775 |  |  |  |  |  |  | innermost scope for C<$outer> also contains C<$inner>. | 
| 776 |  |  |  |  |  |  |  | 
| 777 |  |  |  |  |  |  | This is not the same as asking whether C<$inner> is visible from | 
| 778 |  |  |  |  |  |  | C<$outer>. | 
| 779 |  |  |  |  |  |  |  | 
| 780 |  |  |  |  |  |  |  | 
| 781 |  |  |  |  |  |  | =item C<< filename() >> | 
| 782 |  |  |  |  |  |  |  | 
| 783 |  |  |  |  |  |  | Returns the filename for the source code if applicable | 
| 784 |  |  |  |  |  |  | (PPI::Document::File) or C<undef> otherwise (PPI::Document). | 
| 785 |  |  |  |  |  |  |  | 
| 786 |  |  |  |  |  |  |  | 
| 787 |  |  |  |  |  |  | =item C<< isa( $classname ) >> | 
| 788 |  |  |  |  |  |  |  | 
| 789 |  |  |  |  |  |  | To be compatible with other modules that expect to get a | 
| 790 |  |  |  |  |  |  | PPI::Document, the Perl::ToPerl6::Document class masquerades as the | 
| 791 |  |  |  |  |  |  | PPI::Document class. | 
| 792 |  |  |  |  |  |  |  | 
| 793 |  |  |  |  |  |  |  | 
| 794 |  |  |  |  |  |  | =item C<< highest_explicit_perl_version() >> | 
| 795 |  |  |  |  |  |  |  | 
| 796 |  |  |  |  |  |  | Returns a L<version|version> object for the highest Perl version | 
| 797 |  |  |  |  |  |  | requirement declared in the document via a C<use> or C<require> | 
| 798 |  |  |  |  |  |  | statement.  Returns nothing if there is no version statement. | 
| 799 |  |  |  |  |  |  |  | 
| 800 |  |  |  |  |  |  |  | 
| 801 |  |  |  |  |  |  | =item C<< uses_module($module_or_pragma_name) >> | 
| 802 |  |  |  |  |  |  |  | 
| 803 |  |  |  |  |  |  | Answers whether there is a C<use>, C<require>, or C<no> of the given name in | 
| 804 |  |  |  |  |  |  | this document.  Note that there is no differentiation of modules vs. pragmata | 
| 805 |  |  |  |  |  |  | here. | 
| 806 |  |  |  |  |  |  |  | 
| 807 |  |  |  |  |  |  |  | 
| 808 |  |  |  |  |  |  | =item C<< process_annotations() >> | 
| 809 |  |  |  |  |  |  |  | 
| 810 |  |  |  |  |  |  | Causes this Document to scan itself and mark which lines & | 
| 811 |  |  |  |  |  |  | transformers are disabled by the C<"## no mogrify"> annotations. | 
| 812 |  |  |  |  |  |  |  | 
| 813 |  |  |  |  |  |  |  | 
| 814 |  |  |  |  |  |  | =item C<< line_is_disabled_for_transformer($line, $transformer_object) >> | 
| 815 |  |  |  |  |  |  |  | 
| 816 |  |  |  |  |  |  | Returns true if the given C<$transformer_object> or C<$transformer_name> has | 
| 817 |  |  |  |  |  |  | been disabled for at C<$line> in this Document.  Otherwise, returns false. | 
| 818 |  |  |  |  |  |  |  | 
| 819 |  |  |  |  |  |  |  | 
| 820 |  |  |  |  |  |  | =item C<< add_annotation( $annotation ) >> | 
| 821 |  |  |  |  |  |  |  | 
| 822 |  |  |  |  |  |  | Adds an C<$annotation> object to this Document. | 
| 823 |  |  |  |  |  |  |  | 
| 824 |  |  |  |  |  |  |  | 
| 825 |  |  |  |  |  |  | =item C<< annotations() >> | 
| 826 |  |  |  |  |  |  |  | 
| 827 |  |  |  |  |  |  | Returns a list containing all the | 
| 828 |  |  |  |  |  |  | L<Perl::ToPerl6::Annotation|Perl::ToPerl6::Annotation>s that | 
| 829 |  |  |  |  |  |  | were found in this Document. | 
| 830 |  |  |  |  |  |  |  | 
| 831 |  |  |  |  |  |  |  | 
| 832 |  |  |  |  |  |  | =item C<< add_suppressed_transformation($transformation) >> | 
| 833 |  |  |  |  |  |  |  | 
| 834 |  |  |  |  |  |  | Informs this Document that a C<$transformation> was found but not reported | 
| 835 |  |  |  |  |  |  | because it fell on a line that had been suppressed by a C<"## no mogrify"> | 
| 836 |  |  |  |  |  |  | annotation. Returns C<$self>. | 
| 837 |  |  |  |  |  |  |  | 
| 838 |  |  |  |  |  |  |  | 
| 839 |  |  |  |  |  |  | =item C<< suppressed_transformations() >> | 
| 840 |  |  |  |  |  |  |  | 
| 841 |  |  |  |  |  |  | Returns a list of references to all the | 
| 842 |  |  |  |  |  |  | L<Perl::ToPerl6::Transformation|Perl::ToPerl6::Transformation>s | 
| 843 |  |  |  |  |  |  | that were found in this Document but were suppressed. | 
| 844 |  |  |  |  |  |  |  | 
| 845 |  |  |  |  |  |  |  | 
| 846 |  |  |  |  |  |  | =item C<< is_program() >> | 
| 847 |  |  |  |  |  |  |  | 
| 848 |  |  |  |  |  |  | Returns whether this document is considered to be a program. | 
| 849 |  |  |  |  |  |  |  | 
| 850 |  |  |  |  |  |  |  | 
| 851 |  |  |  |  |  |  | =item C<< is_module() >> | 
| 852 |  |  |  |  |  |  |  | 
| 853 |  |  |  |  |  |  | Returns whether this document is considered to be a Perl module. | 
| 854 |  |  |  |  |  |  |  | 
| 855 |  |  |  |  |  |  | =back | 
| 856 |  |  |  |  |  |  |  | 
| 857 |  |  |  |  |  |  | =head1 AUTHOR | 
| 858 |  |  |  |  |  |  |  | 
| 859 |  |  |  |  |  |  | Chris Dolan <cdolan@cpan.org> | 
| 860 |  |  |  |  |  |  |  | 
| 861 |  |  |  |  |  |  | =head1 COPYRIGHT | 
| 862 |  |  |  |  |  |  |  | 
| 863 |  |  |  |  |  |  | Copyright (c) 2006-2011 Chris Dolan. | 
| 864 |  |  |  |  |  |  |  | 
| 865 |  |  |  |  |  |  | This program is free software; you can redistribute it and/or modify | 
| 866 |  |  |  |  |  |  | it under the same terms as Perl itself.  The full text of this license | 
| 867 |  |  |  |  |  |  | can be found in the LICENSE file included with this module. | 
| 868 |  |  |  |  |  |  |  | 
| 869 |  |  |  |  |  |  | =cut | 
| 870 |  |  |  |  |  |  |  | 
| 871 |  |  |  |  |  |  | ############################################################################## | 
| 872 |  |  |  |  |  |  | # Local Variables: | 
| 873 |  |  |  |  |  |  | #   mode: cperl | 
| 874 |  |  |  |  |  |  | #   cperl-indent-level: 4 | 
| 875 |  |  |  |  |  |  | #   fill-column: 78 | 
| 876 |  |  |  |  |  |  | #   indent-tabs-mode: nil | 
| 877 |  |  |  |  |  |  | #   c-indentation-style: bsd | 
| 878 |  |  |  |  |  |  | # End: | 
| 879 |  |  |  |  |  |  | # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : |