File Coverage

lib/Devel/PerlySense/Document.pm
Criterion Covered Total %
statement 319 325 98.1
branch 90 106 84.9
condition 22 29 75.8
subroutine 51 52 98.0
pod 33 33 100.0
total 515 545 94.5


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Devel::PerlySense::Document - A Perl file/document
4              
5             =head1 SYNOPSIS
6              
7              
8              
9              
10             =head1 DESCRIPTION
11              
12             The document contains a PPI parsed document, etc. along with a
13             metadata object.
14              
15              
16             =head2 Caching
17              
18             Caching is done on a per file + mod timestamp basis. Things that are
19             cached are: PPI documents, Document::Api and Document::Meta objects.
20              
21             Currently Cache::Cache is used. This isn't great (duh), since there is
22             no good way to expire obsolete files.
23              
24              
25             =cut
26              
27              
28              
29              
30              
31 63     63   239 use strict;
  63         84  
  63         1799  
32 63     63   220 use warnings;
  63         79  
  63         1716  
33 63     63   6871 use utf8;
  63         189  
  63         305  
34              
35             package Devel::PerlySense::Document;
36              
37              
38              
39              
40              
41 63     63   8483 use Spiffy -Base;
  63         90331  
  63         289  
42 63     63   243346 use Carp;
  63     63   88  
  63     63   1811  
  63         224  
  63         106  
  63         1410  
  63         222  
  63         75  
  63         3490  
43 63     63   5081 use Data::Dumper;
  63         50757  
  63         2994  
44 63     63   9650 use PPI 1.003;
  63         2092650  
  63         1445  
45 63     63   286 use File::Basename;
  63         75  
  63         3705  
46 63     63   232 use List::MoreUtils qw/ uniq /;
  63         93  
  63         2801  
47              
48 63     63   15561 use Devel::PerlySense;
  63         101  
  63         369  
49 63     63   13554 use Devel::PerlySense::Util;
  63         85  
  63         3758  
50 63     63   242 use Devel::PerlySense::Util::Log;
  63         135  
  63         2332  
51 63     63   17404 use Devel::PerlySense::Document::Location;
  63         1727  
  63         517  
52 63     63   27643 use Devel::PerlySense::Document::Api;
  63         107  
  63         447  
53 63     63   38630 use Devel::PerlySense::Document::Meta;
  63         105  
  63         495  
54              
55 63     63   13795 use Devel::TimeThis;
  63         87  
  63         261400  
