← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:47 2015

Filename/usr/share/perl/5.20/Module/Metadata.pm
StatementsExecuted 37 statements in 4.52ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11110.5ms11.0msModule::Metadata::::BEGIN@29Module::Metadata::BEGIN@29
331111µs111µsModule::Metadata::::CORE:regcompModule::Metadata::CORE:regcomp (opcode)
11114µs35µsModule::Metadata::::BEGIN@21Module::Metadata::BEGIN@21
11112µs22µsModule::Metadata::::BEGIN@12Module::Metadata::BEGIN@12
11110µs27µsModule::Metadata::::BEGIN@728Module::Metadata::BEGIN@728
11110µs107µsModule::Metadata::::BEGIN@20Module::Metadata::BEGIN@20
1117µs14µsModule::Metadata::::BEGIN@13Module::Metadata::BEGIN@13
1117µs30µsModule::Metadata::::BEGIN@18Module::Metadata::BEGIN@18
7717µs7µsModule::Metadata::::CORE:qrModule::Metadata::CORE:qr (opcode)
1116µs6µsModule::Metadata::::BEGIN@22Module::Metadata::BEGIN@22
1116µs6µsModule::Metadata::::BEGIN@19Module::Metadata::BEGIN@19
0000s0sModule::Metadata::::__ANON__[:133]Module::Metadata::__ANON__[:133]
0000s0sModule::Metadata::::__ANON__[:136]Module::Metadata::__ANON__[:136]
0000s0sModule::Metadata::::__ANON__[:154]Module::Metadata::__ANON__[:154]
0000s0sModule::Metadata::::__ANON__[:190]Module::Metadata::__ANON__[:190]
0000s0sModule::Metadata::::__ANON__[:241]Module::Metadata::__ANON__[:241]
0000s0sModule::Metadata::::__ANON__[:26]Module::Metadata::__ANON__[:26]
0000s0sModule::Metadata::::__ANON__[:297]Module::Metadata::__ANON__[:297]
0000s0sModule::Metadata::::__ANON__[:316]Module::Metadata::__ANON__[:316]
0000s0sModule::Metadata::::__ANON__[:337]Module::Metadata::__ANON__[:337]
0000s0sModule::Metadata::::__ANON__[:700]Module::Metadata::__ANON__[:700]
0000s0sModule::Metadata::::__ANON__[:708]Module::Metadata::__ANON__[:708]
0000s0sModule::Metadata::::__ANON__[:723]Module::Metadata::__ANON__[:723]
0000s0sModule::Metadata::::__ANON__[:730]Module::Metadata::__ANON__[:730]
0000s0sModule::Metadata::::_do_find_moduleModule::Metadata::_do_find_module
0000s0sModule::Metadata::::_dwim_versionModule::Metadata::_dwim_version
0000s0sModule::Metadata::::_evaluate_version_lineModule::Metadata::_evaluate_version_line
0000s0sModule::Metadata::::_handle_bomModule::Metadata::_handle_bom
0000s0sModule::Metadata::::_initModule::Metadata::_init
0000s0sModule::Metadata::::_parse_fhModule::Metadata::_parse_fh
0000s0sModule::Metadata::::_parse_fileModule::Metadata::_parse_file
0000s0sModule::Metadata::::_parse_version_expressionModule::Metadata::_parse_version_expression
0000s0sModule::Metadata::::contains_podModule::Metadata::contains_pod
0000s0sModule::Metadata::::filenameModule::Metadata::filename
0000s0sModule::Metadata::::find_module_by_nameModule::Metadata::find_module_by_name
0000s0sModule::Metadata::::find_module_dir_by_nameModule::Metadata::find_module_dir_by_name
0000s0sModule::Metadata::::nameModule::Metadata::name
0000s0sModule::Metadata::::new_from_fileModule::Metadata::new_from_file
0000s0sModule::Metadata::::new_from_handleModule::Metadata::new_from_handle
0000s0sModule::Metadata::::new_from_moduleModule::Metadata::new_from_module
0000s0sModule::Metadata::::package_versions_from_directoryModule::Metadata::package_versions_from_directory
0000s0sModule::Metadata::::packages_insideModule::Metadata::packages_inside
0000s0sModule::Metadata::::podModule::Metadata::pod
0000s0sModule::Metadata::::pod_insideModule::Metadata::pod_inside
0000s0sModule::Metadata::::providesModule::Metadata::provides
0000s0sModule::Metadata::::versionModule::Metadata::version
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2# vim:ts=8:sw=2:et:sta:sts=2
3package Module::Metadata;
4
5# Adapted from Perl-licensed code originally distributed with
6# Module-Build by Ken Williams
7
8# This module provides routines to gather information about
9# perl modules (assuming this may be expanded in the distant
10# parrot future to look at other types of modules).
11
12222µs232µs
# spent 22µs (12+10) within Module::Metadata::BEGIN@12 which was called: # once (12µs+10µs) by Module::Load::Conditional::BEGIN@14 at line 12
use strict;
# spent 22µs making 1 call to Module::Metadata::BEGIN@12 # spent 10µs making 1 call to strict::import
13238µs220µs
# spent 14µs (7+6) within Module::Metadata::BEGIN@13 which was called: # once (7µs+6µs) by Module::Load::Conditional::BEGIN@14 at line 13
use warnings;
# spent 14µs making 1 call to Module::Metadata::BEGIN@13 # spent 6µs making 1 call to warnings::import
14
151400nsour $VERSION = '1.000019';
16113µs$VERSION = eval $VERSION;
# spent 2µs executing statements in string eval
17
18222µs252µs
# spent 30µs (7+22) within Module::Metadata::BEGIN@18 which was called: # once (7µs+22µs) by Module::Load::Conditional::BEGIN@14 at line 18
use Carp qw/croak/;
# spent 30µs making 1 call to Module::Metadata::BEGIN@18 # spent 22µs making 1 call to Exporter::import
19221µs16µs
# spent 6µs within Module::Metadata::BEGIN@19 which was called: # once (6µs+0s) by Module::Load::Conditional::BEGIN@14 at line 19
use File::Spec;
# spent 6µs making 1 call to Module::Metadata::BEGIN@19
20227µs2204µs
# spent 107µs (10+97) within Module::Metadata::BEGIN@20 which was called: # once (10µs+97µs) by Module::Load::Conditional::BEGIN@14 at line 20
use IO::File;
# spent 107µs making 1 call to Module::Metadata::BEGIN@20 # spent 97µs making 1 call to Exporter::import
21381µs357µs
# spent 35µs (14+21) within Module::Metadata::BEGIN@21 which was called: # once (14µs+21µs) by Module::Load::Conditional::BEGIN@14 at line 21
use version 0.87;
# spent 35µs making 1 call to Module::Metadata::BEGIN@21 # spent 12µs making 1 call to version::import # spent 9µs making 1 call to version::_VERSION
22
# spent 6µs within Module::Metadata::BEGIN@22 which was called: # once (6µs+0s) by Module::Load::Conditional::BEGIN@14 at line 28
BEGIN {
2316µs if ($INC{'Log/Contextual.pm'}) {
24 Log::Contextual->import('log_info');
25 } else {
2613µs *log_info = sub (&) { warn $_[0]->() };
27 }
28128µs16µs}
# spent 6µs making 1 call to Module::Metadata::BEGIN@22
2923.73ms211.0ms
# spent 11.0ms (10.5+443µs) within Module::Metadata::BEGIN@29 which was called: # once (10.5ms+443µs) by Module::Load::Conditional::BEGIN@14 at line 29
use File::Find qw(find);
# spent 11.0ms making 1 call to Module::Metadata::BEGIN@29 # spent 29µs making 1 call to Exporter::import
30
3117µs12µsmy $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
# spent 2µs making 1 call to Module::Metadata::CORE:qr
32
3312µs1700nsmy $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
# spent 700ns making 1 call to Module::Metadata::CORE:qr
34 [a-zA-Z_] # the first word CANNOT start with a digit
35 (?:
36 [\w']? # can contain letters, digits, _, or ticks
37 \w # But, NO multi-ticks or trailing ticks
38 )*
39}x;
40
4112µs11µsmy $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
# spent 1µs making 1 call to Module::Metadata::CORE:qr
42 \w # the 2nd+ word CAN start with digits
43 (?:
44 [\w']? # and can contain letters or ticks
45 \w # But, NO multi-ticks or trailing ticks
46 )*
47}x;
48
49145µs239µsmy $PKG_NAME_REGEXP = qr{ # match a package name
# spent 38µs making 1 call to Module::Metadata::CORE:regcomp # spent 900ns making 1 call to Module::Metadata::CORE:qr
50 (?: :: )? # a pkg name can start with aristotle
51 $PKG_FIRST_WORD_REGEXP # a package word
52 (?:
53 (?: :: )+ ### aristotle (allow one or many times)
54 $PKG_ADDL_WORD_REGEXP ### a package word
55 )* # ^ zero, one or many times
56 (?:
57 :: # allow trailing aristotle
58 )?
59}x;
60
61148µs243µsmy $PKG_REGEXP = qr{ # match a package declaration
# spent 42µs making 1 call to Module::Metadata::CORE:regcomp # spent 900ns making 1 call to Module::Metadata::CORE:qr
62 ^[\s\{;]* # intro chars on a line
63 package # the word 'package'
64 \s+ # whitespace
65 ($PKG_NAME_REGEXP) # a package name
66 \s* # optional whitespace
67 ($V_NUM_REGEXP)? # optional version number
68 \s* # optional whitesapce
69 [;\{] # semicolon line terminator or block start (since 5.16)
70}x;
71
7212µs1600nsmy $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
# spent 600ns making 1 call to Module::Metadata::CORE:qr
73 ([\$*]) # sigil - $ or *
74 (
75 ( # optional leading package name
76 (?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
77 (?:\w+(?:::|\'))* # Foo::Bar:: ...
78 )?
79 VERSION
80 )\b
81}x;
82
83135µs231µsmy $VERS_REGEXP = qr{ # match a VERSION definition
# spent 30µs making 1 call to Module::Metadata::CORE:regcomp # spent 700ns making 1 call to Module::Metadata::CORE:qr
84 (?:
85 \(\s*$VARNAME_REGEXP\s*\) # with parens
86 |
87 $VARNAME_REGEXP # without parens
88 )
89 \s*
90 =[^=~] # = but not ==, nor =~
91}x;
92
93sub new_from_file {
94 my $class = shift;
95 my $filename = File::Spec->rel2abs( shift );
96
97 return undef unless defined( $filename ) && -f $filename;
98 return $class->_init(undef, $filename, @_);
99}
100
101sub new_from_handle {
102 my $class = shift;
103 my $handle = shift;
104 my $filename = shift;
105 return undef unless defined($handle) && defined($filename);
106 $filename = File::Spec->rel2abs( $filename );
107
108 return $class->_init(undef, $filename, @_, handle => $handle);
109
110}
111
112
113sub new_from_module {
114 my $class = shift;
115 my $module = shift;
116 my %props = @_;
117
118 $props{inc} ||= \@INC;
119 my $filename = $class->find_module_by_name( $module, $props{inc} );
120 return undef unless defined( $filename ) && -f $filename;
121 return $class->_init($module, $filename, %props);
122}
123
124{
125
1261400ns my $compare_versions = sub {
127 my ($v1, $op, $v2) = @_;
128 $v1 = version->new($v1)
129 unless UNIVERSAL::isa($v1,'version');
130
131 my $eval_str = "\$v1 $op \$v2";
132 my $result = eval $eval_str;
133 log_info { "error comparing versions: '$eval_str' $@" } if $@;
134
135 return $result;
13612µs };
137
138 my $normalize_version = sub {
139 my ($version) = @_;
140 if ( $version =~ /[=<>!,]/ ) { # logic, not just version
141 # take as is without modification
142 }
143 elsif ( ref $version eq 'version' ) { # version objects
144 $version = $version->is_qv ? $version->normal : $version->stringify;
145 }
146 elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
147 # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
148 $version = "v$version";
149 }
150 else {
151 # leave alone
152 }
153 return $version;
15411µs };
155
156 # separate out some of the conflict resolution logic
157
158 my $resolve_module_versions = sub {
159 my $packages = shift;
160
161 my( $file, $version );
162 my $err = '';
163 foreach my $p ( @$packages ) {
164 if ( defined( $p->{version} ) ) {
165 if ( defined( $version ) ) {
166 if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
167 $err .= " $p->{file} ($p->{version})\n";
168 } else {
169 # same version declared multiple times, ignore
170 }
171 } else {
172 $file = $p->{file};
173 $version = $p->{version};
174 }
175 }
176 $file ||= $p->{file} if defined( $p->{file} );
177 }
178
179 if ( $err ) {
180 $err = " $file ($version)\n" . $err;
181 }
182
183 my %result = (
184 file => $file,
185 version => $version,
186 err => $err
187 );
188
189 return \%result;
19012µs };
191
192 sub provides {
193 my $class = shift;
194
195 croak "provides() requires key/value pairs \n" if @_ % 2;
196 my %args = @_;
197
198 croak "provides() takes only one of 'dir' or 'files'\n"
199 if $args{dir} && $args{files};
200
201 croak "provides() requires a 'version' argument"
202 unless defined $args{version};
203
204 croak "provides() does not support version '$args{version}' metadata"
205 unless grep { $args{version} eq $_ } qw/1.4 2/;
206
207 $args{prefix} = 'lib' unless defined $args{prefix};
208
209 my $p;
210 if ( $args{dir} ) {
211 $p = $class->package_versions_from_directory($args{dir});
212 }
213 else {
214 croak "provides() requires 'files' to be an array reference\n"
215 unless ref $args{files} eq 'ARRAY';
216 $p = $class->package_versions_from_directory($args{files});
217 }
218
219 # Now, fix up files with prefix
220 if ( length $args{prefix} ) { # check in case disabled with q{}
221 $args{prefix} =~ s{/$}{};
222 for my $v ( values %$p ) {
223 $v->{file} = "$args{prefix}/$v->{file}";
224 }
225 }
226
227 return $p
228 }
229
230 sub package_versions_from_directory {
231 my ( $class, $dir, $files ) = @_;
232
233 my @files;
234
235 if ( $files ) {
236 @files = @$files;
237 } else {
238 find( {
239 wanted => sub {
240 push @files, $_ if -f $_ && /\.pm$/;
241 },
242 no_chdir => 1,
243 }, $dir );
244 }
245
246 # First, we enumerate all packages & versions,
247 # separating into primary & alternative candidates
248 my( %prime, %alt );
249 foreach my $file (@files) {
250 my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir );
251 my @path = split( /\//, $mapped_filename );
252 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
253
254 my $pm_info = $class->new_from_file( $file );
255
256 foreach my $package ( $pm_info->packages_inside ) {
257 next if $package eq 'main'; # main can appear numerous times, ignore
258 next if $package eq 'DB'; # special debugging package, ignore
259 next if grep /^_/, split( /::/, $package ); # private package, ignore
260
261 my $version = $pm_info->version( $package );
262
263 $prime_package = $package if lc($prime_package) eq lc($package);
264 if ( $package eq $prime_package ) {
265 if ( exists( $prime{$package} ) ) {
266 croak "Unexpected conflict in '$package'; multiple versions found.\n";
267 } else {
268 $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
269 $prime{$package}{file} = $mapped_filename;
270 $prime{$package}{version} = $version if defined( $version );
271 }
272 } else {
273 push( @{$alt{$package}}, {
274 file => $mapped_filename,
275 version => $version,
276 } );
277 }
278 }
279 }
280
281 # Then we iterate over all the packages found above, identifying conflicts
282 # and selecting the "best" candidate for recording the file & version
283 # for each package.
284 foreach my $package ( keys( %alt ) ) {
285 my $result = $resolve_module_versions->( $alt{$package} );
286
287 if ( exists( $prime{$package} ) ) { # primary package selected
288
289 if ( $result->{err} ) {
290 # Use the selected primary package, but there are conflicting
291 # errors among multiple alternative packages that need to be
292 # reported
293 log_info {
294 "Found conflicting versions for package '$package'\n" .
295 " $prime{$package}{file} ($prime{$package}{version})\n" .
296 $result->{err}
297 };
298
299 } elsif ( defined( $result->{version} ) ) {
300 # There is a primary package selected, and exactly one
301 # alternative package
302
303 if ( exists( $prime{$package}{version} ) &&
304 defined( $prime{$package}{version} ) ) {
305 # Unless the version of the primary package agrees with the
306 # version of the alternative package, report a conflict
307 if ( $compare_versions->(
308 $prime{$package}{version}, '!=', $result->{version}
309 )
310 ) {
311
312 log_info {
313 "Found conflicting versions for package '$package'\n" .
314 " $prime{$package}{file} ($prime{$package}{version})\n" .
315 " $result->{file} ($result->{version})\n"
316 };
317 }
318
319 } else {
320 # The prime package selected has no version so, we choose to
321 # use any alternative package that does have a version
322 $prime{$package}{file} = $result->{file};
323 $prime{$package}{version} = $result->{version};
324 }
325
326 } else {
327 # no alt package found with a version, but we have a prime
328 # package so we use it whether it has a version or not
329 }
330
331 } else { # No primary package was selected, use the best alternative
332
333 if ( $result->{err} ) {
334 log_info {
335 "Found conflicting versions for package '$package'\n" .
336 $result->{err}
337 };
338 }
339
340 # Despite possible conflicting versions, we choose to record
341 # something rather than nothing
342 $prime{$package}{file} = $result->{file};
343 $prime{$package}{version} = $result->{version}
344 if defined( $result->{version} );
345 }
346 }
347
348 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
349 # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
350 for (grep defined $_->{version}, values %prime) {
351 $_->{version} = $normalize_version->( $_->{version} );
352 }
353
354 return \%prime;
355 }
356}
357
358
359sub _init {
360 my $class = shift;
361 my $module = shift;
362 my $filename = shift;
363 my %props = @_;
364
365 my $handle = delete $props{handle};
366 my( %valid_props, @valid_props );
367 @valid_props = qw( collect_pod inc );
368 @valid_props{@valid_props} = delete( @props{@valid_props} );
369 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
370
371 my %data = (
372 module => $module,
373 filename => $filename,
374 version => undef,
375 packages => [],
376 versions => {},
377 pod => {},
378 pod_headings => [],
379 collect_pod => 0,
380
381 %valid_props,
382 );
383
384 my $self = bless(\%data, $class);
385
386 if ( $handle ) {
387 $self->_parse_fh($handle);
388 }
389 else {
390 $self->_parse_file();
391 }
392
393 unless($self->{module} and length($self->{module})) {
394 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
395 if($f =~ /\.pm$/) {
396 $f =~ s/\..+$//;
397 my @candidates = grep /$f$/, @{$self->{packages}};
398 $self->{module} = shift(@candidates); # punt
399 }
400 else {
401 if(grep /main/, @{$self->{packages}}) {
402 $self->{module} = 'main';
403 }
404 else {
405 $self->{module} = $self->{packages}[0] || '';
406 }
407 }
408 }
409
410 $self->{version} = $self->{versions}{$self->{module}}
411 if defined( $self->{module} );
412
413 return $self;
414}
415
416# class method
417sub _do_find_module {
418 my $class = shift;
419 my $module = shift || croak 'find_module_by_name() requires a package name';
420 my $dirs = shift || \@INC;
421
422 my $file = File::Spec->catfile(split( /::/, $module));
423 foreach my $dir ( @$dirs ) {
424 my $testfile = File::Spec->catfile($dir, $file);
425 return [ File::Spec->rel2abs( $testfile ), $dir ]
426 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
427 return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
428 if -e "$testfile.pm";
429 }
430 return;
431}
432
433# class method
434sub find_module_by_name {
435 my $found = shift()->_do_find_module(@_) or return;
436 return $found->[0];
437}
438
439# class method
440sub find_module_dir_by_name {
441 my $found = shift()->_do_find_module(@_) or return;
442 return $found->[1];
443}
444
445
446# given a line of perl code, attempt to parse it if it looks like a
447# $VERSION assignment, returning sigil, full name, & package name
448sub _parse_version_expression {
449 my $self = shift;
450 my $line = shift;
451
452 my( $sig, $var, $pkg );
453 if ( $line =~ /$VERS_REGEXP/o ) {
454 ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
455 if ( $pkg ) {
456 $pkg = ($pkg eq '::') ? 'main' : $pkg;
457 $pkg =~ s/::$//;
458 }
459 }
460
461 return ( $sig, $var, $pkg );
462}
463
464sub _parse_file {
465 my $self = shift;
466
467 my $filename = $self->{filename};
468 my $fh = IO::File->new( $filename )
469 or croak( "Can't open '$filename': $!" );
470
471 $self->_handle_bom($fh, $filename);
472
473 $self->_parse_fh($fh);
474}
475
476# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
477# If there's one, then skip it and set the :encoding layer appropriately.
478sub _handle_bom {
479 my ($self, $fh, $filename) = @_;
480
481 my $pos = $fh->getpos;
482 return unless defined $pos;
483
484 my $buf = ' ' x 2;
485 my $count = $fh->read( $buf, length $buf );
486 return unless defined $count and $count >= 2;
487
488 my $encoding;
489 if ( $buf eq "\x{FE}\x{FF}" ) {
490 $encoding = 'UTF-16BE';
491 } elsif ( $buf eq "\x{FF}\x{FE}" ) {
492 $encoding = 'UTF-16LE';
493 } elsif ( $buf eq "\x{EF}\x{BB}" ) {
494 $buf = ' ';
495 $count = $fh->read( $buf, length $buf );
496 if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
497 $encoding = 'UTF-8';
498 }
499 }
500
501 if ( defined $encoding ) {
502 if ( "$]" >= 5.008 ) {
503 # $fh->binmode requires perl 5.10
504 binmode( $fh, ":encoding($encoding)" );
505 }
506 } else {
507 $fh->setpos($pos)
508 or croak( sprintf "Can't reset position to the top of '$filename'" );
509 }
510
511 return $encoding;
512}
513
514sub _parse_fh {
515 my ($self, $fh) = @_;
516
517 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
518 my( @pkgs, %vers, %pod, @pod );
519 my $pkg = 'main';
520 my $pod_sect = '';
521 my $pod_data = '';
522 my $in_end = 0;
523
524 while (defined( my $line = <$fh> )) {
525 my $line_num = $.;
526
527 chomp( $line );
528
529 # From toke.c : any line that begins by "=X", where X is an alphabetic
530 # character, introduces a POD segment.
531 my $is_cut;
532 if ( $line =~ /^=([a-zA-Z].*)/ ) {
533 my $cmd = $1;
534 # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
535 # character (which includes the newline, but here we chomped it away).
536 $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
537 $in_pod = !$is_cut;
538 }
539
540 if ( $in_pod ) {
541
542 if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
543 push( @pod, $1 );
544 if ( $self->{collect_pod} && length( $pod_data ) ) {
545 $pod{$pod_sect} = $pod_data;
546 $pod_data = '';
547 }
548 $pod_sect = $1;
549
550 } elsif ( $self->{collect_pod} ) {
551 $pod_data .= "$line\n";
552
553 }
554
555 } elsif ( $is_cut ) {
556
557 if ( $self->{collect_pod} && length( $pod_data ) ) {
558 $pod{$pod_sect} = $pod_data;
559 $pod_data = '';
560 }
561 $pod_sect = '';
562
563 } else {
564
565 # Skip after __END__
566 next if $in_end;
567
568 # Skip comments in code
569 next if $line =~ /^\s*#/;
570
571 # Would be nice if we could also check $in_string or something too
572 if ($line eq '__END__') {
573 $in_end++;
574 next;
575 }
576 last if $line eq '__DATA__';
577
578 # parse $line to see if it's a $VERSION declaration
579 my( $vers_sig, $vers_fullname, $vers_pkg ) =
580 ($line =~ /VERSION/)
581 ? $self->_parse_version_expression( $line )
582 : ();
583
584 if ( $line =~ /$PKG_REGEXP/o ) {
585 $pkg = $1;
586 push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
587 $vers{$pkg} = $2 unless exists( $vers{$pkg} );
588 $need_vers = defined $2 ? 0 : 1;
589
590 # VERSION defined with full package spec, i.e. $Module::VERSION
591 } elsif ( $vers_fullname && $vers_pkg ) {
592 push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
593 $need_vers = 0 if $vers_pkg eq $pkg;
594
595 unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
596 $vers{$vers_pkg} =
597 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
598 }
599
600 # first non-comment line in undeclared package main is VERSION
601 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
602 $need_vers = 0;
603 my $v =
604 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
605 $vers{$pkg} = $v;
606 push( @pkgs, 'main' );
607
608 # first non-comment line in undeclared package defines package main
609 } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
610 $need_vers = 1;
611 $vers{main} = '';
612 push( @pkgs, 'main' );
613
614 # only keep if this is the first $VERSION seen
615 } elsif ( $vers_fullname && $need_vers ) {
616 $need_vers = 0;
617 my $v =
618 $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
619
620
621 unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
622 $vers{$pkg} = $v;
623 }
624
625 }
626
627 }
628
629 }
630
631 if ( $self->{collect_pod} && length($pod_data) ) {
632 $pod{$pod_sect} = $pod_data;
633 }
634
635 $self->{versions} = \%vers;
636 $self->{packages} = \@pkgs;
637 $self->{pod} = \%pod;
638 $self->{pod_headings} = \@pod;
639}
640
641{
6422300nsmy $pn = 0;
643sub _evaluate_version_line {
644 my $self = shift;
645 my( $sigil, $var, $line ) = @_;
646
647 # Some of this code came from the ExtUtils:: hierarchy.
648
649 # We compile into $vsub because 'use version' would cause
650 # compiletime/runtime issues with local()
651 my $vsub;
652 $pn++; # everybody gets their own package
653 my $eval = qq{BEGIN { my \$dummy = q# Hide from _packages_inside()
654 #; package Module::Metadata::_version::p$pn;
655 use version;
656 no strict;
657 no warnings;
658
659 \$vsub = sub {
660 local $sigil$var;
661 \$$var=undef;
662 $line;
663 \$$var
664 };
665 }};
666
667 $eval = $1 if $eval =~ m{^(.+)}s;
668
669 local $^W;
670 # Try to get the $VERSION
671 eval $eval;
672 # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
673 # installed, so we need to hunt in ./lib for it
674 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
675 local @INC = ('lib',@INC);
676 eval $eval;
677 }
678 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
679 if $@;
680 (ref($vsub) eq 'CODE') or
681 croak "failed to build version sub for $self->{filename}";
682 my $result = eval { $vsub->() };
683 croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
684 if $@;
685
686 # Upgrade it into a version object
687 my $version = eval { _dwim_version($result) };
688
689 croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
690 unless defined $version; # "0" is OK!
691
692 return $version;
693}
694}
695
696# Try to DWIM when things fail the lax version test in obvious ways
697{
6981200ns my @version_prep = (
699 # Best case, it just works
700 sub { return shift },
701
702 # If we still don't have a version, try stripping any
703 # trailing junk that is prohibited by lax rules
704 sub {
705 my $v = shift;
706 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
707 return $v;
708 },
709
710 # Activestate apparently creates custom versions like '1.23_45_01', which
711 # cause version.pm to think it's an invalid alpha. So check for that
712 # and strip them
713 sub {
714 my $v = shift;
715 my $num_dots = () = $v =~ m{(\.)}g;
716 my $num_unders = () = $v =~ m{(_)}g;
717 my $leading_v = substr($v,0,1) eq 'v';
718 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
719 $v =~ s{_}{}g;
720 $num_unders = () = $v =~ m{(_)}g;
721 }
722 return $v;
723 },
724
725 # Worst case, try numifying it like we would have before version objects
726 sub {
727 my $v = shift;
7282363µs244µs
# spent 27µs (10+17) within Module::Metadata::BEGIN@728 which was called: # once (10µs+17µs) by Module::Load::Conditional::BEGIN@14 at line 728
no warnings 'numeric';
# spent 27µs making 1 call to Module::Metadata::BEGIN@728 # spent 17µs making 1 call to warnings::unimport
729 return 0 + $v;
730 },
731
73216µs );
733
734 sub _dwim_version {
735 my ($result) = shift;
736
737 return $result if ref($result) eq 'version';
738
739 my ($version, $error);
740 for my $f (@version_prep) {
741 $result = $f->($result);
742 $version = eval { version->new($result) };
743 $error ||= $@ if $@; # capture first failure
744 last if defined $version;
745 }
746
747 croak $error unless defined $version;
748
749 return $version;
750 }
751}
752
753############################################################
754
755# accessors
756sub name { $_[0]->{module} }
757
758sub filename { $_[0]->{filename} }
759sub packages_inside { @{$_[0]->{packages}} }
760sub pod_inside { @{$_[0]->{pod_headings}} }
761sub contains_pod { 0+@{$_[0]->{pod_headings}} }
762
763sub version {
764 my $self = shift;
765 my $mod = shift || $self->{module};
766 my $vers;
767 if ( defined( $mod ) && length( $mod ) &&
768 exists( $self->{versions}{$mod} ) ) {
769 return $self->{versions}{$mod};
770 } else {
771 return undef;
772 }
773}
774
775sub pod {
776 my $self = shift;
777 my $sect = shift;
778 if ( defined( $sect ) && length( $sect ) &&
779 exists( $self->{pod}{$sect} ) ) {
780 return $self->{pod}{$sect};
781 } else {
782 return undef;
783 }
784}
785
786112µs1;
787
788=head1 NAME
789
790Module::Metadata - Gather package and POD information from perl module files
791
792=head1 SYNOPSIS
793
794 use Module::Metadata;
795
796 # information about a .pm file
797 my $info = Module::Metadata->new_from_file( $file );
798 my $version = $info->version;
799
800 # CPAN META 'provides' field for .pm files in a directory
801 my $provides = Module::Metadata->provides(
802 dir => 'lib', version => 2
803 );
804
805=head1 DESCRIPTION
806
807This module provides a standard way to gather metadata about a .pm file through
808(mostly) static analysis and (some) code execution. When determining the
809version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional
810in the CPAN toolchain.
811
812=head1 USAGE
813
814=head2 Class methods
815
816=over 4
817
818=item C<< new_from_file($filename, collect_pod => 1) >>
819
820Constructs a C<Module::Metadata> object given the path to a file. Returns
821undef if the filename does not exist.
822
823C<collect_pod> is a optional boolean argument that determines whether POD
824data is collected and stored for reference. POD data is not collected by
825default. POD headings are always collected.
826
827If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
828it is skipped before processing, and the content of the file is also decoded
829appropriately starting from perl 5.8.
830
831=item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
832
833This works just like C<new_from_file>, except that a handle can be provided
834as the first argument.
835
836Note that there is no validation to confirm that the handle is a handle or
837something that can act like one. Passing something that isn't a handle will
838cause a exception when trying to read from it. The C<filename> argument is
839mandatory or undef will be returned.
840
841You are responsible for setting the decoding layers on C<$handle> if
842required.
843
844=item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
845
846Constructs a C<Module::Metadata> object given a module or package name.
847Returns undef if the module cannot be found.
848
849In addition to accepting the C<collect_pod> argument as described above,
850this method accepts a C<inc> argument which is a reference to an array of
851directories to search for the module. If none are given, the default is
852@INC.
853
854If the file that contains the module begins by an UTF-8, UTF-16BE or
855UTF-16LE byte-order mark, then it is skipped before processing, and the
856content of the file is also decoded appropriately starting from perl 5.8.
857
858=item C<< find_module_by_name($module, \@dirs) >>
859
860Returns the path to a module given the module or package name. A list
861of directories can be passed in as an optional parameter, otherwise
862@INC is searched.
863
864Can be called as either an object or a class method.
865
866=item C<< find_module_dir_by_name($module, \@dirs) >>
867
868Returns the entry in C<@dirs> (or C<@INC> by default) that contains
869the module C<$module>. A list of directories can be passed in as an
870optional parameter, otherwise @INC is searched.
871
872Can be called as either an object or a class method.
873
874=item C<< provides( %options ) >>
875
876This is a convenience wrapper around C<package_versions_from_directory>
877to generate a CPAN META C<provides> data structure. It takes key/value
878pairs. Valid option keys include:
879
880=over
881
882=item version B<(required)>
883
884Specifies which version of the L<CPAN::Meta::Spec> should be used as
885the format of the C<provides> output. Currently only '1.4' and '2'
886are supported (and their format is identical). This may change in
887the future as the definition of C<provides> changes.
888
889The C<version> option is required. If it is omitted or if
890an unsupported version is given, then C<provides> will throw an error.
891
892=item dir
893
894Directory to search recursively for F<.pm> files. May not be specified with
895C<files>.
896
897=item files
898
899Array reference of files to examine. May not be specified with C<dir>.
900
901=item prefix
902
903String to prepend to the C<file> field of the resulting output. This defaults
904to F<lib>, which is the common case for most CPAN distributions with their
905F<.pm> files in F<lib>. This option ensures the META information has the
906correct relative path even when the C<dir> or C<files> arguments are
907absolute or have relative paths from a location other than the distribution
908root.
909
910=back
911
912For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
913is a hashref of the form:
914
915 {
916 'Package::Name' => {
917 version => '0.123',
918 file => 'lib/Package/Name.pm'
919 },
920 'OtherPackage::Name' => ...
921 }
922
923=item C<< package_versions_from_directory($dir, \@files?) >>
924
925Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
926for those files in C<$dir> - and reads each file for packages and versions,
927returning a hashref of the form:
928
929 {
930 'Package::Name' => {
931 version => '0.123',
932 file => 'Package/Name.pm'
933 },
934 'OtherPackage::Name' => ...
935 }
936
937The C<DB> and C<main> packages are always omitted, as are any "private"
938packages that have leading underscores in the namespace (e.g.
939C<Foo::_private>)
940
941Note that the file path is relative to C<$dir> if that is specified.
942This B<must not> be used directly for CPAN META C<provides>. See
943the C<provides> method instead.
944
945=item C<< log_info (internal) >>
946
947Used internally to perform logging; imported from Log::Contextual if
948Log::Contextual has already been loaded, otherwise simply calls warn.
949
950=back
951
952=head2 Object methods
953
954=over 4
955
956=item C<< name() >>
957
958Returns the name of the package represented by this module. If there
959are more than one packages, it makes a best guess based on the
960filename. If it's a script (i.e. not a *.pm) the package name is
961'main'.
962
963=item C<< version($package) >>
964
965Returns the version as defined by the $VERSION variable for the
966package as returned by the C<name> method if no arguments are
967given. If given the name of a package it will attempt to return the
968version of that package if it is specified in the file.
969
970=item C<< filename() >>
971
972Returns the absolute path to the file.
973
974=item C<< packages_inside() >>
975
976Returns a list of packages. Note: this is a raw list of packages
977discovered (or assumed, in the case of C<main>). It is not
978filtered for C<DB>, C<main> or private packages the way the
979C<provides> method does. Invalid package names are not returned,
980for example "Foo:Bar". Strange but valid package names are
981returned, for example "Foo::Bar::", and are left up to the caller
982on how to handle.
983
984=item C<< pod_inside() >>
985
986Returns a list of POD sections.
987
988=item C<< contains_pod() >>
989
990Returns true if there is any POD in the file.
991
992=item C<< pod($section) >>
993
994Returns the POD data in the given section.
995
996=back
997
998=head1 AUTHOR
999
1000Original code from Module::Build::ModuleInfo by Ken Williams
1001<kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
1002
1003Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
1004assistance from David Golden (xdg) <dagolden@cpan.org>.
1005
1006=head1 COPYRIGHT & LICENSE
1007
1008Original code Copyright (c) 2001-2011 Ken Williams.
1009Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
1010All rights reserved.
1011
1012This library is free software; you can redistribute it and/or
1013modify it under the same terms as Perl itself.
1014
1015=cut
1016
 
# spent 7µs within Module::Metadata::CORE:qr which was called 7 times, avg 957ns/call: # once (2µs+0s) by Module::Load::Conditional::BEGIN@14 at line 31 # once (1µs+0s) by Module::Load::Conditional::BEGIN@14 at line 41 # once (900ns+0s) by Module::Load::Conditional::BEGIN@14 at line 49 # once (900ns+0s) by Module::Load::Conditional::BEGIN@14 at line 61 # once (700ns+0s) by Module::Load::Conditional::BEGIN@14 at line 83 # once (700ns+0s) by Module::Load::Conditional::BEGIN@14 at line 33 # once (600ns+0s) by Module::Load::Conditional::BEGIN@14 at line 72
sub Module::Metadata::CORE:qr; # opcode
# spent 111µs within Module::Metadata::CORE:regcomp which was called 3 times, avg 37µs/call: # once (42µs+0s) by Module::Load::Conditional::BEGIN@14 at line 61 # once (38µs+0s) by Module::Load::Conditional::BEGIN@14 at line 49 # once (30µs+0s) by Module::Load::Conditional::BEGIN@14 at line 83
sub Module::Metadata::CORE:regcomp; # opcode
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.