← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:09 2023

Filename/usr/share/perl/5.36/Module/Metadata.pm
StatementsExecuted 38 statements in 3.22ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1112.79ms2.88msModule::Metadata::::BEGIN@39Module::Metadata::BEGIN@39
331296µs296µsModule::Metadata::::CORE:regcompModule::Metadata::CORE:regcomp (opcode)
1118µs8µsModule::Metadata::::BEGIN@20Module::Metadata::BEGIN@20
1117µs9µsModule::Metadata::::BEGIN@14Module::Metadata::BEGIN@14
1117µs25µsModule::Metadata::::BEGIN@27Module::Metadata::BEGIN@27
1116µs24µsModule::Metadata::::BEGIN@767Module::Metadata::BEGIN@767
1115µs17µsModule::Metadata::::BEGIN@19Module::Metadata::BEGIN@19
1114µs15µsModule::Metadata::::BEGIN@21Module::Metadata::BEGIN@21
7714µs4µsModule::Metadata::::CORE:qrModule::Metadata::CORE:qr (opcode)
1113µs16µsModule::Metadata::::BEGIN@15Module::Metadata::BEGIN@15
1113µs3µsModule::Metadata::::BEGIN@28Module::Metadata::BEGIN@28
111300ns300nsModule::Metadata::::__ANON__Module::Metadata::__ANON__ (xsub)
0000s0sModule::Metadata::::__ANON__[:143]Module::Metadata::__ANON__[:143]
0000s0sModule::Metadata::::__ANON__[:146]Module::Metadata::__ANON__[:146]
0000s0sModule::Metadata::::__ANON__[:164]Module::Metadata::__ANON__[:164]
0000s0sModule::Metadata::::__ANON__[:202]Module::Metadata::__ANON__[:202]
0000s0sModule::Metadata::::__ANON__[:254]Module::Metadata::__ANON__[:254]
0000s0sModule::Metadata::::__ANON__[:25]Module::Metadata::__ANON__[:25]
0000s0sModule::Metadata::::__ANON__[:312]Module::Metadata::__ANON__[:312]
0000s0sModule::Metadata::::__ANON__[:332]Module::Metadata::__ANON__[:332]
0000s0sModule::Metadata::::__ANON__[:356]Module::Metadata::__ANON__[:356]
0000s0sModule::Metadata::::__ANON__[:36]Module::Metadata::__ANON__[:36]
0000s0sModule::Metadata::::__ANON__[:739]Module::Metadata::__ANON__[:739]
0000s0sModule::Metadata::::__ANON__[:747]Module::Metadata::__ANON__[:747]
0000s0sModule::Metadata::::__ANON__[:762]Module::Metadata::__ANON__[:762]
0000s0sModule::Metadata::::__ANON__[:769]Module::Metadata::__ANON__[:769]
0000s0sModule::Metadata::::__clean_evalModule::Metadata::__clean_eval
0000s0sModule::Metadata::::__uniqModule::Metadata::__uniq
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_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::::is_indexableModule::Metadata::is_indexable
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:tw=78
3package Module::Metadata; # git description: v1.000036-4-g435a294
4# ABSTRACT: Gather package and POD information from perl module files
5
6# Adapted from Perl-licensed code originally distributed with
7# Module-Build by Ken Williams
8
9# This module provides routines to gather information about
10# perl modules (assuming this may be expanded in the distant
11# parrot future to look at other types of modules).
12
13sub __clean_eval { eval $_[0] }
14216µs210µs
# spent 9µs (7+1) within Module::Metadata::BEGIN@14 which was called: # once (7µs+1µs) by Module::Load::Conditional::BEGIN@14 at line 14
use strict;
# spent 9µs making 1 call to Module::Metadata::BEGIN@14 # spent 1µs making 1 call to strict::import
15221µs230µs
# spent 16µs (3+13) within Module::Metadata::BEGIN@15 which was called: # once (3µs+13µs) by Module::Load::Conditional::BEGIN@14 at line 15
use warnings;
# spent 16µs making 1 call to Module::Metadata::BEGIN@15 # spent 13µs making 1 call to warnings::import
16
171300nsour $VERSION = '1.000037';
18
19214µs228µs
# spent 17µs (5+12) within Module::Metadata::BEGIN@19 which was called: # once (5µs+12µs) by Module::Load::Conditional::BEGIN@14 at line 19
use Carp qw/croak/;
# spent 17µs making 1 call to Module::Metadata::BEGIN@19 # spent 12µs making 1 call to Exporter::import
20241µs28µs
# spent 8µs (8+300ns) within Module::Metadata::BEGIN@20 which was called: # once (8µs+300ns) by Module::Load::Conditional::BEGIN@14 at line 20
use File::Spec;
# spent 8µs making 1 call to Module::Metadata::BEGIN@20 # spent 300ns making 1 call to Module::Metadata::__ANON__
21
# spent 15µs (4+11) within Module::Metadata::BEGIN@21 which was called: # once (4µs+11µs) by Module::Load::Conditional::BEGIN@14 at line 26
BEGIN {
22 # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl
23 eval {
2432µs111µs require Fcntl; Fcntl->import('SEEK_SET'); 1;
# spent 11µs making 1 call to Exporter::import
25 } or *SEEK_SET = sub { 0 }
26117µs115µs}
# spent 15µs making 1 call to Module::Metadata::BEGIN@21
27363µs343µs
# spent 25µs (7+18) within Module::Metadata::BEGIN@27 which was called: # once (7µs+18µs) by Module::Load::Conditional::BEGIN@14 at line 27
use version 0.87;
# spent 25µs making 1 call to Module::Metadata::BEGIN@27 # spent 13µs making 1 call to version::import # spent 5µs making 1 call to version::_VERSION
28
# spent 3µs within Module::Metadata::BEGIN@28 which was called: # once (3µs+0s) by Module::Load::Conditional::BEGIN@14 at line 38
BEGIN {
2912µs if ($INC{'Log/Contextual.pm'}) {
30 require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs
31 Log::Contextual->import('log_info',
32 '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }),
33 );
34 }
35 else {
3611µs *log_info = sub (&) { warn $_[0]->() };
37 }
38112µs13µs}
# spent 3µs making 1 call to Module::Metadata::BEGIN@28
3922.43ms22.90ms
# spent 2.88ms (2.79+84µs) within Module::Metadata::BEGIN@39 which was called: # once (2.79ms+84µs) by Module::Load::Conditional::BEGIN@14 at line 39
use File::Find qw(find);
# spent 2.88ms making 1 call to Module::Metadata::BEGIN@39 # spent 21µs making 1 call to Exporter::import
40
4116µ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
42
4313µs1300nsmy $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
# spent 300ns making 1 call to Module::Metadata::CORE:qr
44 [a-zA-Z_] # the first word CANNOT start with a digit
45 (?:
46 [\w']? # can contain letters, digits, _, or ticks
47 \w # But, NO multi-ticks or trailing ticks
48 )*
49}x;
50
5111µs1300nsmy $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
# spent 300ns making 1 call to Module::Metadata::CORE:qr
52 \w # the 2nd+ word CAN start with digits
53 (?:
54 [\w']? # and can contain letters or ticks
55 \w # But, NO multi-ticks or trailing ticks
56 )*
57}x;
58
591125µs2121µsmy $PKG_NAME_REGEXP = qr{ # match a package name
# spent 121µs making 1 call to Module::Metadata::CORE:regcomp # spent 400ns making 1 call to Module::Metadata::CORE:qr
60 (?: :: )? # a pkg name can start with arisdottle
61 $PKG_FIRST_WORD_REGEXP # a package word
62 (?:
63 (?: :: )+ ### arisdottle (allow one or many times)
64 $PKG_ADDL_WORD_REGEXP ### a package word
65 )* # ^ zero, one or many times
66 (?:
67 :: # allow trailing arisdottle
68 )?
69}x;
70
711124µs2121µsmy $PKG_REGEXP = qr{ # match a package declaration
# spent 120µs making 1 call to Module::Metadata::CORE:regcomp # spent 400ns making 1 call to Module::Metadata::CORE:qr
72 ^[\s\{;]* # intro chars on a line
73 package # the word 'package'
74 \s+ # whitespace
75 ($PKG_NAME_REGEXP) # a package name
76 \s* # optional whitespace
77 ($V_NUM_REGEXP)? # optional version number
78 \s* # optional whitesapce
79 [;\{] # semicolon line terminator or block start (since 5.16)
80}x;
81
8211µs1300nsmy $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
# spent 300ns making 1 call to Module::Metadata::CORE:qr
83 ([\$*]) # sigil - $ or *
84 (
85 ( # optional leading package name
86 (?:::|\')? # possibly starting like just :: (a la $::VERSION)
87 (?:\w+(?:::|\'))* # Foo::Bar:: ...
88 )?
89 VERSION
90 )\b
91}x;
92
93158µs255µsmy $VERS_REGEXP = qr{ # match a VERSION definition
# spent 55µs making 1 call to Module::Metadata::CORE:regcomp # spent 300ns making 1 call to Module::Metadata::CORE:qr
94 (?:
95 \(\s*$VARNAME_REGEXP\s*\) # with parens
96 |
97 $VARNAME_REGEXP # without parens
98 )
99 \s*
100 =[^=~>] # = but not ==, nor =~, nor =>
101}x;
102
103sub new_from_file {
104 my $class = shift;
105 my $filename = File::Spec->rel2abs( shift );
106
107 return undef unless defined( $filename ) && -f $filename;
108 return $class->_init(undef, $filename, @_);
109}
110
111sub new_from_handle {
112 my $class = shift;
113 my $handle = shift;
114 my $filename = shift;
115 return undef unless defined($handle) && defined($filename);
116 $filename = File::Spec->rel2abs( $filename );
117
118 return $class->_init(undef, $filename, @_, handle => $handle);
119
120}
121
122
123sub new_from_module {
124 my $class = shift;
125 my $module = shift;
126 my %props = @_;
127
128 $props{inc} ||= \@INC;
129 my $filename = $class->find_module_by_name( $module, $props{inc} );
130 return undef unless defined( $filename ) && -f $filename;
131 return $class->_init($module, $filename, %props);
132}
133
134{
135
136 my $compare_versions = sub {
137 my ($v1, $op, $v2) = @_;
138 $v1 = version->new($v1)
139 unless UNIVERSAL::isa($v1,'version');
140
141 my $eval_str = "\$v1 $op \$v2";
142 my $result = eval $eval_str;
143 log_info { "error comparing versions: '$eval_str' $@" } if $@;
144
145 return $result;
14612µs };
147
148 my $normalize_version = sub {
149 my ($version) = @_;
150 if ( $version =~ /[=<>!,]/ ) { # logic, not just version
151 # take as is without modification
152 }
153 elsif ( ref $version eq 'version' ) { # version objects
154 $version = $version->is_qv ? $version->normal : $version->stringify;
155 }
156 elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
157 # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
158 $version = "v$version";
159 }
160 else {
161 # leave alone
162 }
163 return $version;
1641600ns };
165
166 # separate out some of the conflict resolution logic
167
168 my $resolve_module_versions = sub {
169 my $packages = shift;
170
171 my( $file, $version );
172 my $err = '';
173 foreach my $p ( @$packages ) {
174 if ( defined( $p->{version} ) ) {
175 if ( defined( $version ) ) {
176 if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
177 $err .= " $p->{file} ($p->{version})\n";
178 }
179 else {
180 # same version declared multiple times, ignore
181 }
182 }
183 else {
184 $file = $p->{file};
185 $version = $p->{version};
186 }
187 }
188 $file ||= $p->{file} if defined( $p->{file} );
189 }
190
191 if ( $err ) {
192 $err = " $file ($version)\n" . $err;
193 }
194
195 my %result = (
196 file => $file,
197 version => $version,
198 err => $err
199 );
200
201 return \%result;
20211µs };
203
204 sub provides {
205 my $class = shift;
206
207 croak "provides() requires key/value pairs \n" if @_ % 2;
208 my %args = @_;
209
210 croak "provides() takes only one of 'dir' or 'files'\n"
211 if $args{dir} && $args{files};
212
213 croak "provides() requires a 'version' argument"
214 unless defined $args{version};
215
216 croak "provides() does not support version '$args{version}' metadata"
217 unless grep $args{version} eq $_, qw/1.4 2/;
218
219 $args{prefix} = 'lib' unless defined $args{prefix};
220
221 my $p;
222 if ( $args{dir} ) {
223 $p = $class->package_versions_from_directory($args{dir});
224 }
225 else {
226 croak "provides() requires 'files' to be an array reference\n"
227 unless ref $args{files} eq 'ARRAY';
228 $p = $class->package_versions_from_directory($args{files});
229 }
230
231 # Now, fix up files with prefix
232 if ( length $args{prefix} ) { # check in case disabled with q{}
233 $args{prefix} =~ s{/$}{};
234 for my $v ( values %$p ) {
235 $v->{file} = "$args{prefix}/$v->{file}";
236 }
237 }
238
239 return $p
240 }
241
242 sub package_versions_from_directory {
243 my ( $class, $dir, $files ) = @_;
244
245 my @files;
246
247 if ( $files ) {
248 @files = @$files;
249 }
250 else {
251 find( {
252 wanted => sub {
253 push @files, $_ if -f $_ && /\.pm$/;
254 },
255 no_chdir => 1,
256 }, $dir );
257 }
258
259 # First, we enumerate all packages & versions,
260 # separating into primary & alternative candidates
261 my( %prime, %alt );
262 foreach my $file (@files) {
263 my $mapped_filename = File::Spec->abs2rel( $file, $dir );
264 my @path = File::Spec->splitdir( $mapped_filename );
265 (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
266
267 my $pm_info = $class->new_from_file( $file );
268
269 foreach my $package ( $pm_info->packages_inside ) {
270 next if $package eq 'main'; # main can appear numerous times, ignore
271 next if $package eq 'DB'; # special debugging package, ignore
272 next if grep /^_/, split( /::/, $package ); # private package, ignore
273
274 my $version = $pm_info->version( $package );
275
276 $prime_package = $package if lc($prime_package) eq lc($package);
277 if ( $package eq $prime_package ) {
278 if ( exists( $prime{$package} ) ) {
279 croak "Unexpected conflict in '$package'; multiple versions found.\n";
280 }
281 else {
282 $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
283 $prime{$package}{file} = $mapped_filename;
284 $prime{$package}{version} = $version if defined( $version );
285 }
286 }
287 else {
288 push( @{$alt{$package}}, {
289 file => $mapped_filename,
290 version => $version,
291 } );
292 }
293 }
294 }
295
296 # Then we iterate over all the packages found above, identifying conflicts
297 # and selecting the "best" candidate for recording the file & version
298 # for each package.
299 foreach my $package ( keys( %alt ) ) {
300 my $result = $resolve_module_versions->( $alt{$package} );
301
302 if ( exists( $prime{$package} ) ) { # primary package selected
303
304 if ( $result->{err} ) {
305 # Use the selected primary package, but there are conflicting
306 # errors among multiple alternative packages that need to be
307 # reported
308 log_info {
309 "Found conflicting versions for package '$package'\n" .
310 " $prime{$package}{file} ($prime{$package}{version})\n" .
311 $result->{err}
312 };
313
314 }
315 elsif ( defined( $result->{version} ) ) {
316 # There is a primary package selected, and exactly one
317 # alternative package
318
319 if ( exists( $prime{$package}{version} ) &&
320 defined( $prime{$package}{version} ) ) {
321 # Unless the version of the primary package agrees with the
322 # version of the alternative package, report a conflict
323 if ( $compare_versions->(
324 $prime{$package}{version}, '!=', $result->{version}
325 )
326 ) {
327
328 log_info {
329 "Found conflicting versions for package '$package'\n" .
330 " $prime{$package}{file} ($prime{$package}{version})\n" .
331 " $result->{file} ($result->{version})\n"
332 };
333 }
334
335 }
336 else {
337 # The prime package selected has no version so, we choose to
338 # use any alternative package that does have a version
339 $prime{$package}{file} = $result->{file};
340 $prime{$package}{version} = $result->{version};
341 }
342
343 }
344 else {
345 # no alt package found with a version, but we have a prime
346 # package so we use it whether it has a version or not
347 }
348
349 }
350 else { # No primary package was selected, use the best alternative
351
352 if ( $result->{err} ) {
353 log_info {
354 "Found conflicting versions for package '$package'\n" .
355 $result->{err}
356 };
357 }
358
359 # Despite possible conflicting versions, we choose to record
360 # something rather than nothing
361 $prime{$package}{file} = $result->{file};
362 $prime{$package}{version} = $result->{version}
363 if defined( $result->{version} );
364 }
365 }
366
367 # Normalize versions. Can't use exists() here because of bug in YAML::Node.
368 # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
369 for (grep defined $_->{version}, values %prime) {
370 $_->{version} = $normalize_version->( $_->{version} );
371 }
372
373 return \%prime;
374 }
375}
376
377
3781300nssub _init {
379 my $class = shift;
380 my $module = shift;
381 my $filename = shift;
382 my %props = @_;
383
384 my $handle = delete $props{handle};
385 my( %valid_props, @valid_props );
386 @valid_props = qw( collect_pod inc decode_pod );
387 @valid_props{@valid_props} = delete( @props{@valid_props} );
388 warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
389
390 my %data = (
391 module => $module,
392 filename => $filename,
393 version => undef,
394 packages => [],
395 versions => {},
396 pod => {},
397 pod_headings => [],
398 collect_pod => 0,
399
400 %valid_props,
401 );
402
403 my $self = bless(\%data, $class);
404
405 if ( not $handle ) {
406 my $filename = $self->{filename};
407 open $handle, '<', $filename
408 or croak( "Can't open '$filename': $!" );
409
410 $self->_handle_bom($handle, $filename);
411 }
412 $self->_parse_fh($handle);
413
414 @{$self->{packages}} = __uniq(@{$self->{packages}});
415
416 unless($self->{module} and length($self->{module})) {
417 # CAVEAT (possible TODO): .pmc files not treated the same as .pm
418 if ($self->{filename} =~ /\.pm$/) {
419 my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
420 $f =~ s/\..+$//;
421 my @candidates = grep /(^|::)$f$/, @{$self->{packages}};
422 $self->{module} = shift(@candidates); # this may be undef
423 }
424 else {
425 # this seems like an atrocious heuristic, albeit marginally better than
426 # what was here before. It should be rewritten entirely to be more like
427 # "if it's not a .pm file, it's not require()able as a name, therefore
428 # name() should be undef."
429 if ((grep /main/, @{$self->{packages}})
430 or (grep /main/, keys %{$self->{versions}})) {
431 $self->{module} = 'main';
432 }
433 else {
434 # TODO: this should maybe default to undef instead
435 $self->{module} = $self->{packages}[0] || '';
436 }
437 }
438 }
439
440 $self->{version} = $self->{versions}{$self->{module}}
441 if defined( $self->{module} );
442
443 return $self;
444}
445
446# class method
447sub _do_find_module {
448 my $class = shift;
449 my $module = shift || croak 'find_module_by_name() requires a package name';
450 my $dirs = shift || \@INC;
451
452 my $file = File::Spec->catfile(split( /::/, $module));
453 foreach my $dir ( @$dirs ) {
454 my $testfile = File::Spec->catfile($dir, $file);
455 return [ File::Spec->rel2abs( $testfile ), $dir ]
456 if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
457 # CAVEAT (possible TODO): .pmc files are not discoverable here
458 $testfile .= '.pm';
459 return [ File::Spec->rel2abs( $testfile ), $dir ]
460 if -e $testfile;
461 }
462 return;
463}
464
465# class method
466sub find_module_by_name {
467 my $found = shift()->_do_find_module(@_) or return;
468 return $found->[0];
469}
470
471# class method
472sub find_module_dir_by_name {
473 my $found = shift()->_do_find_module(@_) or return;
474 return $found->[1];
475}
476
477
478# given a line of perl code, attempt to parse it if it looks like a
479# $VERSION assignment, returning sigil, full name, & package name
480sub _parse_version_expression {
481 my $self = shift;
482 my $line = shift;
483
484 my( $sigil, $variable_name, $package);
485 if ( $line =~ /$VERS_REGEXP/o ) {
486 ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
487 if ( $package ) {
488 $package = ($package eq '::') ? 'main' : $package;
489 $package =~ s/::$//;
490 }
491 }
492
493 return ( $sigil, $variable_name, $package );
494}
495
496# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
497# If there's one, then skip it and set the :encoding layer appropriately.
498sub _handle_bom {
499 my ($self, $fh, $filename) = @_;
500
501 my $pos = tell $fh;
502 return unless defined $pos;
503
504 my $buf = ' ' x 2;
505 my $count = read $fh, $buf, length $buf;
506 return unless defined $count and $count >= 2;
507
508 my $encoding;
509 if ( $buf eq "\x{FE}\x{FF}" ) {
510 $encoding = 'UTF-16BE';
511 }
512 elsif ( $buf eq "\x{FF}\x{FE}" ) {
513 $encoding = 'UTF-16LE';
514 }
515 elsif ( $buf eq "\x{EF}\x{BB}" ) {
516 $buf = ' ';
517 $count = read $fh, $buf, length $buf;
518 if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
519 $encoding = 'UTF-8';
520 }
521 }
522
523 if ( defined $encoding ) {
524 if ( "$]" >= 5.008 ) {
525 binmode( $fh, ":encoding($encoding)" );
526 }
527 }
528 else {
529 seek $fh, $pos, SEEK_SET
530 or croak( sprintf "Can't reset position to the top of '$filename'" );
531 }
532
533 return $encoding;
534}
535
536sub _parse_fh {
537 my ($self, $fh) = @_;
538
539 my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
540 my( @packages, %vers, %pod, @pod );
541 my $package = 'main';
542 my $pod_sect = '';
543 my $pod_data = '';
544 my $in_end = 0;
545 my $encoding = '';
546
547 while (defined( my $line = <$fh> )) {
548 my $line_num = $.;
549
550 chomp( $line );
551
552 # From toke.c : any line that begins by "=X", where X is an alphabetic
553 # character, introduces a POD segment.
554 my $is_cut;
555 if ( $line =~ /^=([a-zA-Z].*)/ ) {
556 my $cmd = $1;
557 # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
558 # character (which includes the newline, but here we chomped it away).
559 $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
560 $in_pod = !$is_cut;
561 }
562
563 if ( $in_pod ) {
564
565 if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
566 push( @pod, $1 );
567 if ( $self->{collect_pod} && length( $pod_data ) ) {
568 $pod{$pod_sect} = $pod_data;
569 $pod_data = '';
570 }
571 $pod_sect = $1;
572 }
573 elsif ( $self->{collect_pod} ) {
574 if ( $self->{decode_pod} && $line =~ /^=encoding ([\w-]+)/ ) {
575 $encoding = $1;
576 }
577 $pod_data .= "$line\n";
578 }
579 next;
580 }
581 elsif ( $is_cut ) {
582 if ( $self->{collect_pod} && length( $pod_data ) ) {
583 $pod{$pod_sect} = $pod_data;
584 $pod_data = '';
585 }
586 $pod_sect = '';
587 next;
588 }
589
590 # Skip after __END__
591 next if $in_end;
592
593 # Skip comments in code
594 next if $line =~ /^\s*#/;
595
596 # Would be nice if we could also check $in_string or something too
597 if ($line eq '__END__') {
598 $in_end++;
599 next;
600 }
601
602 last if $line eq '__DATA__';
603
604 # parse $line to see if it's a $VERSION declaration
605 my( $version_sigil, $version_fullname, $version_package ) =
606 index($line, 'VERSION') >= 1
607 ? $self->_parse_version_expression( $line )
608 : ();
609
610 if ( $line =~ /$PKG_REGEXP/o ) {
611 $package = $1;
612 my $version = $2;
613 push( @packages, $package ) unless grep( $package eq $_, @packages );
614 $need_vers = defined $version ? 0 : 1;
615
616 if ( not exists $vers{$package} and defined $version ){
617 # Upgrade to a version object.
618 my $dwim_version = eval { _dwim_version($version) };
619 croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
620 unless defined $dwim_version; # "0" is OK!
621 $vers{$package} = $dwim_version;
622 }
623 }
624
625 # VERSION defined with full package spec, i.e. $Module::VERSION
626 elsif ( $version_fullname && $version_package ) {
627 # we do NOT save this package in found @packages
628 $need_vers = 0 if $version_package eq $package;
629
630 unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
631 $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
632 }
633 }
634
635 # first non-comment line in undeclared package main is VERSION
636 elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
637 $need_vers = 0;
638 my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
639 $vers{$package} = $v;
640 push( @packages, 'main' );
641 }
642
643 # first non-comment line in undeclared package defines package main
644 elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
645 $need_vers = 1;
646 $vers{main} = '';
647 push( @packages, 'main' );
648 }
649
650 # only keep if this is the first $VERSION seen
651 elsif ( $version_fullname && $need_vers ) {
652 $need_vers = 0;
653 my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
654
655 unless ( defined $vers{$package} && length $vers{$package} ) {
656 $vers{$package} = $v;
657 }
658 }
659 } # end loop over each line
660
661 if ( $self->{collect_pod} && length($pod_data) ) {
662 $pod{$pod_sect} = $pod_data;
663 }
664
665 if ( $self->{decode_pod} && $encoding ) {
666 require Encode;
667 $_ = Encode::decode( $encoding, $_ ) for values %pod;
668 }
669
670 $self->{versions} = \%vers;
671 $self->{packages} = \@packages;
672 $self->{pod} = \%pod;
673 $self->{pod_headings} = \@pod;
674}
675
676sub __uniq (@)
677{
678 my (%seen, $key);
679 grep !$seen{ $key = $_ }++, @_;
680}
681
682{
6831200nsmy $pn = 0;
684sub _evaluate_version_line {
685 my $self = shift;
686 my( $sigil, $variable_name, $line ) = @_;
687
688 # We compile into a local sub because 'use version' would cause
689 # compiletime/runtime issues with local()
690 $pn++; # everybody gets their own package
691 my $eval = qq{ my \$dummy = q# Hide from _packages_inside()
692 #; package Module::Metadata::_version::p${pn};
693 use version;
694 sub {
695 local $sigil$variable_name;
696 $line;
697 return \$$variable_name if defined \$$variable_name;
698 return \$Module::Metadata::_version::p${pn}::$variable_name;
699 };
700 };
701
702 $eval = $1 if $eval =~ m{^(.+)}s;
703
704 local $^W;
705 # Try to get the $VERSION
706 my $vsub = __clean_eval($eval);
707 # some modules say $VERSION <equal sign> $Foo::Bar::VERSION, but Foo::Bar isn't
708 # installed, so we need to hunt in ./lib for it
709 if ( $@ =~ /Can't locate/ && -d 'lib' ) {
710 local @INC = ('lib',@INC);
711 $vsub = __clean_eval($eval);
712 }
713 warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
714 if $@;
715
716 (ref($vsub) eq 'CODE') or
717 croak "failed to build version sub for $self->{filename}";
718
719 my $result = eval { $vsub->() };
720 # FIXME: $eval is not the right thing to print here
721 croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
722 if $@;
723
724 # Upgrade it into a version object
725 my $version = eval { _dwim_version($result) };
726
727 # FIXME: $eval is not the right thing to print here
728 croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
729 unless defined $version; # "0" is OK!
730
731 return $version;
732}
733}
734
735# Try to DWIM when things fail the lax version test in obvious ways
736{
7371100ns my @version_prep = (
738 # Best case, it just works
739 sub { return shift },
740
741 # If we still don't have a version, try stripping any
742 # trailing junk that is prohibited by lax rules
743 sub {
744 my $v = shift;
745 $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
746 return $v;
747 },
748
749 # Activestate apparently creates custom versions like '1.23_45_01', which
750 # cause version.pm to think it's an invalid alpha. So check for that
751 # and strip them
752 sub {
753 my $v = shift;
754 my $num_dots = () = $v =~ m{(\.)}g;
755 my $num_unders = () = $v =~ m{(_)}g;
756 my $leading_v = substr($v,0,1) eq 'v';
757 if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
758 $v =~ s{_}{}g;
759 $num_unders = () = $v =~ m{(_)}g;
760 }
761 return $v;
762 },
763
764 # Worst case, try numifying it like we would have before version objects
765 sub {
766 my $v = shift;
7672262µs241µs
# spent 24µs (6+18) within Module::Metadata::BEGIN@767 which was called: # once (6µs+18µs) by Module::Load::Conditional::BEGIN@14 at line 767
no warnings 'numeric';
# spent 24µs making 1 call to Module::Metadata::BEGIN@767 # spent 18µs making 1 call to warnings::unimport
768 return 0 + $v;
769 },
770
77112µs );
772
773 sub _dwim_version {
774 my ($result) = shift;
775
776 return $result if ref($result) eq 'version';
777
778 my ($version, $error);
779 for my $f (@version_prep) {
780 $result = $f->($result);
781 $version = eval { version->new($result) };
782 $error ||= $@ if $@; # capture first failure
783 last if defined $version;
784 }
785
786 croak $error unless defined $version;
787
788 return $version;
789 }
790}
791
792############################################################
793
794# accessors
7951200nssub name { $_[0]->{module} }
796
797sub filename { $_[0]->{filename} }
798sub packages_inside { @{$_[0]->{packages}} }
799sub pod_inside { @{$_[0]->{pod_headings}} }
800sub contains_pod { 0+@{$_[0]->{pod_headings}} }
801
802sub version {
803 my $self = shift;
804 my $mod = shift || $self->{module};
805 my $vers;
806 if ( defined( $mod ) && length( $mod ) &&
807 exists( $self->{versions}{$mod} ) ) {
808 return $self->{versions}{$mod};
809 }
810 else {
811 return undef;
812 }
813}
814
815sub pod {
816 my $self = shift;
817 my $sect = shift;
818 if ( defined( $sect ) && length( $sect ) &&
819 exists( $self->{pod}{$sect} ) ) {
820 return $self->{pod}{$sect};
821 }
822 else {
823 return undef;
824 }
825}
826
827sub is_indexable {
828 my ($self, $package) = @_;
829
830 my @indexable_packages = grep $_ ne 'main', $self->packages_inside;
831
832 # check for specific package, if provided
833 return !! grep $_ eq $package, @indexable_packages if $package;
834
835 # otherwise, check for any indexable packages at all
836 return !! @indexable_packages;
837}
838
839112µs1;
840
841__END__
 
