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