File Coverage

lib/Devel/PerlySense/Document/Meta.pm
Criterion Covered Total %
statement 186 186 100.0
branch 71 76 93.4
condition 45 49 91.8
subroutine 23 23 100.0
pod 8 8 100.0
total 333 342 97.3


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Devel::PerlySense::Document::Meta - Document information generated
4             during a parse
5              
6             =cut
7              
8              
9              
10              
11              
12 63     63   240 use strict;
  63         90  
  63         1886  
13 63     63   235 use warnings;
  63         79  
  63         1556  
14 63     63   237 use utf8;
  63         89  
  63         311  
15              
16             package Devel::PerlySense::Document::Meta;
17              
18              
19              
20              
21              
22              
23 63     63   2330 use Spiffy -Base;
  63         71  
  63         295  
24 63     63   120333 use Carp;
  63     63   149  
  63     63   1454  
  63         210  
  63         137  
  63         1547  
  63         771  
  63         169  
  63         3661  
25 63     63   259 use File::Basename;
  63         87  
  63         3805  
26 63     63   347 use Path::Class;
  63         118  
  63         2694  
27 63     63   232 use Data::Dumper;
  63         61  
  63         2242  
28 63     63   245 use PPI::Document;
  63         87  
  63         1625  
29 63     63   20904 use PPI::Dumper;
  63         62271  
  63         5421  
30              
31              
32              
33              
34              
35             =head1 PROPERTIES
36              
37             =head2 raPackage
38              
39             Package declarations.
40              
41             Array ref with cloned PPI::Statement::Package objects.
42              
43             Default: []
44              
45             =cut
46             field "raPackage" => [];
47              
48              
49              
50              
51              
52             =head2 raNameModuleUse
53              
54             Array ref with module names that are "use"d.
55              
56             Default: []
57              
58             =cut
59             field "raNameModuleUse" => [];
60              
61              
62              
63              
64              
65             =head2 raNameModuleBase
66              
67             Array ref with module names that are base classes.
68              
69             Default: []
70              
71             =cut
72             field "raNameModuleBase" => [];
73              
74              
75              
76              
77              
78             =head2 rhRowColModule
79              
80             Module names.
81              
82             Hash ref with (keys: row, values:
83             hash ref with (keys: col, values:
84             hash with keys:
85             oNode => cloned PPI::Node objects
86             module => module name string
87             )
88             )
89             )
90              
91             rhRowColModule->{43}->{2}-> node
92              
93             Default: {}
94              
95             =cut
96             field "rhRowColModule" => {};
97              
98              
99              
100              
101              
102             =head2 rhRowColMethod
103              
104             Method calls.
105              
106             Hash ref with (keys: row, values:
107             hash ref with (keys: col, values:
108             {
109             oNode => cloned PPI::Node object,
110             oNodePrev => node to the left of the ->
111             }
112             )
113             )
114              
115             rhRowColModule->{43}->{2}-> node
116              
117             Default: {}
118              
119             =cut
120             field "rhRowColMethod" => {};
121              
122              
123              
124              
125              
126             =head2 raLocationPod
127              
128             POD blocks.
129              
130             Array ref with Location objects, representing each pod chunk that is a
131             heading/item. They have the following properties:
132              
133             podSection
134             pod
135              
136             Default: []
137              
138             =cut
139             field "raLocationPod" => [];
140              
141              
142              
143              
144              
145             =head2 raLocationSub
146              
147             sub definition.
148              
149             Array ref with Location objects, representing each sub
150             declaration. They have the following properties:
151              
152             nameSub
153             source
154             namePackage
155             oLocationEnd
156              
157             Default: []
158              
159             =cut
160             field "raLocationSub" => [];
161              
162              
163              
164              
165              
166              
167              
168              
169             =head2 aPluginSyntax
170              
171             Array ref with Devel::PerlySense::Plugin::Syntax objects.
172              
173             Return whatever plugins under Devel::PerlySense::Plugin::Syntax::* are
174             found.
175              
176             Readonly.
177              
178             =cut
179              
180             use Module::Pluggable (
181 63         717 sub_name => "raPluginSyntax",
182             search_path => [ "Devel::PerlySense::Plugin::Syntax" ],
183             instantiate => "new",
184 63     63   287 );
  63         74  
