Commit | Line | Data |
5ac756c6 |
1 | # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- |
2 | # vim:ts=8:sw=2:et:sta:sts=2 |
3 | package Module::Metadata; |
4 | |
cd41f0db |
5 | # Adapted from Perl-licensed code originally distributed with |
6 | # Module-Build by Ken Williams |
5ac756c6 |
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 | |
12 | use strict; |
13 | use vars qw($VERSION); |
9f6d641e |
14 | $VERSION = '1.000009'; |
5ac756c6 |
15 | $VERSION = eval $VERSION; |
16 | |
6f3c7f28 |
17 | use Carp qw/croak/; |
5ac756c6 |
18 | use File::Spec; |
19 | use IO::File; |
4850170c |
20 | use version 0.87; |
3db27017 |
21 | BEGIN { |
22 | if ($INC{'Log/Contextual.pm'}) { |
23 | Log::Contextual->import('log_info'); |
24 | } else { |
e6ddd765 |
25 | *log_info = sub (&) { warn $_[0]->() }; |
3db27017 |
26 | } |
27 | } |
5ac756c6 |
28 | use File::Find qw(find); |
29 | |
30 | my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal |
31 | |
32 | my $PKG_REGEXP = qr{ # match a package declaration |
33 | ^[\s\{;]* # intro chars on a line |
34 | package # the word 'package' |
35 | \s+ # whitespace |
36 | ([\w:]+) # a package name |
37 | \s* # optional whitespace |
38 | ($V_NUM_REGEXP)? # optional version number |
39 | \s* # optional whitesapce |
710f253f |
40 | [;\{] # semicolon line terminator or block start (since 5.16) |
5ac756c6 |
41 | }x; |
42 | |
43 | my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name |
44 | ([\$*]) # sigil - $ or * |
45 | ( |
46 | ( # optional leading package name |
47 | (?:::|\')? # possibly starting like just :: (Ì la $::VERSION) |
48 | (?:\w+(?:::|\'))* # Foo::Bar:: ... |
49 | )? |
50 | VERSION |
51 | )\b |
52 | }x; |
53 | |
54 | my $VERS_REGEXP = qr{ # match a VERSION definition |
55 | (?: |
56 | \(\s*$VARNAME_REGEXP\s*\) # with parens |
57 | | |
58 | $VARNAME_REGEXP # without parens |
59 | ) |
60 | \s* |
61 | =[^=~] # = but not ==, nor =~ |
62 | }x; |
63 | |
64 | |
65 | sub new_from_file { |
66 | my $class = shift; |
67 | my $filename = File::Spec->rel2abs( shift ); |
68 | |
69 | return undef unless defined( $filename ) && -f $filename; |
70 | return $class->_init(undef, $filename, @_); |
71 | } |
72 | |
f33c0a6c |
73 | sub new_from_handle { |
74 | my $class = shift; |
75 | my $handle = shift; |
76 | my $filename = shift; |
77 | return undef unless defined($handle) && defined($filename); |
78 | $filename = File::Spec->rel2abs( $filename ); |
79 | |
80 | return $class->_init(undef, $filename, @_, handle => $handle); |
81 | |
82 | } |
83 | |
84 | |
5ac756c6 |
85 | sub new_from_module { |
86 | my $class = shift; |
87 | my $module = shift; |
88 | my %props = @_; |
89 | |
90 | $props{inc} ||= \@INC; |
91 | my $filename = $class->find_module_by_name( $module, $props{inc} ); |
92 | return undef unless defined( $filename ) && -f $filename; |
93 | return $class->_init($module, $filename, %props); |
94 | } |
95 | |
96 | { |
97 | |
98 | my $compare_versions = sub { |
99 | my ($v1, $op, $v2) = @_; |
4850170c |
100 | $v1 = version->new($v1) |
101 | unless UNIVERSAL::isa($v1,'version'); |
5ac756c6 |
102 | |
103 | my $eval_str = "\$v1 $op \$v2"; |
104 | my $result = eval $eval_str; |
105 | log_info { "error comparing versions: '$eval_str' $@" } if $@; |
106 | |
107 | return $result; |
108 | }; |
109 | |
110 | my $normalize_version = sub { |
111 | my ($version) = @_; |
112 | if ( $version =~ /[=<>!,]/ ) { # logic, not just version |
113 | # take as is without modification |
114 | } |
4850170c |
115 | elsif ( ref $version eq 'version' ) { # version objects |
5ac756c6 |
116 | $version = $version->is_qv ? $version->normal : $version->stringify; |
117 | } |
118 | elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots |
119 | # normalize string tuples without "v": "1.2.3" -> "v1.2.3" |
120 | $version = "v$version"; |
121 | } |
122 | else { |
123 | # leave alone |
124 | } |
125 | return $version; |
126 | }; |
127 | |
128 | # separate out some of the conflict resolution logic |
129 | |
130 | my $resolve_module_versions = sub { |
131 | my $packages = shift; |
132 | |
133 | my( $file, $version ); |
134 | my $err = ''; |
135 | foreach my $p ( @$packages ) { |
136 | if ( defined( $p->{version} ) ) { |
137 | if ( defined( $version ) ) { |
138 | if ( $compare_versions->( $version, '!=', $p->{version} ) ) { |
139 | $err .= " $p->{file} ($p->{version})\n"; |
140 | } else { |
141 | # same version declared multiple times, ignore |
142 | } |
143 | } else { |
144 | $file = $p->{file}; |
145 | $version = $p->{version}; |
146 | } |
147 | } |
148 | $file ||= $p->{file} if defined( $p->{file} ); |
149 | } |
150 | |
151 | if ( $err ) { |
152 | $err = " $file ($version)\n" . $err; |
153 | } |
154 | |
155 | my %result = ( |
156 | file => $file, |
157 | version => $version, |
158 | err => $err |
159 | ); |
160 | |
161 | return \%result; |
162 | }; |
163 | |
ca33f3bd |
164 | sub provides { |
165 | my $class = shift; |
166 | |
6f3c7f28 |
167 | croak "provides() requires key/value pairs \n" if @_ % 2; |
ca33f3bd |
168 | my %args = @_; |
169 | |
6f3c7f28 |
170 | croak "provides() takes only one of 'dir' or 'files'\n" |
ca33f3bd |
171 | if $args{dir} && $args{files}; |
172 | |
6f3c7f28 |
173 | croak "provides() requires a 'version' argument" |
c06d0187 |
174 | unless defined $args{version}; |
175 | |
6f3c7f28 |
176 | croak "provides() does not support version '$args{version}' metadata" |
c06d0187 |
177 | unless grep { $args{version} eq $_ } qw/1.4 2/; |
178 | |
ca33f3bd |
179 | $args{prefix} = 'lib' unless defined $args{prefix}; |
180 | |
181 | my $p; |
182 | if ( $args{dir} ) { |
183 | $p = $class->package_versions_from_directory($args{dir}); |
184 | } |
185 | else { |
6f3c7f28 |
186 | croak "provides() requires 'files' to be an array reference\n" |
ca33f3bd |
187 | unless ref $args{files} eq 'ARRAY'; |
188 | $p = $class->package_versions_from_directory($args{files}); |
189 | } |
190 | |
191 | # Now, fix up files with prefix |
192 | if ( length $args{prefix} ) { # check in case disabled with q{} |
193 | $args{prefix} =~ s{/$}{}; |
194 | for my $v ( values %$p ) { |
195 | $v->{file} = "$args{prefix}/$v->{file}"; |
196 | } |
197 | } |
198 | |
199 | return $p |
200 | } |
201 | |
5ac756c6 |
202 | sub package_versions_from_directory { |
203 | my ( $class, $dir, $files ) = @_; |
204 | |
205 | my @files; |
206 | |
207 | if ( $files ) { |
208 | @files = @$files; |
209 | } else { |
210 | find( { |
211 | wanted => sub { |
212 | push @files, $_ if -f $_ && /\.pm$/; |
213 | }, |
214 | no_chdir => 1, |
215 | }, $dir ); |
216 | } |
217 | |
218 | # First, we enumerate all packages & versions, |
219 | # separating into primary & alternative candidates |
220 | my( %prime, %alt ); |
221 | foreach my $file (@files) { |
222 | my $mapped_filename = File::Spec->abs2rel( $file, $dir ); |
223 | my @path = split( /\//, $mapped_filename ); |
224 | (my $prime_package = join( '::', @path )) =~ s/\.pm$//; |
225 | |
226 | my $pm_info = $class->new_from_file( $file ); |
227 | |
228 | foreach my $package ( $pm_info->packages_inside ) { |
229 | next if $package eq 'main'; # main can appear numerous times, ignore |
230 | next if $package eq 'DB'; # special debugging package, ignore |
231 | next if grep /^_/, split( /::/, $package ); # private package, ignore |
232 | |
233 | my $version = $pm_info->version( $package ); |
234 | |
235 | if ( $package eq $prime_package ) { |
236 | if ( exists( $prime{$package} ) ) { |
6f3c7f28 |
237 | croak "Unexpected conflict in '$package'; multiple versions found.\n"; |
5ac756c6 |
238 | } else { |
239 | $prime{$package}{file} = $mapped_filename; |
240 | $prime{$package}{version} = $version if defined( $version ); |
241 | } |
242 | } else { |
243 | push( @{$alt{$package}}, { |
244 | file => $mapped_filename, |
245 | version => $version, |
246 | } ); |
247 | } |
248 | } |
249 | } |
250 | |
251 | # Then we iterate over all the packages found above, identifying conflicts |
252 | # and selecting the "best" candidate for recording the file & version |
253 | # for each package. |
254 | foreach my $package ( keys( %alt ) ) { |
255 | my $result = $resolve_module_versions->( $alt{$package} ); |
256 | |
257 | if ( exists( $prime{$package} ) ) { # primary package selected |
258 | |
259 | if ( $result->{err} ) { |
260 | # Use the selected primary package, but there are conflicting |
261 | # errors among multiple alternative packages that need to be |
262 | # reported |
263 | log_info { |
264 | "Found conflicting versions for package '$package'\n" . |
265 | " $prime{$package}{file} ($prime{$package}{version})\n" . |
266 | $result->{err} |
267 | }; |
268 | |
269 | } elsif ( defined( $result->{version} ) ) { |
270 | # There is a primary package selected, and exactly one |
271 | # alternative package |
272 | |
273 | if ( exists( $prime{$package}{version} ) && |
274 | defined( $prime{$package}{version} ) ) { |
275 | # Unless the version of the primary package agrees with the |
276 | # version of the alternative package, report a conflict |
277 | if ( $compare_versions->( |
278 | $prime{$package}{version}, '!=', $result->{version} |
279 | ) |
280 | ) { |
281 | |
282 | log_info { |
283 | "Found conflicting versions for package '$package'\n" . |
284 | " $prime{$package}{file} ($prime{$package}{version})\n" . |
285 | " $result->{file} ($result->{version})\n" |
286 | }; |
287 | } |
288 | |
289 | } else { |
290 | # The prime package selected has no version so, we choose to |
291 | # use any alternative package that does have a version |
292 | $prime{$package}{file} = $result->{file}; |
293 | $prime{$package}{version} = $result->{version}; |
294 | } |
295 | |
296 | } else { |
297 | # no alt package found with a version, but we have a prime |
298 | # package so we use it whether it has a version or not |
299 | } |
300 | |
301 | } else { # No primary package was selected, use the best alternative |
302 | |
303 | if ( $result->{err} ) { |
304 | log_info { |
305 | "Found conflicting versions for package '$package'\n" . |
306 | $result->{err} |
307 | }; |
308 | } |
309 | |
310 | # Despite possible conflicting versions, we choose to record |
311 | # something rather than nothing |
312 | $prime{$package}{file} = $result->{file}; |
313 | $prime{$package}{version} = $result->{version} |
314 | if defined( $result->{version} ); |
315 | } |
316 | } |
317 | |
318 | # Normalize versions. Can't use exists() here because of bug in YAML::Node. |
319 | # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18 |
320 | for (grep defined $_->{version}, values %prime) { |
321 | $_->{version} = $normalize_version->( $_->{version} ); |
322 | } |
323 | |
324 | return \%prime; |
325 | } |
326 | } |
327 | |
328 | |
329 | sub _init { |
330 | my $class = shift; |
331 | my $module = shift; |
332 | my $filename = shift; |
333 | my %props = @_; |
334 | |
f33c0a6c |
335 | my $handle = delete $props{handle}; |
5ac756c6 |
336 | my( %valid_props, @valid_props ); |
337 | @valid_props = qw( collect_pod inc ); |
338 | @valid_props{@valid_props} = delete( @props{@valid_props} ); |
339 | warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); |
340 | |
341 | my %data = ( |
342 | module => $module, |
343 | filename => $filename, |
344 | version => undef, |
345 | packages => [], |
346 | versions => {}, |
347 | pod => {}, |
348 | pod_headings => [], |
349 | collect_pod => 0, |
350 | |
351 | %valid_props, |
352 | ); |
353 | |
354 | my $self = bless(\%data, $class); |
355 | |
f33c0a6c |
356 | if ( $handle ) { |
357 | $self->_parse_fh($handle); |
358 | } |
359 | else { |
360 | $self->_parse_file(); |
361 | } |
5ac756c6 |
362 | |
363 | unless($self->{module} and length($self->{module})) { |
364 | my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); |
365 | if($f =~ /\.pm$/) { |
366 | $f =~ s/\..+$//; |
367 | my @candidates = grep /$f$/, @{$self->{packages}}; |
368 | $self->{module} = shift(@candidates); # punt |
369 | } |
370 | else { |
371 | if(grep /main/, @{$self->{packages}}) { |
372 | $self->{module} = 'main'; |
373 | } |
374 | else { |
375 | $self->{module} = $self->{packages}[0] || ''; |
376 | } |
377 | } |
378 | } |
379 | |
380 | $self->{version} = $self->{versions}{$self->{module}} |
381 | if defined( $self->{module} ); |
382 | |
383 | return $self; |
384 | } |
385 | |
386 | # class method |
387 | sub _do_find_module { |
388 | my $class = shift; |
6f3c7f28 |
389 | my $module = shift || croak 'find_module_by_name() requires a package name'; |
5ac756c6 |
390 | my $dirs = shift || \@INC; |
391 | |
392 | my $file = File::Spec->catfile(split( /::/, $module)); |
393 | foreach my $dir ( @$dirs ) { |
394 | my $testfile = File::Spec->catfile($dir, $file); |
395 | return [ File::Spec->rel2abs( $testfile ), $dir ] |
396 | if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp |
397 | return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ] |
398 | if -e "$testfile.pm"; |
399 | } |
400 | return; |
401 | } |
402 | |
403 | # class method |
404 | sub find_module_by_name { |
405 | my $found = shift()->_do_find_module(@_) or return; |
406 | return $found->[0]; |
407 | } |
408 | |
409 | # class method |
410 | sub find_module_dir_by_name { |
411 | my $found = shift()->_do_find_module(@_) or return; |
412 | return $found->[1]; |
413 | } |
414 | |
415 | |
416 | # given a line of perl code, attempt to parse it if it looks like a |
417 | # $VERSION assignment, returning sigil, full name, & package name |
418 | sub _parse_version_expression { |
419 | my $self = shift; |
420 | my $line = shift; |
421 | |
422 | my( $sig, $var, $pkg ); |
69859aa0 |
423 | if ( $line =~ /$VERS_REGEXP/o ) { |
5ac756c6 |
424 | ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); |
425 | if ( $pkg ) { |
426 | $pkg = ($pkg eq '::') ? 'main' : $pkg; |
427 | $pkg =~ s/::$//; |
428 | } |
429 | } |
430 | |
431 | return ( $sig, $var, $pkg ); |
432 | } |
433 | |
434 | sub _parse_file { |
435 | my $self = shift; |
436 | |
437 | my $filename = $self->{filename}; |
438 | my $fh = IO::File->new( $filename ) |
6f3c7f28 |
439 | or croak( "Can't open '$filename': $!" ); |
5ac756c6 |
440 | |
441 | $self->_parse_fh($fh); |
442 | } |
443 | |
444 | sub _parse_fh { |
445 | my ($self, $fh) = @_; |
446 | |
447 | my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); |
448 | my( @pkgs, %vers, %pod, @pod ); |
449 | my $pkg = 'main'; |
450 | my $pod_sect = ''; |
451 | my $pod_data = ''; |
452 | |
453 | while (defined( my $line = <$fh> )) { |
454 | my $line_num = $.; |
455 | |
456 | chomp( $line ); |
457 | next if $line =~ /^\s*#/; |
458 | |
921abefc |
459 | my $is_cut; |
460 | if ( $line =~ /^=(.{0,3})/ ) { |
461 | $is_cut = $1 eq 'cut'; |
462 | $in_pod = !$is_cut; |
463 | } |
5ac756c6 |
464 | |
465 | # Would be nice if we could also check $in_string or something too |
466 | last if !$in_pod && $line =~ /^__(?:DATA|END)__$/; |
467 | |
921abefc |
468 | if ( $in_pod || $is_cut ) { |
5ac756c6 |
469 | |
470 | if ( $line =~ /^=head\d\s+(.+)\s*$/ ) { |
471 | push( @pod, $1 ); |
472 | if ( $self->{collect_pod} && length( $pod_data ) ) { |
473 | $pod{$pod_sect} = $pod_data; |
474 | $pod_data = ''; |
475 | } |
476 | $pod_sect = $1; |
477 | |
478 | |
479 | } elsif ( $self->{collect_pod} ) { |
480 | $pod_data .= "$line\n"; |
481 | |
482 | } |
483 | |
484 | } else { |
485 | |
486 | $pod_sect = ''; |
487 | $pod_data = ''; |
488 | |
489 | # parse $line to see if it's a $VERSION declaration |
490 | my( $vers_sig, $vers_fullname, $vers_pkg ) = |
9922478c |
491 | ($line =~ /VERSION/) |
492 | ? $self->_parse_version_expression( $line ) |
493 | : (); |
5ac756c6 |
494 | |
69859aa0 |
495 | if ( $line =~ /$PKG_REGEXP/o ) { |
5ac756c6 |
496 | $pkg = $1; |
497 | push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs ); |
498 | $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} ); |
499 | $need_vers = defined $2 ? 0 : 1; |
500 | |
501 | # VERSION defined with full package spec, i.e. $Module::VERSION |
502 | } elsif ( $vers_fullname && $vers_pkg ) { |
503 | push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs ); |
504 | $need_vers = 0 if $vers_pkg eq $pkg; |
505 | |
506 | unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) { |
507 | $vers{$vers_pkg} = |
508 | $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
509 | } else { |
510 | # Warn unless the user is using the "$VERSION = eval |
511 | # $VERSION" idiom (though there are probably other idioms |
512 | # that we should watch out for...) |
513 | warn <<"EOM" unless $line =~ /=\s*eval/; |
514 | Package '$vers_pkg' already declared with version '$vers{$vers_pkg}', |
515 | ignoring subsequent declaration on line $line_num. |
516 | EOM |
517 | } |
518 | |
519 | # first non-comment line in undeclared package main is VERSION |
520 | } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) { |
521 | $need_vers = 0; |
522 | my $v = |
523 | $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
524 | $vers{$pkg} = $v; |
525 | push( @pkgs, 'main' ); |
526 | |
527 | # first non-comment line in undeclared package defines package main |
528 | } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) { |
529 | $need_vers = 1; |
530 | $vers{main} = ''; |
531 | push( @pkgs, 'main' ); |
532 | |
533 | # only keep if this is the first $VERSION seen |
534 | } elsif ( $vers_fullname && $need_vers ) { |
535 | $need_vers = 0; |
536 | my $v = |
537 | $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
538 | |
539 | |
540 | unless ( defined $vers{$pkg} && length $vers{$pkg} ) { |
541 | $vers{$pkg} = $v; |
542 | } else { |
543 | warn <<"EOM"; |
544 | Package '$pkg' already declared with version '$vers{$pkg}' |
545 | ignoring new version '$v' on line $line_num. |
546 | EOM |
547 | } |
548 | |
549 | } |
550 | |
551 | } |
552 | |
553 | } |
554 | |
555 | if ( $self->{collect_pod} && length($pod_data) ) { |
556 | $pod{$pod_sect} = $pod_data; |
557 | } |
558 | |
559 | $self->{versions} = \%vers; |
560 | $self->{packages} = \@pkgs; |
561 | $self->{pod} = \%pod; |
562 | $self->{pod_headings} = \@pod; |
563 | } |
564 | |
565 | { |
566 | my $pn = 0; |
567 | sub _evaluate_version_line { |
568 | my $self = shift; |
569 | my( $sigil, $var, $line ) = @_; |
570 | |
571 | # Some of this code came from the ExtUtils:: hierarchy. |
572 | |
573 | # We compile into $vsub because 'use version' would cause |
574 | # compiletime/runtime issues with local() |
575 | my $vsub; |
576 | $pn++; # everybody gets their own package |
577 | my $eval = qq{BEGIN { q# Hide from _packages_inside() |
578 | #; package Module::Metadata::_version::p$pn; |
4850170c |
579 | use version; |
5ac756c6 |
580 | no strict; |
581 | |
5ac756c6 |
582 | \$vsub = sub { |
398fe5a2 |
583 | local $sigil$var; |
584 | \$$var=undef; |
5ac756c6 |
585 | $line; |
586 | \$$var |
587 | }; |
588 | }}; |
589 | |
590 | local $^W; |
591 | # Try to get the $VERSION |
592 | eval $eval; |
593 | # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't |
594 | # installed, so we need to hunt in ./lib for it |
595 | if ( $@ =~ /Can't locate/ && -d 'lib' ) { |
596 | local @INC = ('lib',@INC); |
597 | eval $eval; |
598 | } |
599 | warn "Error evaling version line '$eval' in $self->{filename}: $@\n" |
600 | if $@; |
601 | (ref($vsub) eq 'CODE') or |
6f3c7f28 |
602 | croak "failed to build version sub for $self->{filename}"; |
5ac756c6 |
603 | my $result = eval { $vsub->() }; |
6f3c7f28 |
604 | croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" |
5ac756c6 |
605 | if $@; |
606 | |
d880ef1f |
607 | # Upgrade it into a version object |
92ad06ed |
608 | my $version = eval { _dwim_version($result) }; |
609 | |
6f3c7f28 |
610 | croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" |
92ad06ed |
611 | unless defined $version; # "0" is OK! |
5ac756c6 |
612 | |
92ad06ed |
613 | return $version; |
5ac756c6 |
614 | } |
615 | } |
616 | |
92ad06ed |
617 | # Try to DWIM when things fail the lax version test in obvious ways |
618 | { |
619 | my @version_prep = ( |
620 | # Best case, it just works |
621 | sub { return shift }, |
622 | |
623 | # If we still don't have a version, try stripping any |
624 | # trailing junk that is prohibited by lax rules |
625 | sub { |
626 | my $v = shift; |
627 | $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b |
628 | return $v; |
629 | }, |
630 | |
631 | # Activestate apparently creates custom versions like '1.23_45_01', which |
632 | # cause version.pm to think it's an invalid alpha. So check for that |
633 | # and strip them |
634 | sub { |
635 | my $v = shift; |
636 | my $num_dots = () = $v =~ m{(\.)}g; |
637 | my $num_unders = () = $v =~ m{(_)}g; |
638 | my $leading_v = substr($v,0,1) eq 'v'; |
639 | if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { |
640 | $v =~ s{_}{}g; |
641 | $num_unders = () = $v =~ m{(_)}g; |
642 | } |
643 | return $v; |
644 | }, |
645 | |
646 | # Worst case, try numifying it like we would have before version objects |
647 | sub { |
648 | my $v = shift; |
649 | no warnings 'numeric'; |
650 | return 0 + $v; |
651 | }, |
652 | |
653 | ); |
654 | |
655 | sub _dwim_version { |
656 | my ($result) = shift; |
657 | |
658 | return $result if ref($result) eq 'version'; |
659 | |
660 | my ($version, $error); |
661 | for my $f (@version_prep) { |
662 | $result = $f->($result); |
663 | $version = eval { version->new($result) }; |
664 | $error ||= $@ if $@; # capture first failure |
665 | last if defined $version; |
666 | } |
667 | |
6f3c7f28 |
668 | croak $error unless defined $version; |
92ad06ed |
669 | |
670 | return $version; |
671 | } |
672 | } |
5ac756c6 |
673 | |
674 | ############################################################ |
675 | |
676 | # accessors |
677 | sub name { $_[0]->{module} } |
678 | |
679 | sub filename { $_[0]->{filename} } |
680 | sub packages_inside { @{$_[0]->{packages}} } |
681 | sub pod_inside { @{$_[0]->{pod_headings}} } |
682 | sub contains_pod { $#{$_[0]->{pod_headings}} } |
683 | |
684 | sub version { |
685 | my $self = shift; |
686 | my $mod = shift || $self->{module}; |
687 | my $vers; |
688 | if ( defined( $mod ) && length( $mod ) && |
689 | exists( $self->{versions}{$mod} ) ) { |
690 | return $self->{versions}{$mod}; |
691 | } else { |
692 | return undef; |
693 | } |
694 | } |
695 | |
696 | sub pod { |
697 | my $self = shift; |
698 | my $sect = shift; |
699 | if ( defined( $sect ) && length( $sect ) && |
700 | exists( $self->{pod}{$sect} ) ) { |
701 | return $self->{pod}{$sect}; |
702 | } else { |
703 | return undef; |
704 | } |
705 | } |
706 | |
707 | 1; |
708 | |
5ac756c6 |
709 | =head1 NAME |
710 | |
2c11e51d |
711 | Module::Metadata - Gather package and POD information from perl module files |
5ac756c6 |
712 | |
6290f67c |
713 | =head1 SYNOPSIS |
714 | |
715 | use Module::Metadata; |
716 | |
717 | # information about a .pm file |
718 | my $info = Module::Metadata->new_from_file( $file ); |
719 | my $version = $info->version; |
720 | |
ca33f3bd |
721 | # CPAN META 'provides' field for .pm files in a directory |
c06d0187 |
722 | my $provides = Module::Metadata->provides( |
723 | dir => 'lib', version => 2 |
724 | ); |
6290f67c |
725 | |
5ac756c6 |
726 | =head1 DESCRIPTION |
727 | |
6290f67c |
728 | This module provides a standard way to gather metadata about a .pm file |
729 | without executing unsafe code. |
730 | |
731 | =head1 USAGE |
732 | |
733 | =head2 Class methods |
734 | |
5ac756c6 |
735 | =over 4 |
736 | |
6290f67c |
737 | =item C<< new_from_file($filename, collect_pod => 1) >> |
5ac756c6 |
738 | |
6290f67c |
739 | Construct a C<Module::Metadata> object given the path to a file. Takes an |
740 | optional argument C<collect_pod> which is a boolean that determines whether POD |
741 | data is collected and stored for reference. POD data is not collected by |
742 | default. POD headings are always collected. Returns undef if the filename |
743 | does not exist. |
5ac756c6 |
744 | |
6290f67c |
745 | =item C<< new_from_handle($handle, $filename, collect_pod => 1) >> |
f33c0a6c |
746 | |
747 | This works just like C<new_from_file>, except that a handle can be provided |
748 | as the first argument. Note that there is no validation to confirm that the |
749 | handle is a handle or something that can act like one. Passing something that |
750 | isn't a handle will cause a exception when trying to read from it. The |
751 | C<filename> argument is mandatory or undef will be returned. |
752 | |
6290f67c |
753 | =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >> |
5ac756c6 |
754 | |
d846be69 |
755 | Construct a C<Module::Metadata> object given a module or package name. In addition |
5ac756c6 |
756 | to accepting the C<collect_pod> argument as described above, this |
757 | method accepts a C<inc> argument which is a reference to an array of |
758 | of directories to search for the module. If none are given, the |
6290f67c |
759 | default is @INC. Returns undef if the module cannot be found. |
5ac756c6 |
760 | |
6290f67c |
761 | =item C<< find_module_by_name($module, \@dirs) >> |
5ac756c6 |
762 | |
763 | Returns the path to a module given the module or package name. A list |
764 | of directories can be passed in as an optional parameter, otherwise |
765 | @INC is searched. |
766 | |
767 | Can be called as either an object or a class method. |
768 | |
6290f67c |
769 | =item C<< find_module_dir_by_name($module, \@dirs) >> |
5ac756c6 |
770 | |
771 | Returns the entry in C<@dirs> (or C<@INC> by default) that contains |
772 | the module C<$module>. A list of directories can be passed in as an |
773 | optional parameter, otherwise @INC is searched. |
774 | |
775 | Can be called as either an object or a class method. |
776 | |
ca33f3bd |
777 | =item C<< provides( %options ) >> |
778 | |
779 | This is a convenience wrapper around C<package_versions_from_directory> |
780 | to generate a CPAN META C<provides> data structure. It takes key/value |
781 | pairs. Valid option keys include: |
782 | |
783 | =over |
784 | |
c06d0187 |
785 | =item version B<(required)> |
786 | |
787 | Specifies which version of the L<CPAN::Meta::Spec> should be used as |
788 | the format of the C<provides> output. Currently only '1.4' and '2' |
789 | are supported (and their format is identical). This may change in |
790 | the future as the definition of C<provides> changes. |
791 | |
792 | The C<version> option is required. If it is omitted or if |
793 | an unsupported version is given, then C<provides> will throw an error. |
794 | |
ca33f3bd |
795 | =item dir |
796 | |
797 | Directory to search recursively for F<.pm> files. May not be specified with |
798 | C<files>. |
799 | |
800 | =item files |
801 | |
802 | Array reference of files to examine. May not be specified with C<dir>. |
803 | |
804 | =item prefix |
805 | |
806 | String to prepend to the C<file> field of the resulting output. This defaults |
807 | to F<lib>, which is the common case for most CPAN distributions with their |
808 | F<.pm> files in F<lib>. This option ensures the META information has the |
809 | correct relative path even when the C<dir> or C<files> arguments are |
810 | absolute or have relative paths from a location other than the distribution |
811 | root. |
812 | |
813 | =back |
814 | |
815 | For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value |
816 | is a hashref of the form: |
817 | |
818 | { |
819 | 'Package::Name' => { |
820 | version => '0.123', |
821 | file => 'lib/Package/Name.pm' |
822 | }, |
823 | 'OtherPackage::Name' => ... |
824 | } |
825 | |
6290f67c |
826 | =item C<< package_versions_from_directory($dir, \@files?) >> |
2c11e51d |
827 | |
828 | Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks |
829 | for those files in C<$dir> - and reads each file for packages and versions, |
830 | returning a hashref of the form: |
5ac756c6 |
831 | |
2c11e51d |
832 | { |
833 | 'Package::Name' => { |
834 | version => '0.123', |
835 | file => 'Package/Name.pm' |
836 | }, |
837 | 'OtherPackage::Name' => ... |
838 | } |
839 | |
ca33f3bd |
840 | The C<DB> and C<main> packages are always omitted, as are any "private" |
841 | packages that have leading underscores in the namespace (e.g. |
842 | C<Foo::_private>) |
843 | |
844 | Note that the file path is relative to C<$dir> if that is specified. |
845 | This B<must not> be used directly for CPAN META C<provides>. See |
846 | the C<provides> method instead. |
847 | |
6290f67c |
848 | =item C<< log_info (internal) >> |
2c11e51d |
849 | |
850 | Used internally to perform logging; imported from Log::Contextual if |
851 | Log::Contextual has already been loaded, otherwise simply calls warn. |
852 | |
853 | =back |
5ac756c6 |
854 | |
6290f67c |
855 | =head2 Object methods |
856 | |
857 | =over 4 |
858 | |
859 | =item C<< name() >> |
860 | |
861 | Returns the name of the package represented by this module. If there |
862 | are more than one packages, it makes a best guess based on the |
863 | filename. If it's a script (i.e. not a *.pm) the package name is |
864 | 'main'. |
865 | |
866 | =item C<< version($package) >> |
867 | |
868 | Returns the version as defined by the $VERSION variable for the |
869 | package as returned by the C<name> method if no arguments are |
870 | given. If given the name of a package it will attempt to return the |
871 | version of that package if it is specified in the file. |
872 | |
873 | =item C<< filename() >> |
874 | |
875 | Returns the absolute path to the file. |
876 | |
877 | =item C<< packages_inside() >> |
878 | |
1f67ffd7 |
879 | Returns a list of packages. Note: this is a raw list of packages |
880 | discovered (or assumed, in the case of C<main>). It is not |
881 | filtered for C<DB>, C<main> or private packages the way the |
882 | C<provides> method does. |
6290f67c |
883 | |
884 | =item C<< pod_inside() >> |
885 | |
886 | Returns a list of POD sections. |
887 | |
888 | =item C<< contains_pod() >> |
889 | |
890 | Returns true if there is any POD in the file. |
891 | |
892 | =item C<< pod($section) >> |
893 | |
894 | Returns the POD data in the given section. |
895 | |
896 | =back |
897 | |
5ac756c6 |
898 | =head1 AUTHOR |
899 | |
6290f67c |
900 | Original code from Module::Build::ModuleInfo by Ken Williams |
901 | <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> |
5ac756c6 |
902 | |
2c11e51d |
903 | Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with |
6290f67c |
904 | assistance from David Golden (xdg) <dagolden@cpan.org>. |
5ac756c6 |
905 | |
906 | =head1 COPYRIGHT |
907 | |
6290f67c |
908 | Original code Copyright (c) 2001-2011 Ken Williams. |
909 | Additional code Copyright (c) 2010-2011 Matt Trout and David Golden. |
910 | All rights reserved. |
5ac756c6 |
911 | |
912 | This library is free software; you can redistribute it and/or |
913 | modify it under the same terms as Perl itself. |
914 | |
5ac756c6 |
915 | =cut |
916 | |