| 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 |