185              
186             my $raPluginSyntax;
187 327     327 1 849 sub aPluginSyntax {
188 327   100     1353 $raPluginSyntax ||= [ $self->raPluginSyntax ];
189 327         52479 return @$raPluginSyntax;
190             }
191              
192              
193              
194              
195              
196             =head1 API METHODS
197              
198             =head2 new()
199             Create new empty Meta object
200              
201             =cut
202             sub new(@) {
203 326     326 1 496 my $pkg = shift;
204              
205 326         945 my $self = bless {}, $pkg;
206              
207 326         619 return($self);
208             }
209              
210              
211              
212              
213              
214             =head2 parse($oDocument)
215              
216             Parse the Devel::PerlySense::Document and extract metadata. Fill
217             appropriate data structures.
218              
219             Return 1 or die on errors.
220              
221             =cut
222             sub _setRowColNodeModule(\%$$$$) {
223 6054     6054   21564 my ($rhRowCol, $row, $col, $oNode, $module) = @_;
224              
225 6054         29739 $rhRowCol->{$row}->{$col} = {
226             oNode => $oNode,
227             module => $module,
228             };
229              
230 6054         12190 return;
231             }
232              
233 325     325 1 470 sub parse {
234 325         405 my ($oDocument) = @_;
235             #PPI::Dumper->new($oDocument->oDocument)->print; use PPI::Dumper;
236              
237 325         392 my @aToken;
238 325         353 my @aPackage;
239 325         331 my %hNameModuleUse;
240 325         316 my %hNameModuleBase;
241 325         396 my %hRowColModule;
242 325         328 my %hRowColMethod;
243 325         297 my @aLocationPod;
244 325         348 my @aPodHeadingCurrent;
245 325         592 my $packageCurrent = "main";
246 325         8010 my $rhDataDocument = {
247             raPackage => \@aPackage,
248             rhNameModuleUse => \%hNameModuleUse,
249             rhNameModuleBase => \%hNameModuleBase,
250             rhRowColModule => \%hRowColModule,
251             rhRowColMethod => \%hRowColMethod,
252             raLocationPod => \@aLocationPod,
253             };
254              
255             #Optimization, avoid the method call inside the loop
256 325         952 my @aPluginSyntax = $self->aPluginSyntax();
257              
258             $oDocument->aDocumentFind(
259             sub {
260 514745     514745   4307203 my ($oTop, $oNode) = @_;
261 514745 50       947092 my $oLocation = $oNode->location or return(0);
262 514745         4611066 eval {
263              
264 514745         526616 my ($row, $col) = ($oLocation->[0], $oLocation->[1]);
265              
266             #Optimization: compare against the string instead of
267             #doing insanely many ->isa(). This is slightly fragile
268             #wrt changes in subclasses in PPI.
269 514745         481156 my $pkgNode = ref($oNode);
270              
271              
272              
273             #Collect tokens
274 514745 100 66     1732065 if($pkgNode =~ /^PPI::Token/ && $oNode->location) {
275 423802 100 100     4429663 if($pkgNode =~ /^PPI::Token::QuoteLike/ || $pkgNode =~ /^PPI::Token::Quote/) {
276 5230         6894 push(@aToken, $oNode);
277             } else {
278             #...we're only interested in nodes which are single words
279 418572 100       719152 if( $oNode !~ /\s/) {
280 243702         1050651 push(@aToken, $oNode);
281             }
282             }
283             }
284              
285              
286              
287              
288             #package
289 514745 100       1651421 if($pkgNode eq "PPI::Statement::Package") {
290 323         650 push(@aPackage, $oNode);
291 323         1714 $packageCurrent = $oNode->namespace;
292             }
293              
294              
295              
296             #use
297 514745 100       716430 if($pkgNode eq "PPI::Statement::Include") {
298 3104 100       6474 $hNameModuleUse{$1}++ if($oNode =~ /^ use \s+ ( [A-Z][\w:]* ) /xs);
299             }
300              
301              
302              
303              
304             #base class
305              
306             # use base
307 514745 100       771893 if($pkgNode eq "PPI::Statement::Include") {
308 3104 100       5185 if($oNode =~ /^ use \s+ (?:base|parent) \s+ (?:qw)? \s* (.+);$/xs) {
309 157         3709 my $modules = $1;
310 157         710 for my $module (grep { $_ ne "qw" } $modules =~ /([\w:]+)/gs) {
  169         529  
311 169         757 $hNameModuleBase{$module}++ ;
312             }
313              
314             }
315             }
316              
317             # @ISA = ...
318             ## fragile: stuff to the right...
319 514745 100 100     920316 if($pkgNode eq "PPI::Token::Symbol" && $oNode eq '@ISA') {
320 25         447 my $oStatement = $oNode->statement;
321              
322             ###TODO: ignore module names with interpolated variables
323 25 100       487 if($oStatement =~ /\@ISA \s* = \s* (.+);$/xs) {
324 17         649 my $modules = $1;
325 17         117 for my $module (grep { $_ ne "qw" } $modules =~ /([\w:]+)/gs) {
  34         71  
326 29         75 $hNameModuleBase{$module}++ ;
327             }
328             }
329             }
330              
331             #push(@ISA, )
332             ## fragile: "push() if(sdfkjs)" doesn't work
333 514745 100 100     1206849 if($pkgNode eq "PPI::Token::Symbol" && $oNode eq '@ISA' && @aToken > 2) {
      66        
334 25         350 my $prev = -1; #last one is the '@ISA'
335              
336 25 100 66     61 if($aToken[--$prev] eq "push" || $aToken[--$prev] eq "push") {
337 8         1276 my $oStatement = $oNode->parent->parent;
338 8 50       129 $oStatement =~ /\@ISA \s* , \s* (.+)/xs or next;
339 8         562 my $modules = $1;
340              
341 8         66 $hNameModuleBase{$_}++ for($modules =~ /([\w:]+)/gs);
342             }
343             }
344              
345              
346              
347              
348             #module
349 514745 100 100     1667932 if(
    100          
350             $pkgNode eq "PPI::Token::Word" &&
351             $oNode =~ /^[A-Z][\w:]*$/ #Word chars and ::, Starts with uppercase, is pragma or number
352             ) {
353 7525 100 100     63593 if( ! ($aToken[-2]->isa("PPI::Token::Operator") && $aToken[-2] eq "->") ) {
354 5654         18740 _setRowColNodeModule(%hRowColModule, $row, $col, $oNode, "$oNode");
355             }
356             }
357             elsif(
358             $pkgNode =~ /^PPI::Token::Quote::/
359             # || $pkgNode =~ /^PPI::Token::QuoteLike/ ##TODO: enable when PPI gets "string" method on these classes
360             ) {
361 4964         16442 my $module = $oNode->string;
362 4964 100       51628 if($module =~ /^ [A-Z]\w* (?: :: [A-Z]\w* )+ $/x) {
    100          
363             #Well formed, likely module, i.e. at least one :: separator
364 345         1329 _setRowColNodeModule(%hRowColModule, $row, $col, $oNode, $module);
365             }
366             elsif($module =~ /^[A-Z][\w]*$/) {
367             #Check whether there is a file anywhere matching the name (because only the string contents is a weak indicator of module-ness).
368 517 100       2398 if($oDocument->fileFindModule(nameModule => $module)) {
369 55         750 _setRowColNodeModule(%hRowColModule, $row, $col, $oNode, $module);
370             }
371             }
372             }
373              
374              
375              
376              
377             #method
378 514745 100 100     1161509 if($pkgNode eq "PPI::Token::Word" && @aToken > 2) {
379 59001         98148 my ($oObject, $oOperator) = @aToken[-3, -2];
380 59001 100 100     239075 if($oOperator->isa("PPI::Token::Operator") && $oOperator eq "->") {
381 17493 100 100     278748 $oObject->isa("PPI::Token::Symbol") || $oObject->isa("PPI::Token::Word") or $oObject = undef;
382             #print "$row/$col: ($oObject$oOperator$oNode)\n";
383 17493         98221 $hRowColMethod{$row}->{$col} = {
384             oNode => $oNode,
385             oNodeObject => $oObject,
386             };
387             }
388              
389             }
390              
391              
392              
393             #pod
394 514745 100       714069 if($pkgNode eq "PPI::Token::Pod") {
395 4838         49257 $self->parsePod($oDocument, $oNode, \@aLocationPod, \@aPodHeadingCurrent);
396             }
397              
398              
399              
400             #sub
401 514745         407755 my $nameSub = "";
402 514745 100 100     765924 $pkgNode eq "PPI::Statement::Sub" && !$oNode->forward and $nameSub = $oNode->name;
403 514745 100       825120 $pkgNode eq "PPI::Statement::Scheduled" and $nameSub = $oNode->type;
404 514745 100       617812 if($nameSub) {
405 3359         112574 push(
406 3359         4340 @{$self->raLocationSub},
407             $self->oLocationSub(
408             $oDocument,
409             $oNode,
410             $nameSub,
411             $packageCurrent,
412             ),
413             );
414             }
415              
416              
417 514745         568830 for my $plugin (@aPluginSyntax) {
418             #TODO: Set new $packageCurrent if needed
419 512157         1088174 $plugin->parse(
420             rhDataDocument => $rhDataDocument,
421             oMeta => $self,
422             oDocument => $oDocument,
423             oNode => $oNode,
424             pkgNode => $pkgNode,
425             row => $row,
426             col => $col,
427             packageCurrent => $packageCurrent,
428             raToken => \@aToken,
429             );
430             }
431             };
432 514745 50       716726 $@ and warn($@);
433              
434 514745         1094224 return(0);
435 325         5258 });
436              
437 325         28735 $self->raPackage(\@aPackage);
438 325         14989 $self->raNameModuleUse([sort keys %hNameModuleUse]);
439 325         10884 $self->raNameModuleBase([sort keys %hNameModuleBase]);
440 325         10322 $self->rhRowColModule(\%hRowColModule);
441 325         10386 $self->rhRowColMethod(\%hRowColMethod);
442 325         10423 $self->raLocationPod(\@aLocationPod);
443              
444 325         38866 return(1);
445             }
446              
447              
448              
449              
450              
451             =head2 moduleAt(row => $row, col => $col)
452              
453             Find the module mentioned on line $row (1..) at $col (1..).
454              
455             Return string like "My::Module" or "Module", or undef if none was
456             found.
457              
458             =cut
459 37     37 1 133 sub moduleAt {
460 37         103 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
461 37 100       872 my $rhToken = $self->rhTokenOfAt($self->rhRowColModule, $row, $col) or return(undef);
462 12         53 return( $rhToken->{module} );
463             }
464              
465              
466              
467              
468              
469             =head2 rhMethodAt(row => $row, col => $col)
470              
471             Find the module mentioned on line $row (1..) at $col (1..).
472              
473             Return hash ref with { oNode, oNodeObject } or undef if none was
474             found.
475              
476             =cut
477 84     84 1 320 sub rhMethodAt {
478 84         224 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
479 84         1967 return($self->rhTokenOfAt($self->rhRowColMethod, $row, $col));
480             }
481              
482              
483              
484              
485              
486             =head2 rhTokenOfAt($rhRowCol, $row, $col)
487              
488             Find the token mentioned in $rhRowCol on line $row (1..) at $col (1..).
489              
490             Return hash ref with keys oNode and possibly oNodeObject, or undef if
491             none was found.
492              
493             =cut
494 121     121 1 540 sub rhTokenOfAt {
495 121         128 my ($rhRowCol, $row, $col) = @_;
496              
497 121 100       435 my $rhCol = $rhRowCol->{$row} or return(undef);
498 65         173 for my $colToken (keys %$rhCol) {
499 92         86 my $rhToken = $rhCol->{$colToken};
500 92         100 my $oNode = $rhToken->{oNode};
501 92         304 my $colTokenEnd = $colToken + length($oNode);
502 92 100 100     636 if($col >= $colToken && $col < $colTokenEnd) {
503 53         199 return($rhToken);
504             }
505             }
506              
507 12         39 return(undef);
508             }
509              
510              
511              
512              
513              
514             =head2 parsePod($oDocument, $oNode, $raLocationPod, $raPodHeadingCurrent)
515              
516             Parse $oNode and add one or more Location objects to $raLocationPod.
517              
518             Add pod chunks that are =head or =item. Prefix the pod chunks with
519             their immediate pod heading level.
520              
521             Return 1 on success, die on errors.
522              
523             =cut
524 4838     4838 1 6303 sub parsePod {
525 4838         7573 my ($oDocument, $oNode, $raLocationPod, $raPodHeadingCurrent) = @_;
526              
527 4838         17645 my @aLine = split(/\n/, $oNode);
528 4838         43675 my $lineCur = -1;
529 4838         6504 for my $line (@aLine) {
530 52437         34528 $lineCur++;
531              
532 52437 100       220351 if($line =~ /^ (?: =head(\d+)\b ) | (?: =item\b )/x) {
533 7033   100     27808 my $headingLevel = $1 || 0;
534 7033 100       10007 if($headingLevel) {
535 6714 100       19801 @$raPodHeadingCurrent > $headingLevel and splice(@$raPodHeadingCurrent, $headingLevel); #Remove everything below this heading
536 6714         13986 $raPodHeadingCurrent->[$headingLevel - 1] = $line;
537             }
538              
539 7033         11114 my $podSection = "";
540 7033         6418 my $level = 0;
541 7033         10845 for my $heading (@$raPodHeadingCurrent) {
542 12035 50       18878 defined($heading) or $heading = ""; # Silence undef warning, is this the right thing to do?
543 12035 100 100     38579 ($level < $headingLevel - 1) || ($headingLevel == 0) and $podSection .= "$heading\n\n";
544 12035         16897 $level++;
545             }
546              
547              
548 7033         11921 my $pod = "$line\n";
549 7033         10060 my $linePod = $lineCur + 1;
550 7033   66     27450 while(defined($aLine[$linePod]) && $aLine[$linePod] !~ /^=/) {
551 40133         140421 $pod .= $aLine[$linePod++] . "\n";
552             }
553              
554 7033         253332 my $oLocation = Devel::PerlySense::Document::Location->new(
555             file => $oDocument->file,
556             row => $oNode->location->[0] + $lineCur,
557             col => 1,
558             );
559 7033         182785 $oLocation->rhProperty->{pod} = $pod;
560 7033         218700 $oLocation->rhProperty->{podSection} = $podSection;
561              
562 7033         52300 push(@$raLocationPod, $oLocation);
563             }
564             }
565              
566 4838         18208 return(1);
567             }
568              
569              
570              
571              
572              
573             =head2 oLocationSub($oDocument, $oNode, $nameSub, $packageCurrent)
574              
575             Create a Document::Location object from the sub $nameSub consisting of
576             $oNode, found in $oDocument in $packageCurrent.
577              
578             Set appropriate Location->rhProperty keys:
579              
580             nameSub
581             source
582             namePackage
583             oLocationEnd
584              
585             Return the new Location object.
586              
587             =cut
588 3359     3359 1 28464 sub oLocationSub {
589 3359         8919 my ($oDocument, $oNode, $nameSub, $packageCurrent) = @_;
590              
591 3359         87605 my $oLocation = Devel::PerlySense::Document::Location->new(
592             file => $oDocument->file,
593             row => $oNode->location->[0],
594             col => $oNode->location->[1],
595             );
596 3359         89044 $oLocation->rhProperty->{nameSub} = $nameSub;
597 3359         26749 $oLocation->rhProperty->{source} = "$oNode";
598 3359         1883134 $oLocation->rhProperty->{namePackage} = $packageCurrent;
599              
600              
601 3359         36302 my $countNewline =()= $oNode =~ /\n/g;
602 3359         1414389 my ($rowEnd, $colEnd) = ($oNode->location->[0] + $countNewline, 1);
603 3359 100       50799 if ($countNewline) {
604 3343 50       6964 $oNode =~ /\n([^\n]+?)\z/ and $colEnd += length($1);
605             } else {
606 16         34 $colEnd = length($oNode);
607             }
608              
609 3359         1558341 my $oLocationEnd = Devel::PerlySense::Document::Location->new(
610             file => $oDocument->file,
611             row => $rowEnd,
612             col => $colEnd,
613             );
614 3359         89460 $oLocation->rhProperty->{oLocationEnd} = $oLocationEnd;
615              
616 3359         21370 return($oLocation);
617             }
618              
619              
620              
621              
622              
623             1;
624              
625              
626              
627              
628              
629             __END__
630              
631             =encoding utf8
632              
633             =head1 AUTHOR
634              
635             Johan Lindström, C<< <johanl[ÄT]DarSerMan.com> >>
636              
637             =head1 BUGS
638              
639             Please report any bugs or feature requests to
640             C<bug-devel-perlysense@rt.cpan.org>, or through the web interface at
641             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Devel-PerlySense>.
642             I will be notified, and then you'll automatically be notified of progress on
643             your bug as I make changes.
644              
645             =head1 ACKNOWLEDGEMENTS
646              
647             =head1 COPYRIGHT & LICENSE
648              
649             Copyright 2005 Johan Lindström, All Rights Reserved.
650              
651             This program is free software; you can redistribute it and/or modify it
652             under the same terms as Perl itself.
653              
654             =cut