56              
57              
58              
59              
60              
61             =head1 PROPERTIES
62              
63             =head2 oPerlySense
64              
65             Devel::PerlySense object.
66              
67             Default: set during new()
68              
69             =cut
70             field "oPerlySense" => undef;
71              
72              
73              
74              
75              
76             =head2 file
77              
78             The absolute file name of the parsed file, or "" if none was parsed.
79              
80             Default: ""
81              
82             =cut
83             field "file" => "";
84              
85              
86              
87              
88              
89             =head2 oDocument
90              
91             The PPI::Document object from the parse(), or undef if none was
92             parsed.
93              
94             Default: undef
95              
96             =cut
97             field "oDocument" => undef;
98             # sub oDocument {
99             # @_ or (Carp::longmess =~ /Document::parse/s or cluck("\n\n\n\n\nODOCUMENT FOR (" . $self->file . ")\n"));
100             # use Carp qw/cluck/;
101              
102             # @_ and $self->{odocument} = $_[0];
103              
104             # $self->{odocument};
105             # }
106              
107              
108              
109              
110              
111             =head2 oMeta
112              
113             The Devel::PerlySense::Document::Meta object from the parse(), or
114             undef if none was parsed.
115              
116             Default: undef
117              
118             =cut
119             field "oMeta" => undef;
120              
121              
122              
123              
124              
125             =head2 rhPackageApiLikely
126              
127             Hash ref with (keys: package names; Document::Api objects).
128              
129             Default: {}
130              
131             =cut
132             field "rhPackageApiLikely" => {};
133              
134              
135              
136              
137              
138             =head1 API METHODS
139              
140             =head2 new(oPerlySense => $oPerlySense)
141              
142             Create new PearlySense::Document object. Associate it with $oPerlySense.
143              
144             =cut
145 335     335 1 1258 sub new {
146 335         1696 my ($oPerlySense) = Devel::PerlySense::Util::aNamedArg(["oPerlySense"], @_);
147              
148 335         1363 $self = bless {}, $self; #Create the object. It looks weird because of Spiffy
149 335         10167 $self->oPerlySense($oPerlySense);
150              
151 335         2588 return($self);
152             }
153              
154              
155              
156              
157              
158             =head2 fileFindModule(nameModule => $nameModule)
159              
160             Find the file containing the $nameModule given the file property of
161             the document.
162              
163             Return the absolute file name, or undef if none could be found. Die on
164             errors.
165              
166             =cut
167 517     517 1 663 sub fileFindModule {
168 517         2177 my ($nameModule) = Devel::PerlySense::Util::aNamedArg(["nameModule"], @_);
169              
170 517 50       28018 my $file = $self->file or return(undef);
171              
172             return(
173 517         16321 $self->oPerlySense->fileFindModule(
174             nameModule => $nameModule,
175             dirOrigin => dirname($self->file)
176             )
177             );
178             }
179              
180              
181              
182              
183              
184             =head2 parse(file => $file)
185              
186             Parse the $file and store the metadata.
187              
188             Return 1 on success, else die.
189              
190             Cached on the usual.
191              
192             =cut
193             ###TODO: Rearrange these so they are write cached here, but read
194             ###cached on first access instead.
195 337     337 1 446 sub parse {
196 337         1092 my ($file) = Devel::PerlySense::Util::aNamedArg(["file"], @_);
197              
198 336         647 my $keyCache = "document";
199 336 100       1086 if(my $oDocument = $self->cacheGet($keyCache, $file)) {
200 9         474 $self->oDocument($oDocument);
201             } else {
202 327         1051 $self->parse0(file => $file);
203 325         7976 $self->cacheSet($keyCache, $file, $self->oDocument);
204             }
205              
206 334         11217 $self->file($file);
207              
208              
209 334         3273 $keyCache = "document-meta";
210 334 100       877 if(my $oMeta = $self->cacheGet($keyCache, $file)) {
211 9         298 $self->oMeta($oMeta);
212             } else {
213 325         3755 $oMeta = Devel::PerlySense::Document::Meta->new();
214              
215 325         1241 $oMeta->parse($self);
216              
217 325         8700 $self->oMeta($oMeta);
218 325         9621 $self->cacheSet($keyCache, $file, $self->oMeta);
219             }
220              
221 334         3624 return(1);
222             }
223              
224              
225              
226              
227              
228             =head2 parse0(file => $file)
229              
230             Parse the $file and store the metadata.
231              
232             Return 1 on success, else die.
233              
234             =cut
235 327     327 1 499 sub parse0 {
236 327         1110 my ($file) = Devel::PerlySense::Util::aNamedArg(["file"], @_);
237             #print " Parsing: ((($file)))\n";
238 327 100       3107 my $oDocument = PPI::Document->new($file) or die("Could not parse file ($file): " . PPI::Document->errstr . "\n");
239 325         44342632 $oDocument->index_locations();
240              
241 325         9037059 $self->oDocument($oDocument);
242              
243 325         4500 return(1);
244             }
245              
246              
247              
248              
249              
250             =head2 aNamePackage()
251              
252             Return list of package names in this document.
253              
254             =cut
255 60     60 1 93 sub aNamePackage {
256 60         111 return( sort uniq map { $_->namespace } @{$self->oMeta->raPackage} );
  58         1899  
  60         1443  
257             }
258              
259              
260              
261              
262              
263             =head2 aNameBase()
264              
265             Return list of names of modules that are base classes, according to
266             either "use base" or an assignment to @ISA.
267              
268             Dir on errors.
269              
270             =cut
271 199     199 1 466 sub aNameBase {
272              
273             #TODO: Should be centralized in PerlySense and made configurable
274 199         399 my %hStop = map { $_ => 1 } qw(Exporter DynaLoader);
  398         1140  
275              
276 199 100       768 my @aBase = grep { (! $hStop{$_}) && $_ =~ /[A-Z]/ } @{$self->oMeta->raNameModuleBase};
  184         5166  
  199         5264  
277              
278 199         2829 return(@aBase);
279             }
280              
281              
282              
283              
284              
285             =head2 hasBaseClass($nameClass)
286              
287             Return true if $nameClass is an immediate base class to this one, else
288             false.
289              
290             =cut
291 20     20 1 28 sub hasBaseClass {
292 20         31 my ($nameClass) = @_;
293              
294 20         26 return( (grep { $_ eq $nameClass } @{$self->oMeta->raNameModuleBase}) > 0 );
  14         378  
  20         499  
295             }
296              
297              
298              
299              
300              
301             =head2 aNameModuleUse()
302              
303             Find modules that are used in this document.
304              
305             Don't find pragmas. Don't find very common infrastructure
306             modules. Only report modules used in this actual document.
307              
308             Return list of unique module names.
309              
310             Dir on errors.
311              
312             =cut
313 9     9 1 13 sub aNameModuleUse {
314              
315 9         13 my %hStop = map { $_ => 1 } qw(Exporter DynaLoader); #TODO: Should be centralized in PerlySense and made configurable
  18         49  
316 9         21 my @aModule = grep { (! $hStop{$_}) } @{$self->oMeta->raNameModuleUse};
  47         331  
  9         221  
317              
318 9         93 return(@aModule);
319             }
320              
321              
322              
323              
324              
325             =head2 packageAt(row => $row)
326              
327             Return the package name that is active on line $row (1..), or die on
328             errors.
329              
330             =cut
331 25     25 1 36 sub packageAt {
332 25         86 my ($row) = Devel::PerlySense::Util::aNamedArg(["row"], @_);
333 25 100       118 $row > 0 or croak("Parameter row ($row) must be 1..");
334              
335 23 50       754 my @aPackage =
336 23         613 grep { $_->namespace && $_->location->[0] <= $row }
337 23 100       46 @{$self->oMeta->raPackage}
338             or return("main");
339              
340 19         1003 my $oPackage = $aPackage[-1];
341 19         86 return($oPackage->namespace);
342             }
343              
344              
345              
346              
347             =head2 isEmptyAt(row => $row, col => $col)
348              
349             Determine whether the position at $row, $col is empty (ther is no known
350             content, no:
351              
352             modules
353             methods
354             variables?
355              
356             ).
357              
358             Return 1 if empty, else 0.
359              
360             Die on errors.
361              
362             =cut
363 16     16 1 17 sub isEmptyAt {
364 16         40 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
365              
366 16 100       407 $self->oMeta->moduleAt(row => $row, col => $col) and return(0);
367 12 100       274 $self->oMeta->rhMethodAt(row => $row, col => $col) and return(0);
368              
369 11         33 return(1);
370             }
371              
372              
373              
374              
375              
376             =head2 moduleAt(row => $row, col => $col)
377              
378             Find the module mentioned on line $row (1..) at $col (1..). Don't
379             recognize modules that isn't ucfirst(). There may be false positives,
380             if it looks like a module. (examples?)
381              
382             Return string like "My::Module" or "Module", or undef if none was
383             found.
384              
385             Die on errors.
386              
387             =cut
388 21     21 1 24 sub moduleAt {
389 21         63 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
390 21         519 return($self->oMeta->moduleAt(row => $row, col => $col));
391             }
392              
393              
394              
395              
396              
397             =head2 methodCallAt(row => $row, col => $col)
398              
399             Return the method call Perl code is on line $row (1..) at $col (1..),
400             or die on errors.
401              
402             In scalar context, return string like "$self->fooBar". Don't include
403             the parameter list or parens, only the "$object->method".
404              
405             In list context, return two item list with (object, method).
406              
407             The object may be undef/"" if it's an expression rather than a simple
408             variable.
409              
410             Return undef or () if none was found. Die on errors.
411              
412             =cut
413 72     72 1 74 sub methodCallAt {
414 72         304 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
415              
416 72 100       1832 my $rhMethod = $self->oMeta->rhMethodAt(row => $row, col => $col) or return;
417 40         71 my ($oMethod, $oObject) = ($rhMethod->{oNode}, $rhMethod->{oNodeObject});
418              
419 40 100       98 wantarray and return($oObject, $oMethod);
420 8 100       25 return((defined($oObject) ? $oObject : "") . "->$oMethod");
421             }
422              
423              
424              
425              
426              
427             =head2 selfMethodCallAt(row => $row, row => $col)
428              
429             Return the name of the $self->method at $row, $col in this document.
430              
431             If no method call is found, maybe warn and return undef.
432              
433             Die on errors.
434              
435             =cut
436 23     23 1 31 sub selfMethodCallAt {
437 23         98 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
438              
439 23         89 my ($object, $method) = $self->methodCallAt(row => $row, col => $col);
440 23 100       87 $method or return(undef);
441 13 100 66     62 $object and $object eq '$self' or return(undef); #We only know about self so far
442              
443 4         69 return($method);
444             }
445              
446              
447              
448              
449              
450             =head2 moduleMethodCallAt(row => $row, row => $col)
451              
452             Find the My::Module->method call at $row, $col in this document.
453              
454             In list context, return two item list with (module, method). In scalar
455             context, return "My::Module->method".
456              
457             Return undef or () if none was found. Die on errors.
458              
459             =cut
460 22     22 1 29 sub moduleMethodCallAt {
461 22         82 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
462              
463 22         67 my ($module, $method) = $self->methodCallAt(row => $row, col => $col);
464 22 100 66     117 $module && $method or return(undef);
465 12 100       23 $module =~ /[^\w:]/ and return(undef); #only allow bareword modules
466              
467 7 100       68 wantarray() and return($module, $method);
468 2         3 return("$module->$method");
469             }
470              
471              
472              
473              
474              
475             =head2 aObjectMethodCallAt(row => $row, row => $col)
476              
477             Return three item array with (object name, method name, $oLocation of the
478             surrounding sub) of the $self->method at $row, $col in this
479             document. The object may be '$self'.
480              
481             If no method call is found, maybe warn and return ().
482              
483             Die on errors.
484              
485             =cut
486 17     17 1 25 sub aObjectMethodCallAt {
487 17         61 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
488              
489 17         48 my ($oObject, $oMethod) = $self->methodCallAt(row => $row, col => $col);
490 17 100 66     91 $oObject && $oMethod or return();
491 7 50       12 $oObject =~ /^\$\w+$/ or return();
492              
493 7 50       65 my $oLocationSub = $self->oLocationEnclosingSub($oMethod) or return();
494              
495 7         26 return($oObject, $oMethod, $oLocationSub);
496             }
497              
498              
499              
500              
501              
502             =head2 rhRegexExample(row => $row, col => $col)
503              
504             Look in $file at location $row/$col and find the regex located there,
505             and possibly the example comment preceeding it.
506              
507             Return hash ref with (keys: regex, example; values: source
508             string). The source string is an empty string if nothing found.
509              
510             If there is an example string in a comment, return the example without
511             the comment #
512              
513             Die if $file doesn't exist, or on other errors.
514              
515             =cut
516 0     0 1 0 sub rhRegexExample {
517 0         0 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
518            
519 0         0 return { regex => "", example => "" };
520             }
521              
522              
523              
524              
525              
526             =head2 oLocationSub(name => $name, [package => "main"])
527              
528             Return a Devel::PerlySense::Document::Location object with the
529             location of the sub declaration called $name in $package, or undef if
530             it wasn't found.
531              
532             Die on errors.
533              
534             =cut
535 22     22 1 45 sub oLocationSub {
536 22         76 my ($name) = Devel::PerlySense::Util::aNamedArg(["name"], @_);
537 22         59 my (%p) = @_;
538 22   100     66 my $package = $p{package} || "main";
539              
540 22         27 for my $oLocation (@{$self->oMeta->raLocationSub}) {
  22         581  
541             # debug("JPL: " . $oLocation->rhProperty->{nameSub} . " eq $name && " . $oLocation->rhProperty->{namePackage} . " eq $package");
542             # defined $oLocation->rhProperty->{nameSub} or debug("SANITY FAILED: " . Dumper($oLocation));
543             # defined $oLocation->rhProperty->{namePackage} or debug("SANITY FAILED: " . Dumper($oLocation));
544 128 100 100     4336 if( $oLocation->rhProperty->{nameSub} eq $name
545             && $oLocation->rhProperty->{namePackage} eq $package) {
546 15         601 debug("Document->oLocation found ($name) in ($oLocation)");
547 15         60 return($oLocation);
548             }
549             }
550              
551 7         55 return(undef);
552             }
553              
554              
555              
556              
557              
558             =head2 oLocationSubAt(row => $row, col => $col)
559              
560             Return a Devel::PerlySense::Document::Location object with the
561             location of the sub definition at $row/$col, or undef if it row/col
562             isn't inside a sub definition.
563              
564             Note: Currently, col is ignored, and the sub is presumed to occupy the
565             entire row.
566              
567             Die on errors.
568              
569             =cut
570 5     5 1 7 sub oLocationSubAt {
571 5         19 my ($row, $col) = Devel::PerlySense::Util::aNamedArg(["row", "col"], @_);
572              
573 5         7 for my $oLocation (@{$self->oMeta->raLocationSub}) {
  5         145  
574 113 100 100     4266 if( $row >= $oLocation->row
575             && $row <= $oLocation->rhProperty->{oLocationEnd}->row
576             ) {
577 2         110 debug("Sub found at ($row/$col): (" . Dumper($oLocation) . ")");
578 2         30 return($oLocation->clone);
579             }
580             }
581            
582 3         18 return(undef);
583             }
584              
585              
586              
587              
588              
589             =head2 oLocationSubDefinition(name => $name, [row => $row], [package => $package])
590              
591             Return a Devel::PerlySense::Document::Location object with the
592             location of the sub "definition" for $name, or undef if it wasn't
593             found. The definition can be the sub declaration, or a POD entry.
594              
595             If $row is passed, use it to determine which package is active at
596             $row. If $package is passed, use that instead. Default to package
597             "main" if neither is passed.
598              
599             If no definition can be found in this document, and the module has one
600             or more base classes, look in the @ISA (depth-first, just like Perl
601             (see perldoc perltoot)).
602              
603             Warn on some failures to find the location. Die on errors.
604              
605             =cut
606 18     18 1 48 sub oLocationSubDefinition {
607 18         76 my ($name) = Devel::PerlySense::Util::aNamedArg(["name"], @_);
608 18         63 my %p = @_; my ($row, $package) = ($p{row}, $p{package});
  18         43  
609              
610 18 100       48 if(! $package) {
611 11 100       26 if($row) {
612 10 50       36 $package = $self->packageAt(row => $row)
613             or warn("Could not find active package at row ($row)\n"), return(undef);
614             } else {
615 1         2 $package = "main";
616             }
617             }
618 18         400 debug("Document->oLocationSubDefinition name($name) package($package)");
619              
620             #Look for the sub definition
621 18         81 my $oLocation = $self->oLocationSub(name => $name, package => $package);
622 18 100       83 $oLocation and return($oLocation);
623              
624             #Fail to POD in same file
625 6         24 $oLocation = $self->oLocationPod(name => $name, lookFor => "method", ignoreBaseModules => 1);
626 6 100       20 $oLocation and return($oLocation);
627              
628             #Fail to base classes
629 2         10 for my $moduleBase ($self->aNameBase) {
630 2 50       60 my $oDocumentBase = $self->oPerlySense->oDocumentFindModule(
631             nameModule => $moduleBase,
632             dirOrigin => dirname($self->file),
633             ) or debug("Could not find module ($moduleBase)\n"), next;
634 2         17 $oLocation = $oDocumentBase->oLocationSubDefinition(name => $name, package => $moduleBase);
635 2 50       23 $oLocation and return($oLocation);
636             }
637              
638 0         0 return(undef);
639             }
640              
641              
642              
643              
644              
645             =head2 oLocationPod(name => $name, lookFor => $lookFor, [ignoreBaseModules => 0])
646              
647             Return a Devel::PerlySense::Document::Location object with the "best"
648             location of the pod =head? or =item where $name is present, or undef
649             if it wasn't found.
650              
651             $lookFor can be "method", i.e. what the search was looking for.
652              
653             If $lookFor is "method" and the POD isn't found, try in the base
654             classes, unless $ignoreBaseModules is true.
655              
656             If the method POD is found in a base class, make sure that notice is
657             in the rhProperty->{pod} (once).
658              
659             Set the rhProperty keys of the Location:
660              
661             found - $lookFor
662             docType - "hint"
663             name - the $name
664             pod - the POD describing $name (includes podSection)
665             podSection - the POD section the name is located in
666              
667             pod will be munged to include podSection, and if the original pod
668             consisted of an "=item", it will be surrounded by "=over" 4 and
669             "=back".
670              
671             Die on errors.
672              
673             =cut
674 194     194 1 292 sub oLocationPod {
675 194         724 my ($name, $lookFor) = Devel::PerlySense::Util::aNamedArg(["name", "lookFor"], @_);
676 194         534 my %p = @_;
677 194   100     725 my $ignoreBaseModules = $p{ignoreBaseModules} || 0;
678 194 50       944 $lookFor eq "method" or croak("Invalid value for lookFor ($lookFor). Valid values are: 'method'.");
679              
680 194         354 my $rexName = quotemeta($name);
681 194         295 for my $oLocationCur (@{$self->oMeta->raLocationPod}) {
  194         4793  
682              
683             ###TODO: ignore name if it has a sigil, i.e "$name"/"%name"/"@name"
684             #First match, this may have to be refined (go for the earliest occurence on the line, or the shortest line)
685 2853 100       100377 if($oLocationCur->rhProperty->{pod} =~ /^= \w+ \s+ [^\n]*? \b $rexName \b /x) {
686 87         1040 my $oLocation = $oLocationCur->clone;
687 87         2214 $oLocation->rhProperty->{found} = $lookFor;
688 87         2608 $oLocation->rhProperty->{docType} = "hint";
689 87         2345 $oLocation->rhProperty->{name} = "$name";
690              
691 87         2503 my $pod = $oLocation->rhProperty->{pod};
692 87 100       558 $pod =~ /^=item\s/ and $pod = "=over 4\n\n$pod\n\n=back\n";
693 87         2015 $oLocation->rhProperty->{pod} = $oLocation->rhProperty->{podSection} . $pod;
694              
695 87         1012 return($oLocation);
696             }
697             }
698              
699              
700 107 100       1063 $ignoreBaseModules and return(undef);
701             #Fail to base classes, maybe
702              
703 104         408 for my $moduleBase ($self->aNameBase) {
704 98 100       2327 my $oDocumentBase = $self->oPerlySense->oDocumentFindModule(
705             nameModule => $moduleBase,
706             dirOrigin => dirname($self->file),
707             ) or warn("Could not find module ($moduleBase)\n"), next;
708 97 100       616 if(my $oLocation = $oDocumentBase->oLocationPod(
709             name => $name,
710             lookFor => $lookFor,
711             )) {
712              
713 53 100       1261 if( $oLocation->rhProperty->{pod} !~ /\n=head1 From <[\w:]+>\n$/) {
714 47         1619 $oLocation->rhProperty->{pod} .= "\n=head1 From <$moduleBase>\n";
715             }
716              
717 53         534 return($oLocation);
718             }
719             }
720              
721 51         249 return(undef);
722             }
723              
724              
725              
726              
727              
728             =head2 aMethodCallOf(nameObject => $nameObject, oLocationWithin => $oLocationWithin)
729              
730             Find all the method calls of $nameObject in the $oLocationWithin.
731              
732             Shortcut: assume the $oLocationWithin is the entire interesting
733             scope. Ignore morons who re-define their vars in inner scopes with a
734             different type. If this turns out to be a problem, fix the problem
735             then. Or smack them over the head with a trout.
736              
737             Return sorted array with the method names called.
738              
739             Die on errors.
740              
741             =cut
742 7     7 1 30 sub aMethodCallOf {
743 7         28 my ($nameObject, $oLocationWithin) = Devel::PerlySense::Util::aNamedArg(["nameObject", "oLocationWithin"], @_);
744              
745              
746             #Stop methods
747 7         26 my %hMethodStop = (isa => 1, can => 1); #TODO: Move to property and config
748              
749              
750 7         23 my $rexObject = quotemeta($nameObject);
751 24         50 my %hMethod =
752 25         181 map { $_ => 1 }
753 7         881 grep { ! exists $hMethodStop{$_} } (
754             $oLocationWithin->rhProperty->{source} =~ /
755             $rexObject
756             \s* -> \s*
757             ( \w+ )
758             /gsx
759             );
760              
761 7         63 return(sort keys %hMethod);
762             }
763              
764              
765              
766              
767              
768             =head2 determineLikelyApi(nameModule => $nameModule)
769              
770             Look in the document for sub declarations, $self->method calls, and
771             $self->{hash_key} in order to determine what is the likely API of the
772             packages of this document. Focus on the $nameModule and its base
773             classes.
774              
775             Set the rhPackageApiLikely property with new
776             Devel::PerlySense::Document::Api objects for each package.
777              
778             Return 1 on success. Die on errors.
779              
780             Cached on the usual + $nameModule.
781              
782             =cut
783 66     66 1 129 sub determineLikelyApi {
784 66         261 my ($nameModule) = Devel::PerlySense::Util::aNamedArg(["nameModule"], @_);
785              
786 66         189 my $keyCache = "likelyApi\t$nameModule";
787 66 100       1829 if(my $rhPackageApi = $self->cacheGet($keyCache, $self->file)) {
788 7         191 $self->rhPackageApiLikely($rhPackageApi);
789             } else {
790 59         228 $self->determineLikelyApi0(nameModule => $nameModule);
791 59         1373 $self->cacheSet($keyCache, $self->file, $self->rhPackageApiLikely);
792             }
793              
794 66         2380 return(1);
795             }
796              
797              
798              
799              
800              
801             =head2 determineLikelyApi0(nameModule => $nameModule)
802              
803             Implementation for determineLikelyApi()
804              
805             =cut
806 59     59 1 77 sub determineLikelyApi0 {
807 59         247 my ($nameModule) = Devel::PerlySense::Util::aNamedArg(["nameModule"], @_);
808              
809              
810 59         117 my $rhPackageApi = {};
811              
812 59         543 my $oApiCur = Devel::PerlySense::Document::Api->new();
813 59         77 my $packageCur = "main";
814 59         74 my $sourcePackage = "";
815 59         92 my @aNodeSub = ();
816 59         1533 for my $oNode ($self->oDocument->elements) {
817 6682 100       250634 if ($oNode->isa("PPI::Statement::Package")) {
818 59         248 $oApiCur->parsePackageSetSub(oDocument => $self, raNodeSub => \@aNodeSub, source => $sourcePackage);
819 59 50       65 (keys %{$oApiCur->rhSub}) and $rhPackageApi->{$packageCur} = $oApiCur;
  59         1531  
820              
821              
822 59         711 $oApiCur = Devel::PerlySense::Document::Api->new();
823 59         380 $packageCur = $oNode->namespace;
824 59         1869 $sourcePackage = "";
825 59         98 @aNodeSub = ();
826             }
827              
828             ###TODO: push this down into the API class?
829 6682 100 66     17562 if ($oNode->isa("PPI::Statement::Sub") && ! $oNode->forward) {
830 408         7637 push(@aNodeSub, $oNode);
831 408         735 $sourcePackage .= $oNode;
832             }
833             }
834 59         581 $oApiCur->parsePackageSetSub(oDocument => $self, raNodeSub => \@aNodeSub, source => $sourcePackage);
835 59 50       74 (keys %{$oApiCur->rhSub}) and $rhPackageApi->{$packageCur} = $oApiCur;
  59         2196  
836              
837              
838              
839             #Look in base classes
840 59         620 for my $nameBase ($self->aNameBase) {
841 20 50       595 my $oDocumentBase = $self->oPerlySense->oDocumentFindModule(
842             nameModule => $nameBase,
843             dirOrigin => dirname($self->file),
844             ) or next;
845              
846 20         172 debug("($nameModule) looking in base class ($nameBase)");
847 20 50       56 $nameModule eq $nameBase and next;
848             ###TODO: look for longer recursive chains
849              
850 20         120 $oDocumentBase->determineLikelyApi(nameModule => $nameBase);
851              
852 20         490 $self->mergePackageApiWithBase(
853             nameModule => $nameModule,
854             rhPackageApi => $rhPackageApi,
855             nameModuleBase => $nameBase,
856             rhPackageApiBase => $oDocumentBase->rhPackageApiLikely,
857             );
858              
859             }
860              
861              
862 59         1430 $self->rhPackageApiLikely($rhPackageApi);
863              
864 59         920 return(1);
865             }
866              
867              
868              
869              
870              
871             =head2 mergePackageApiWithBase(nameModule => $nameModule, rhPackageApi => $rhPackageApi, nameModuleBase => $nameModuleBase, rhPackageApiBase => $rhPackageApiBase)
872              
873             Merge the $rhPackageApiBase of the base class with the existing
874             $rhPackageApi. Modify $rhPackageApi.
875              
876             Only merge the API of the $nameModule.
877              
878             Document::Api objects are cloned, not reused, but individual
879             Document::Location objects may be shared between documents and apis.
880              
881             Return 1 on success, or 0 if the package wasn't found. Die on errors.
882              
883             =cut
884 20     20 1 115 sub mergePackageApiWithBase {
885 20         87 my ($nameModule, $rhPackageApi, $nameModuleBase, $rhPackageApiBase) = Devel::PerlySense::Util::aNamedArg(["nameModule", "rhPackageApi", "nameModuleBase", "rhPackageApiBase"], @_);
886              
887 20 50       127 my $oApiBase = $rhPackageApiBase->{$nameModuleBase} or return(0);
888              
889 20         40 my $oApi = $rhPackageApi->{$nameModule};
890 20 50       44 $oApi or $oApi = $rhPackageApi->{$nameModule} = Devel::PerlySense::Document::Api->new();
891              
892 20         67 $oApi->mergeWithBase($oApiBase);
893              
894 20         52 return(1);
895             }
896              
897              
898              
899              
900              
901             =head2 scoreInterfaceMatch(nameModule => $nameModule, raMethodRequired => $raMethodRequired, raMethodNice => $raMethodNice)
902              
903             Rate the interface match between the document and the wanted interface
904             of the method names in $raMethodRequired + $raMethodNice.
905              
906             If not all method names in $raMethodRequired are supported, the score
907             is 0, and this document should not be considered to support the
908             requirements.
909              
910             The score is calculated like this:
911              
912             % of ($raMethod*) that is supported, except
913             all required must be there.
914              
915             +
916              
917             % of the api that consists of $raMethod*. This will favour smaller
918             interfaces in base classes.
919              
920             Return score on success. Die on errors.
921              
922             =cut
923 42     42 1 70 sub scoreInterfaceMatch {
924 42         187 my ($nameModule, $raMethodRequired, $raMethodNice) = Devel::PerlySense::Util::aNamedArg(["nameModule", "raMethodRequired", "raMethodNice"], @_);
925              
926 42 50       1405 my $oApi = $self->rhPackageApiLikely->{$nameModule} or return(0);
927              
928 42         265 for my $method (@$raMethodRequired) {
929 44 100       154 $oApi->isSubSupported($method) or return(0);
930             }
931              
932 12         88 my %hSeen;
933 12         30 my @aMethod = grep { ! $hSeen{$_}++ } (@$raMethodRequired, @$raMethodNice);
  67         134  
934              
935 12         18 my $supportedMultiplier = 5; #TODO: move to config
936 12         35 my $score = ($oApi->percentSupportedOf(\@aMethod) * $supportedMultiplier) +
937             $oApi->percentConsistsOf(\@aMethod);
938              
939 12         199 my $percentScore = sprintf("%.02f", ($score / ($supportedMultiplier + 1))) + 0;
940              
941 12         71 return($percentScore);
942             }
943              
944              
945              
946              
947              
948             =head2 stringSignatureSurveyFromFile()
949              
950             Calculate a Signature Survey string for the source in the document.
951              
952             Return the string. Die on errors.
953              
954             =cut
955 1     1 1 2 sub stringSignatureSurveyFromFile {
956 1         27 return $self->stringSignatureSurveyFromSource( slurp($self->file) );
957             }
958              
959              
960              
961              
962              
963             =head2 stringSignatureSurveyFromSource($stringSource)
964              
965             Calculate a Signature Survey string for the $stringSource, based on
966             the idea in http://c2.com/doc/SignatureSurvey/ .
967              
968             The idea is not to get an exact representation of the source but a
969             good feel for what it contains.
970              
971             Return the survey string. Die on errors.
972              
973             =cut
974             my $matchReplace = {
975             q/{/ => q/{/,
976             q/}/ => q/}/,
977             q/"/ => q/"/,
978             q/'/ => q/'/,
979             q/;/ => q/;/,
980             q/sub\s+\w+\s*{/ => q/SPECIAL/,
981             q/sub\s+\w+\s*:\s*\w+[^{]+{/ => q/SPECIAL/,
982             q/^=(?:head|item|for|pod)/ => q/SPECIAL/,
983             };
984             my $rexMatch = join("|", keys %$matchReplace );
985 696     696   424 sub _stringReplace {
986 696         464 my ($match) = @_;
987              
988 696 100       959 if(index($match, "sub") > -1) {
989 33 100       43 index($match, ":") > -1 and return "SA{";
990 32         35 return "S{";
991             }
992 663 100       913 index($match, "=") > -1 and return "=";
993              
994 587         729 return $matchReplace->{$match};
995             }
996 1     1 1 2 sub stringSignatureSurveyFromSource {
997 1         31 my ($source) = @_;
998              
999 1         8840 my @aToken = $source =~ /($rexMatch)/gm;
1000             # print Dumper(\@aToken);
1001 696         628 my $signature = join(
1002             "",
1003 1         28 map { $self->_stringReplace($_) } @aToken,
1004             );
1005              
1006             #Remove closing " and ', they just clutter things up
1007 1         130 $signature =~ s/(["'])\1/$1/gsm;
1008              
1009             #Remove empty {}, they most often indicate hash accesses or derefs
1010 1         17 $signature =~ s/{}//gsm;
1011              
1012             #Remove =['"]+ that's a sign of quotes inside POD text
1013 1         20 $signature =~ s/=['"]+/=/gsm;
1014              
1015 1         82 return($signature);
1016             }
1017              
1018              
1019              
1020              
1021              
1022             =head1 IMPLEMENTATION METHODS
1023              
1024              
1025             =head2 oLocationOfNode($oNode, [$extraRow = 0, $extraCol = 0])
1026              
1027             Return Devel::PerlySense::Document::Location object for $oNode.
1028              
1029             If $extraRow or $extraCol are passed, add that to the location.
1030              
1031             =cut
1032 411     411 1 305 sub oLocationOfNode {
1033 411         335 my ($oNode, $extraRow, $extraCol) = @_;
1034 411   50     1163 $extraRow ||= 0;
1035 411   50     834 $extraCol ||= 0;
1036              
1037             return(
1038 411         12804 Devel::PerlySense::Document::Location->new(
1039             file => $self->file,
1040             row => $oNode->location->[0] + $extraRow,
1041             col => $oNode->location->[1] + $extraCol,
1042             )
1043             );
1044             }
1045              
1046              
1047              
1048              
1049              
1050             =head2 aDocumentFind($what)
1051              
1052             Convenience wrapper around $self->$oDocument->find($what) to account
1053             for the unusable api.
1054              
1055             Return list of matching nodes, or an empty list if none was found.
1056              
1057             =cut
1058 327     327 1 528 sub aDocumentFind {
1059 327         503 my ($what) = @_;
1060 327         8508 return($self->aNodeFind($self->oDocument, $what));
1061             }
1062              
1063              
1064              
1065              
1066              
1067             =head2 aNodeFind($oNode, $what)
1068              
1069             Convenience wrapper around $oNode->find($what) to account
1070             for the unusable api.
1071              
1072             Return list of matching nodes, or an empty list if none was found.
1073              
1074             =cut
1075 327     327 1 1631 sub aNodeFind {
1076 327         433 my ($oNode, $what) = @_;
1077 327 50       1784 my $raList = $oNode->find($what) or return();
1078 0         0 return(@$raList);
1079             }
1080              
1081              
1082              
1083              
1084              
1085             =head2 oLocationEnclosingSub($oNode)
1086              
1087             Return a Document::Location object that is the enclosing sub of
1088             $oNode, i.e. $oNode is located within the sub block. The Location
1089             object has the following rhProperty keys:
1090              
1091             nameSub
1092             source
1093             oLocationEnd with: row and col
1094              
1095             Return Location object with the sub, or undef if none was found. Die on
1096             errors.
1097              
1098             =cut
1099 7     7 1 9 sub oLocationEnclosingSub {
1100 7         9 my ($oNode) = @_;
1101              
1102             #Simplification: assume there is only one sub on each row
1103              
1104 7         11 my ($row, $col) = @{$oNode->location};
  7         20  
1105 7         65 for my $oLocation (@{$self->oMeta->raLocationSub}) {
  7         171  
1106 85 100 66     6463 if($row >= $oLocation->row && $row <= $oLocation->rhProperty->{oLocationEnd}->row) {
1107 7         402 return($oLocation);
1108             }
1109             }
1110              
1111              
1112 0         0 return(undef);
1113             }
1114              
1115              
1116              
1117              
1118              
1119             =head1 CACHE METHODS
1120              
1121              
1122             =head2 cacheSet($key, $file, $rValue)
1123              
1124             If a cache is active, store the $value in the cache under the total
1125             key of ($file, $file's timestamp, $key).
1126              
1127             $value should be a scalar or reference which can be freezed.
1128              
1129             $file must be an existing file.
1130              
1131             Return 1 if the $value was stored, else 0. Die on errors.
1132              
1133             =cut
1134 709     709 1 6228 sub cacheSet {
1135 709         1432 my ($key, $file, $rValue) = @_;
1136 709         20838 return( $self->oPerlySense->cacheSet(file => $file, key => $key, value => $rValue) );
1137             }
1138              
1139              
1140              
1141              
1142              
1143             =head2 cacheGet($key, $file)
1144              
1145             If a cache is active, get the value in the cache under the total key
1146             of ($file, $file's timestamp, $key).
1147              
1148             $file must be an existing file.
1149              
1150             Return the value, or undef if the value could not be fetched. Die on
1151             errors.
1152              
1153             =cut
1154 736     736 1 1655 sub cacheGet {
1155 736         1077 my ($key, $file) = @_;
1156 736         18641 my $rValue = $self->oPerlySense->cacheGet(file => $file, key => $key);
1157 736         9344 return($rValue);
1158             }
1159              
1160              
1161              
1162              
1163              
1164             1;
1165              
1166              
1167              
1168              
1169              
1170             __END__
1171              
1172             =encoding utf8
1173              
1174             =head1 AUTHOR
1175              
1176             Johan Lindström, C<< <johanl[ÄT]DarSerMan.com> >>
1177              
1178             =head1 BUGS
1179              
1180             Please report any bugs or feature requests to
1181             C<bug-devel-perlysense@rt.cpan.org>, or through the web interface at
1182             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Devel-PerlySense>.
1183             I will be notified, and then you'll automatically be notified of progress on
1184             your bug as I make changes.
1185              
1186             =head1 ACKNOWLEDGEMENTS
1187              
1188             =head1 COPYRIGHT & LICENSE
1189              
1190             Copyright 2005 Johan Lindström, All Rights Reserved.
1191              
1192             This program is free software; you can redistribute it and/or modify it
1193             under the same terms as Perl itself.
1194              
1195             =cut