# spent 4µs within Module::Metadata::CORE:qr which was called 7 times, avg 500ns/call: # once (2µs+0s) by Module::Load::Conditional::BEGIN@14 at line 41 # once (400ns+0s) by Module::Load::Conditional::BEGIN@14 at line 71 # once (400ns+0s) by Module::Load::Conditional::BEGIN@14 at line 59 # once (300ns+0s) by Module::Load::Conditional::BEGIN@14 at line 93 # once (300ns+0s) by Module::Load::Conditional::BEGIN@14 at line 43 # once (300ns+0s) by Module::Load::Conditional::BEGIN@14 at line 51 # once (300ns+0s) by Module::Load::Conditional::BEGIN@14 at line 82
sub Module::Metadata::CORE:qr; # opcode
# spent 296µs within Module::Metadata::CORE:regcomp which was called 3 times, avg 99µs/call: # once (121µs+0s) by Module::Load::Conditional::BEGIN@14 at line 59 # once (120µs+0s) by Module::Load::Conditional::BEGIN@14 at line 71 # once (55µs+0s) by Module::Load::Conditional::BEGIN@14 at line 93
sub Module::Metadata::CORE:regcomp; # opcode
# spent 300ns within Module::Metadata::__ANON__ which was called: # once (300ns+0s) by Module::Metadata::BEGIN@20 at line 20
sub Module::Metadata::__ANON__; # xsub
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.