line |
stmt |
bran |
cond |
sub |
pod |
time |
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 |
3
|
|
|
|
|
|
|
package 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
|
|
|
|
|
|
|
|
13
|
113
|
|
|
113
|
|
10776
|
sub __clean_eval { eval $_[0] } |
|
6
|
|
|
7
|
|
49
|
|
|
6
|
|
|
5
|
|
13
|
|
|
6
|
|
|
5
|
|
45
|
|
|
4
|
|
|
5
|
|
30
|
|
|
4
|
|
|
5
|
|
9
|
|
|
4
|
|
|
4
|
|
22
|
|
|
4
|
|
|
4
|
|
28
|
|
|
4
|
|
|
4
|
|
10
|
|
|
4
|
|
|
4
|
|
21
|
|
|
4
|
|
|
1
|
|
29
|
|
|
4
|
|
|
1
|
|
8
|
|
|
4
|
|
|
1
|
|
21
|
|
|
4
|
|
|
1
|
|
28
|
|
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
18
|
|
|
3
|
|
|
|
|
26
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
15
|
|
|
3
|
|
|
|
|
21
|
|
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
17
|
|
|
3
|
|
|
|
|
23
|
|
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
14
|
|
|
3
|
|
|
|
|
22
|
|
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
15
|
|
14
|
10
|
|
|
10
|
|
475600
|
use strict; |
|
10
|
|
|
|
|
78
|
|
|
10
|
|
|
|
|
286
|
|
15
|
10
|
|
|
10
|
|
59
|
use warnings; |
|
10
|
|
|
|
|
18
|
|
|
10
|
|
|
|
|
368
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our $VERSION = '1.000037'; |
18
|
|
|
|
|
|
|
|
19
|
10
|
|
|
10
|
|
58
|
use Carp qw/croak/; |
|
10
|
|
|
|
|
32
|
|
|
10
|
|
|
|
|
402
|
|
20
|
10
|
|
|
10
|
|
65
|
use File::Spec; |
|
10
|
|
|
|
|
33
|
|
|
10
|
|
|
|
|
683
|
|
21
|
|
|
|
|
|
|
BEGIN { |
22
|
|
|
|
|
|
|
# Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl |
23
|
|
|
|
|
|
|
eval { |
24
|
10
|
|
|
|
|
85
|
require Fcntl; Fcntl->import('SEEK_SET'); 1; |
|
10
|
|
|
|
|
245
|
|
|
10
|
|
|
|
|
311
|
|
25
|
2
|
|
|
|
|
6
|
} or *SEEK_SET = sub { 0 } |
26
|
10
|
50
|
|
10
|
|
41
|
} |
27
|
10
|
|
|
10
|
|
3637
|
use version 0.87; |
|
10
|
|
|
|
|
15547
|
|
|
10
|
|
|
|
|
61
|
|
28
|
|
|
|
|
|
|
BEGIN { |
29
|
10
|
50
|
|
10
|
|
1172
|
if ($INC{'Log/Contextual.pm'}) { |
30
|
2
|
|
|
|
|
15
|
require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs |
31
|
2
|
|
|
|
|
6
|
Log::Contextual->import('log_info', |
32
|
|
|
|
|
|
|
'-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }), |
33
|
|
|
|
|
|
|
); |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
else { |
36
|
10
|
|
|
2
|
|
209
|
*log_info = sub (&) { warn $_[0]->() }; |
|
2
|
|
|
|
|
14
|
|
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
} |
39
|
10
|
|
|
10
|
|
78
|
use File::Find qw(find); |
|
10
|
|
|
|
|
27
|
|
|
10
|
|
|
|
|
37491
|
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name |
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
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name |
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
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
my $PKG_NAME_REGEXP = qr{ # match a package name |
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
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
my $PKG_REGEXP = qr{ # match a package declaration |
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
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name |
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
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
my $VERS_REGEXP = qr{ # match a VERSION definition |
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
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub new_from_file { |
104
|
103
|
|
|
103
|
1
|
260272
|
my $class = shift; |
105
|
103
|
|
|
|
|
1676
|
my $filename = File::Spec->rel2abs( shift ); |
106
|
|
|
|
|
|
|
|
107
|
103
|
100
|
66
|
|
|
2012
|
return undef unless defined( $filename ) && -f $filename; |
108
|
102
|
|
|
|
|
476
|
return $class->_init(undef, $filename, @_); |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub new_from_handle { |
112
|
7
|
|
|
7
|
1
|
2526
|
my $class = shift; |
113
|
7
|
|
|
|
|
14
|
my $handle = shift; |
114
|
7
|
|
|
|
|
16
|
my $filename = shift; |
115
|
7
|
100
|
66
|
|
|
47
|
return undef unless defined($handle) && defined($filename); |
116
|
6
|
|
|
|
|
124
|
$filename = File::Spec->rel2abs( $filename ); |
117
|
|
|
|
|
|
|
|
118
|
6
|
|
|
|
|
31
|
return $class->_init(undef, $filename, @_, handle => $handle); |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub new_from_module { |
124
|
9
|
|
|
9
|
1
|
4791
|
my $class = shift; |
125
|
9
|
|
|
|
|
21
|
my $module = shift; |
126
|
9
|
|
|
|
|
35
|
my %props = @_; |
127
|
|
|
|
|
|
|
|
128
|
9
|
|
100
|
|
|
43
|
$props{inc} ||= \@INC; |
129
|
9
|
|
|
|
|
27
|
my $filename = $class->find_module_by_name( $module, $props{inc} ); |
130
|
9
|
100
|
66
|
|
|
124
|
return undef unless defined( $filename ) && -f $filename; |
131
|
8
|
|
|
|
|
53
|
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; |
146
|
|
|
|
|
|
|
}; |
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; |
164
|
|
|
|
|
|
|
}; |
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; |
202
|
|
|
|
|
|
|
}; |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub provides { |
205
|
4
|
|
|
4
|
1
|
1862
|
my $class = shift; |
206
|
|
|
|
|
|
|
|
207
|
4
|
50
|
|
|
|
21
|
croak "provides() requires key/value pairs \n" if @_ % 2; |
208
|
4
|
|
|
|
|
23
|
my %args = @_; |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
croak "provides() takes only one of 'dir' or 'files'\n" |
211
|
4
|
50
|
33
|
|
|
17
|
if $args{dir} && $args{files}; |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
croak "provides() requires a 'version' argument" |
214
|
4
|
50
|
|
|
|
15
|
unless defined $args{version}; |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
croak "provides() does not support version '$args{version}' metadata" |
217
|
4
|
50
|
|
|
|
35
|
unless grep $args{version} eq $_, qw/1.4 2/; |
218
|
|
|
|
|
|
|
|
219
|
4
|
100
|
|
|
|
11
|
$args{prefix} = 'lib' unless defined $args{prefix}; |
220
|
|
|
|
|
|
|
|
221
|
4
|
|
|
|
|
15
|
my $p; |
222
|
4
|
50
|
|
|
|
157
|
if ( $args{dir} ) { |
223
|
4
|
|
|
|
|
10
|
$p = $class->package_versions_from_directory($args{dir}); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
else { |
226
|
|
|
|
|
|
|
croak "provides() requires 'files' to be an array reference\n" |
227
|
2
|
0
|
|
|
|
27
|
unless ref $args{files} eq 'ARRAY'; |
228
|
2
|
|
|
|
|
14
|
$p = $class->package_versions_from_directory($args{files}); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# Now, fix up files with prefix |
232
|
4
|
50
|
|
|
|
12
|
if ( length $args{prefix} ) { # check in case disabled with q{} |
233
|
4
|
|
|
|
|
14
|
$args{prefix} =~ s{/$}{}; |
234
|
4
|
|
|
|
|
120
|
for my $v ( values %$p ) { |
235
|
6
|
|
|
|
|
17
|
$v->{file} = "$args{prefix}/$v->{file}"; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
4
|
|
|
|
|
14
|
return $p |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub package_versions_from_directory { |
243
|
6
|
|
|
6
|
1
|
1266
|
my ( $class, $dir, $files ) = @_; |
244
|
|
|
|
|
|
|
|
245
|
6
|
|
|
|
|
12
|
my @files; |
246
|
|
|
|
|
|
|
|
247
|
6
|
100
|
|
|
|
21
|
if ( $files ) { |
248
|
3
|
|
|
|
|
16
|
@files = @$files; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
else { |
251
|
|
|
|
|
|
|
find( { |
252
|
|
|
|
|
|
|
wanted => sub { |
253
|
8
|
100
|
66
|
8
|
|
442
|
push @files, $_ if -f $_ && /\.pm$/; |
254
|
|
|
|
|
|
|
}, |
255
|
5
|
|
|
|
|
330
|
no_chdir => 1, |
256
|
|
|
|
|
|
|
}, $dir ); |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
# First, we enumerate all packages & versions, |
260
|
|
|
|
|
|
|
# separating into primary & alternative candidates |
261
|
6
|
|
|
|
|
43
|
my( %prime, %alt ); |
262
|
6
|
|
|
|
|
12
|
foreach my $file (@files) { |
263
|
6
|
|
|
|
|
293
|
my $mapped_filename = File::Spec->abs2rel( $file, $dir ); |
264
|
6
|
|
|
|
|
35
|
my @path = File::Spec->splitdir( $mapped_filename ); |
265
|
6
|
|
|
|
|
25
|
(my $prime_package = join( '::', @path )) =~ s/\.pm$//; |
266
|
|
|
|
|
|
|
|
267
|
6
|
|
|
|
|
32
|
my $pm_info = $class->new_from_file( $file ); |
268
|
|
|
|
|
|
|
|
269
|
6
|
|
|
|
|
30
|
foreach my $package ( $pm_info->packages_inside ) { |
270
|
22
|
100
|
|
|
|
44
|
next if $package eq 'main'; # main can appear numerous times, ignore |
271
|
18
|
100
|
|
|
|
41
|
next if $package eq 'DB'; # special debugging package, ignore |
272
|
14
|
100
|
|
|
|
82
|
next if grep /^_/, split( /::/, $package ); # private package, ignore |
273
|
|
|
|
|
|
|
|
274
|
10
|
|
|
|
|
34
|
my $version = $pm_info->version( $package ); |
275
|
|
|
|
|
|
|
|
276
|
10
|
100
|
|
|
|
30
|
$prime_package = $package if lc($prime_package) eq lc($package); |
277
|
10
|
100
|
|
|
|
32
|
if ( $package eq $prime_package ) { |
278
|
6
|
50
|
|
|
|
13
|
if ( exists( $prime{$package} ) ) { |
279
|
2
|
|
|
|
|
11
|
croak "Unexpected conflict in '$package'; multiple versions found.\n"; |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
else { |
282
|
6
|
50
|
|
|
|
36
|
$mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename); |
283
|
6
|
|
|
|
|
26
|
$prime{$package}{file} = $mapped_filename; |
284
|
6
|
50
|
|
|
|
27
|
$prime{$package}{version} = $version if defined( $version ); |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
else { |
288
|
5
|
|
|
|
|
26
|
push( @{$alt{$package}}, { |
|
5
|
|
|
|
|
28
|
|
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
|
5
|
|
|
|
|
28
|
foreach my $package ( keys( %alt ) ) { |
300
|
5
|
|
|
|
|
23
|
my $result = $resolve_module_versions->( $alt{$package} ); |
301
|
|
|
|
|
|
|
|
302
|
5
|
50
|
|
|
|
14
|
if ( exists( $prime{$package} ) ) { # primary package selected |
303
|
|
|
|
|
|
|
|
304
|
1
|
0
|
|
|
|
6
|
if ( $result->{err} ) { |
|
|
0
|
|
|
|
|
|
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
|
1
|
|
|
2
|
|
7
|
}; |
|
1
|
|
|
|
|
4
|
|
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
elsif ( defined( $result->{version} ) ) { |
316
|
|
|
|
|
|
|
# There is a primary package selected, and exactly one |
317
|
|
|
|
|
|
|
# alternative package |
318
|
|
|
|
|
|
|
|
319
|
1
|
0
|
0
|
|
|
5
|
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
|
1
|
0
|
|
|
|
8
|
if ( $compare_versions->( |
324
|
|
|
|
|
|
|
$prime{$package}{version}, '!=', $result->{version} |
325
|
|
|
|
|
|
|
) |
326
|
|
|
|
|
|
|
) { |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
log_info { |
329
|
1
|
|
|
2
|
|
7
|
"Found conflicting versions for package '$package'\n" . |
330
|
|
|
|
|
|
|
" $prime{$package}{file} ($prime{$package}{version})\n" . |
331
|
|
|
|
|
|
|
" $result->{file} ($result->{version})\n" |
332
|
1
|
|
|
|
|
2
|
}; |
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
|
1
|
|
|
|
|
7
|
$prime{$package}{file} = $result->{file}; |
340
|
1
|
|
|
|
|
3
|
$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
|
5
|
50
|
|
|
|
16
|
if ( $result->{err} ) { |
353
|
|
|
|
|
|
|
log_info { |
354
|
|
|
|
|
|
|
"Found conflicting versions for package '$package'\n" . |
355
|
|
|
|
|
|
|
$result->{err} |
356
|
1
|
|
|
2
|
|
8
|
}; |
|
1
|
|
|
|
|
2
|
|
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
# Despite possible conflicting versions, we choose to record |
360
|
|
|
|
|
|
|
# something rather than nothing |
361
|
5
|
|
|
|
|
15
|
$prime{$package}{file} = $result->{file}; |
362
|
|
|
|
|
|
|
$prime{$package}{version} = $result->{version} |
363
|
5
|
50
|
|
|
|
21
|
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
|
5
|
|
|
|
|
19
|
for (grep defined $_->{version}, values %prime) { |
370
|
9
|
|
|
|
|
32
|
$_->{version} = $normalize_version->( $_->{version} ); |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
5
|
|
|
|
|
32
|
return \%prime; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
sub _init { |
379
|
111
|
|
|
112
|
|
212
|
my $class = shift; |
380
|
111
|
|
|
|
|
178
|
my $module = shift; |
381
|
111
|
|
|
|
|
180
|
my $filename = shift; |
382
|
111
|
|
|
|
|
227
|
my %props = @_; |
383
|
|
|
|
|
|
|
|
384
|
111
|
|
|
|
|
222
|
my $handle = delete $props{handle}; |
385
|
111
|
|
|
|
|
208
|
my( %valid_props, @valid_props ); |
386
|
111
|
|
|
|
|
308
|
@valid_props = qw( collect_pod inc decode_pod ); |
387
|
111
|
|
|
|
|
422
|
@valid_props{@valid_props} = delete( @props{@valid_props} ); |
388
|
111
|
50
|
|
|
|
265
|
warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); |
|
1
|
|
|
|
|
3
|
|
389
|
|
|
|
|
|
|
|
390
|
111
|
|
|
|
|
1322
|
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
|
111
|
|
|
|
|
316
|
my $self = bless(\%data, $class); |
404
|
|
|
|
|
|
|
|
405
|
111
|
100
|
|
|
|
255
|
if ( not $handle ) { |
406
|
107
|
|
|
|
|
238
|
my $filename = $self->{filename}; |
407
|
107
|
50
|
|
|
|
3552
|
open $handle, '<', $filename |
408
|
|
|
|
|
|
|
or croak( "Can't open '$filename': $!" ); |
409
|
|
|
|
|
|
|
|
410
|
107
|
|
|
|
|
440
|
$self->_handle_bom($handle, $filename); |
411
|
|
|
|
|
|
|
} |
412
|
111
|
|
|
|
|
363
|
$self->_parse_fh($handle); |
413
|
|
|
|
|
|
|
|
414
|
111
|
|
|
|
|
324
|
@{$self->{packages}} = __uniq(@{$self->{packages}}); |
|
111
|
|
|
|
|
289
|
|
|
111
|
|
|
|
|
327
|
|
415
|
|
|
|
|
|
|
|
416
|
111
|
100
|
66
|
|
|
353
|
unless($self->{module} and length($self->{module})) { |
417
|
|
|
|
|
|
|
# CAVEAT (possible TODO): .pmc files not treated the same as .pm |
418
|
105
|
100
|
|
|
|
683
|
if ($self->{filename} =~ /\.pm$/) { |
419
|
96
|
|
|
|
|
1403
|
my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); |
420
|
96
|
|
|
|
|
446
|
$f =~ s/\..+$//; |
421
|
96
|
|
|
|
|
166
|
my @candidates = grep /(^|::)$f$/, @{$self->{packages}}; |
|
96
|
|
|
|
|
780
|
|
422
|
96
|
|
|
|
|
281
|
$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
|
10
|
100
|
100
|
|
|
18
|
if ((grep /main/, @{$self->{packages}}) |
|
10
|
|
|
|
|
52
|
|
430
|
4
|
|
|
|
|
20
|
or (grep /main/, keys %{$self->{versions}})) { |
431
|
9
|
|
|
|
|
22
|
$self->{module} = 'main'; |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
else { |
434
|
|
|
|
|
|
|
# TODO: this should maybe default to undef instead |
435
|
2
|
|
50
|
|
|
15
|
$self->{module} = $self->{packages}[0] || ''; |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
$self->{version} = $self->{versions}{$self->{module}} |
441
|
111
|
100
|
|
|
|
364
|
if defined( $self->{module} ); |
442
|
|
|
|
|
|
|
|
443
|
111
|
|
|
|
|
1857
|
return $self; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# class method |
447
|
|
|
|
|
|
|
sub _do_find_module { |
448
|
9
|
|
|
10
|
|
23
|
my $class = shift; |
449
|
9
|
|
33
|
|
|
25
|
my $module = shift || croak 'find_module_by_name() requires a package name'; |
450
|
9
|
|
100
|
|
|
29
|
my $dirs = shift || \@INC; |
451
|
|
|
|
|
|
|
|
452
|
9
|
|
|
|
|
102
|
my $file = File::Spec->catfile(split( /::/, $module)); |
453
|
9
|
|
|
|
|
30
|
foreach my $dir ( @$dirs ) { |
454
|
11
|
|
|
|
|
77
|
my $testfile = File::Spec->catfile($dir, $file); |
455
|
10
|
50
|
33
|
|
|
172
|
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
|
10
|
|
|
|
|
27
|
$testfile .= '.pm'; |
459
|
10
|
100
|
|
|
|
309
|
return [ File::Spec->rel2abs( $testfile ), $dir ] |
460
|
|
|
|
|
|
|
if -e $testfile; |
461
|
|
|
|
|
|
|
} |
462
|
1
|
|
|
|
|
4
|
return; |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
# class method |
466
|
|
|
|
|
|
|
sub find_module_by_name { |
467
|
8
|
100
|
|
10
|
1
|
447
|
my $found = shift()->_do_find_module(@_) or return; |
468
|
7
|
|
|
|
|
28
|
return $found->[0]; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
# class method |
472
|
|
|
|
|
|
|
sub find_module_dir_by_name { |
473
|
0
|
0
|
|
2
|
1
|
0
|
my $found = shift()->_do_find_module(@_) or return; |
474
|
0
|
|
|
|
|
0
|
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 |
480
|
|
|
|
|
|
|
sub _parse_version_expression { |
481
|
135
|
|
|
137
|
|
225
|
my $self = shift; |
482
|
135
|
|
|
|
|
267
|
my $line = shift; |
483
|
|
|
|
|
|
|
|
484
|
135
|
|
|
|
|
229
|
my( $sigil, $variable_name, $package); |
485
|
135
|
100
|
|
|
|
1004
|
if ( $line =~ /$VERS_REGEXP/o ) { |
486
|
116
|
100
|
|
|
|
545
|
( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); |
487
|
116
|
100
|
|
|
|
273
|
if ( $package ) { |
488
|
20
|
100
|
|
|
|
74
|
$package = ($package eq '::') ? 'main' : $package; |
489
|
20
|
|
|
|
|
89
|
$package =~ s/::$//; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
|
493
|
135
|
|
|
|
|
459
|
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. |
498
|
|
|
|
|
|
|
sub _handle_bom { |
499
|
106
|
|
|
108
|
|
252
|
my ($self, $fh, $filename) = @_; |
500
|
|
|
|
|
|
|
|
501
|
106
|
|
|
|
|
264
|
my $pos = tell $fh; |
502
|
106
|
50
|
|
|
|
234
|
return unless defined $pos; |
503
|
|
|
|
|
|
|
|
504
|
106
|
|
|
|
|
175
|
my $buf = ' ' x 2; |
505
|
106
|
|
|
|
|
1258
|
my $count = read $fh, $buf, length $buf; |
506
|
106
|
50
|
33
|
|
|
546
|
return unless defined $count and $count >= 2; |
507
|
|
|
|
|
|
|
|
508
|
106
|
|
|
|
|
154
|
my $encoding; |
509
|
106
|
100
|
|
|
|
398
|
if ( $buf eq "\x{FE}\x{FF}" ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
510
|
1
|
|
|
|
|
3
|
$encoding = 'UTF-16BE'; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
elsif ( $buf eq "\x{FF}\x{FE}" ) { |
513
|
1
|
|
|
|
|
2
|
$encoding = 'UTF-16LE'; |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
elsif ( $buf eq "\x{EF}\x{BB}" ) { |
516
|
1
|
|
|
|
|
3
|
$buf = ' '; |
517
|
1
|
|
|
|
|
3
|
$count = read $fh, $buf, length $buf; |
518
|
1
|
50
|
33
|
|
|
8
|
if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) { |
|
|
|
33
|
|
|
|
|
519
|
1
|
|
|
|
|
2
|
$encoding = 'UTF-8'; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
106
|
100
|
|
|
|
209
|
if ( defined $encoding ) { |
524
|
3
|
50
|
|
|
|
14
|
if ( "$]" >= 5.008 ) { |
525
|
3
|
|
|
2
|
|
53
|
binmode( $fh, ":encoding($encoding)" ); |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
6
|
|
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
else { |
529
|
103
|
50
|
|
|
|
1243
|
seek $fh, $pos, SEEK_SET |
530
|
|
|
|
|
|
|
or croak( sprintf "Can't reset position to the top of '$filename'" ); |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
|
533
|
106
|
|
|
|
|
15618
|
return $encoding; |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
sub _parse_fh { |
537
|
110
|
|
|
112
|
|
229
|
my ($self, $fh) = @_; |
538
|
|
|
|
|
|
|
|
539
|
110
|
|
|
|
|
264
|
my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); |
540
|
110
|
|
|
|
|
228
|
my( @packages, %vers, %pod, @pod ); |
541
|
110
|
|
|
|
|
180
|
my $package = 'main'; |
542
|
110
|
|
|
|
|
166
|
my $pod_sect = ''; |
543
|
110
|
|
|
|
|
150
|
my $pod_data = ''; |
544
|
110
|
|
|
|
|
151
|
my $in_end = 0; |
545
|
110
|
|
|
|
|
157
|
my $encoding = ''; |
546
|
|
|
|
|
|
|
|
547
|
110
|
|
|
|
|
1013
|
while (defined( my $line = <$fh> )) { |
548
|
1690
|
|
|
|
|
3243
|
my $line_num = $.; |
549
|
|
|
|
|
|
|
|
550
|
1690
|
|
|
|
|
2685
|
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
|
1690
|
|
|
|
|
2588
|
my $is_cut; |
555
|
1690
|
100
|
|
|
|
3368
|
if ( $line =~ /^=([a-zA-Z].*)/ ) { |
556
|
96
|
|
|
|
|
210
|
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
|
96
|
|
|
|
|
166
|
$is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/; |
560
|
96
|
|
|
|
|
138
|
$in_pod = !$is_cut; |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
|
563
|
1690
|
100
|
|
|
|
3131
|
if ( $in_pod ) { |
|
|
100
|
|
|
|
|
|
564
|
|
|
|
|
|
|
|
565
|
454
|
100
|
|
|
|
930
|
if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) { |
|
|
100
|
|
|
|
|
|
566
|
44
|
|
|
|
|
107
|
push( @pod, $1 ); |
567
|
44
|
100
|
100
|
|
|
110
|
if ( $self->{collect_pod} && length( $pod_data ) ) { |
568
|
4
|
|
|
|
|
13
|
$pod{$pod_sect} = $pod_data; |
569
|
4
|
|
|
|
|
8
|
$pod_data = ''; |
570
|
|
|
|
|
|
|
} |
571
|
44
|
|
|
|
|
80
|
$pod_sect = $1; |
572
|
|
|
|
|
|
|
} |
573
|
|
|
|
|
|
|
elsif ( $self->{collect_pod} ) { |
574
|
25
|
100
|
100
|
|
|
98
|
if ( $self->{decode_pod} && $line =~ /^=encoding ([\w-]+)/ ) { |
575
|
1
|
|
|
|
|
4
|
$encoding = $1; |
576
|
|
|
|
|
|
|
} |
577
|
25
|
|
|
|
|
49
|
$pod_data .= "$line\n"; |
578
|
|
|
|
|
|
|
} |
579
|
454
|
|
|
|
|
1306
|
next; |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
elsif ( $is_cut ) { |
582
|
10
|
100
|
66
|
|
|
34
|
if ( $self->{collect_pod} && length( $pod_data ) ) { |
583
|
2
|
|
|
|
|
5
|
$pod{$pod_sect} = $pod_data; |
584
|
2
|
|
|
|
|
2
|
$pod_data = ''; |
585
|
|
|
|
|
|
|
} |
586
|
10
|
|
|
|
|
16
|
$pod_sect = ''; |
587
|
10
|
|
|
|
|
106
|
next; |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
# Skip after __END__ |
591
|
1226
|
100
|
|
|
|
1970
|
next if $in_end; |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
# Skip comments in code |
594
|
1224
|
100
|
|
|
|
2746
|
next if $line =~ /^\s*#/; |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
# Would be nice if we could also check $in_string or something too |
597
|
1126
|
100
|
|
|
|
2355
|
if ($line eq '__END__') { |
598
|
2
|
|
|
|
|
5
|
$in_end++; |
599
|
2
|
|
|
|
|
9
|
next; |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
1124
|
100
|
|
|
|
2178
|
last if $line eq '__DATA__'; |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
# parse $line to see if it's a $VERSION declaration |
605
|
1123
|
100
|
|
|
|
3379
|
my( $version_sigil, $version_fullname, $version_package ) = |
606
|
|
|
|
|
|
|
index($line, 'VERSION') >= 1 |
607
|
|
|
|
|
|
|
? $self->_parse_version_expression( $line ) |
608
|
|
|
|
|
|
|
: (); |
609
|
|
|
|
|
|
|
|
610
|
1123
|
100
|
100
|
|
|
9415
|
if ( $line =~ /$PKG_REGEXP/o ) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
611
|
136
|
|
|
|
|
392
|
$package = $1; |
612
|
136
|
|
|
|
|
269
|
my $version = $2; |
613
|
136
|
100
|
|
|
|
515
|
push( @packages, $package ) unless grep( $package eq $_, @packages ); |
614
|
136
|
100
|
|
|
|
327
|
$need_vers = defined $version ? 0 : 1; |
615
|
|
|
|
|
|
|
|
616
|
136
|
100
|
100
|
|
|
960
|
if ( not exists $vers{$package} and defined $version ){ |
617
|
|
|
|
|
|
|
# Upgrade to a version object. |
618
|
6
|
|
|
|
|
12
|
my $dwim_version = eval { _dwim_version($version) }; |
|
6
|
|
|
|
|
17
|
|
619
|
6
|
50
|
|
|
|
17
|
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
|
6
|
|
|
|
|
180
|
$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
|
20
|
100
|
|
|
|
65
|
$need_vers = 0 if $version_package eq $package; |
629
|
|
|
|
|
|
|
|
630
|
20
|
100
|
66
|
|
|
151
|
unless ( defined $vers{$version_package} && length $vers{$version_package} ) { |
631
|
18
|
|
|
|
|
54
|
$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
|
8
|
|
|
|
|
17
|
$need_vers = 0; |
638
|
8
|
|
|
|
|
23
|
my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); |
639
|
8
|
|
|
|
|
23
|
$vers{$package} = $v; |
640
|
8
|
|
|
|
|
90
|
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
|
8
|
|
|
|
|
17
|
$need_vers = 1; |
646
|
8
|
|
|
|
|
24
|
$vers{main} = ''; |
647
|
8
|
|
|
|
|
71
|
push( @packages, 'main' ); |
648
|
|
|
|
|
|
|
} |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
# only keep if this is the first $VERSION seen |
651
|
|
|
|
|
|
|
elsif ( $version_fullname && $need_vers ) { |
652
|
85
|
|
|
|
|
139
|
$need_vers = 0; |
653
|
85
|
|
|
|
|
197
|
my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); |
654
|
|
|
|
|
|
|
|
655
|
85
|
50
|
66
|
|
|
287
|
unless ( defined $vers{$package} && length $vers{$package} ) { |
656
|
85
|
|
|
|
|
715
|
$vers{$package} = $v; |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
} # end loop over each line |
660
|
|
|
|
|
|
|
|
661
|
110
|
100
|
100
|
|
|
452
|
if ( $self->{collect_pod} && length($pod_data) ) { |
662
|
1
|
|
|
|
|
4
|
$pod{$pod_sect} = $pod_data; |
663
|
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
|
|
665
|
110
|
100
|
66
|
|
|
272
|
if ( $self->{decode_pod} && $encoding ) { |
666
|
1
|
|
|
|
|
6
|
require Encode; |
667
|
1
|
|
|
|
|
14
|
$_ = Encode::decode( $encoding, $_ ) for values %pod; |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
|
670
|
110
|
|
|
|
|
661
|
$self->{versions} = \%vers; |
671
|
110
|
|
|
|
|
217
|
$self->{packages} = \@packages; |
672
|
110
|
|
|
|
|
202
|
$self->{pod} = \%pod; |
673
|
110
|
|
|
|
|
330
|
$self->{pod_headings} = \@pod; |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
sub __uniq (@) |
677
|
|
|
|
|
|
|
{ |
678
|
110
|
|
|
112
|
|
174
|
my (%seen, $key); |
679
|
110
|
|
|
|
|
590
|
grep !$seen{ $key = $_ }++, @_; |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
{ |
683
|
|
|
|
|
|
|
my $pn = 0; |
684
|
|
|
|
|
|
|
sub _evaluate_version_line { |
685
|
111
|
|
|
113
|
|
174
|
my $self = shift; |
686
|
111
|
|
|
|
|
241
|
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
|
111
|
|
|
|
|
183
|
$pn++; # everybody gets their own package |
691
|
111
|
|
|
|
|
518
|
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
|
111
|
50
|
|
|
|
554
|
$eval = $1 if $eval =~ m{^(.+)}s; |
703
|
|
|
|
|
|
|
|
704
|
111
|
|
|
|
|
375
|
local $^W; |
705
|
|
|
|
|
|
|
# Try to get the $VERSION |
706
|
111
|
|
|
|
|
262
|
my $vsub = __clean_eval($eval); |
707
|
|
|
|
|
|
|
# some modules say $VERSION $Foo::Bar::VERSION, but Foo::Bar isn't |
708
|
|
|
|
|
|
|
# installed, so we need to hunt in ./lib for it |
709
|
111
|
50
|
33
|
|
|
436
|
if ( $@ =~ /Can't locate/ && -d 'lib' ) { |
710
|
0
|
|
|
|
|
0
|
local @INC = ('lib',@INC); |
711
|
0
|
|
|
|
|
0
|
$vsub = __clean_eval($eval); |
712
|
|
|
|
|
|
|
} |
713
|
111
|
50
|
|
|
|
244
|
warn "Error evaling version line '$eval' in $self->{filename}: $@\n" |
714
|
|
|
|
|
|
|
if $@; |
715
|
|
|
|
|
|
|
|
716
|
111
|
50
|
|
|
|
328
|
(ref($vsub) eq 'CODE') or |
717
|
|
|
|
|
|
|
croak "failed to build version sub for $self->{filename}"; |
718
|
|
|
|
|
|
|
|
719
|
111
|
|
|
|
|
181
|
my $result = eval { $vsub->() }; |
|
111
|
|
|
|
|
2366
|
|
720
|
|
|
|
|
|
|
# FIXME: $eval is not the right thing to print here |
721
|
111
|
50
|
|
|
|
301
|
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
|
111
|
|
|
|
|
163
|
my $version = eval { _dwim_version($result) }; |
|
111
|
|
|
|
|
261
|
|
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
# FIXME: $eval is not the right thing to print here |
728
|
111
|
50
|
|
|
|
229
|
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
|
111
|
|
|
|
|
706
|
return $version; |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
# Try to DWIM when things fail the lax version test in obvious ways |
736
|
|
|
|
|
|
|
{ |
737
|
|
|
|
|
|
|
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; |
767
|
10
|
|
|
10
|
|
86
|
no warnings 'numeric'; |
|
10
|
|
|
|
|
31
|
|
|
10
|
|
|
|
|
4199
|
|
768
|
|
|
|
|
|
|
return 0 + $v; |
769
|
|
|
|
|
|
|
}, |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
); |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
sub _dwim_version { |
774
|
117
|
|
|
119
|
|
228
|
my ($result) = shift; |
775
|
|
|
|
|
|
|
|
776
|
117
|
100
|
|
|
|
257
|
return $result if ref($result) eq 'version'; |
777
|
|
|
|
|
|
|
|
778
|
112
|
|
|
|
|
208
|
my ($version, $error); |
779
|
112
|
|
|
|
|
262
|
for my $f (@version_prep) { |
780
|
124
|
|
|
|
|
256
|
$result = $f->($result); |
781
|
124
|
|
|
|
|
185
|
$version = eval { version->new($result) }; |
|
124
|
|
|
|
|
1004
|
|
782
|
124
|
100
|
66
|
|
|
345
|
$error ||= $@ if $@; # capture first failure |
783
|
124
|
100
|
|
|
|
295
|
last if defined $version; |
784
|
|
|
|
|
|
|
} |
785
|
|
|
|
|
|
|
|
786
|
112
|
50
|
|
|
|
219
|
croak $error unless defined $version; |
787
|
|
|
|
|
|
|
|
788
|
112
|
|
|
|
|
235
|
return $version; |
789
|
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
} |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
############################################################ |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
# accessors |
795
|
21
|
|
|
22
|
1
|
211
|
sub name { $_[0]->{module} } |
796
|
|
|
|
|
|
|
|
797
|
1
|
|
|
2
|
1
|
4
|
sub filename { $_[0]->{filename} } |
798
|
31
|
|
|
32
|
1
|
453
|
sub packages_inside { @{$_[0]->{packages}} } |
|
31
|
|
|
|
|
122
|
|
799
|
2
|
|
|
3
|
1
|
5
|
sub pod_inside { @{$_[0]->{pod_headings}} } |
|
2
|
|
|
|
|
9
|
|
800
|
4
|
|
|
5
|
1
|
1082
|
sub contains_pod { 0+@{$_[0]->{pod_headings}} } |
|
4
|
|
|
|
|
20
|
|
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
sub version { |
803
|
100
|
|
|
101
|
1
|
1082
|
my $self = shift; |
804
|
100
|
|
100
|
|
|
408
|
my $mod = shift || $self->{module}; |
805
|
100
|
|
|
|
|
147
|
my $vers; |
806
|
100
|
100
|
66
|
|
|
552
|
if ( defined( $mod ) && length( $mod ) && |
|
|
|
100
|
|
|
|
|
807
|
|
|
|
|
|
|
exists( $self->{versions}{$mod} ) ) { |
808
|
85
|
|
|
|
|
361
|
return $self->{versions}{$mod}; |
809
|
|
|
|
|
|
|
} |
810
|
|
|
|
|
|
|
else { |
811
|
15
|
|
|
|
|
60
|
return undef; |
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
sub pod { |
816
|
5
|
|
|
6
|
1
|
670
|
my $self = shift; |
817
|
5
|
|
|
|
|
12
|
my $sect = shift; |
818
|
5
|
100
|
33
|
|
|
35
|
if ( defined( $sect ) && length( $sect ) && |
|
|
|
66
|
|
|
|
|
819
|
|
|
|
|
|
|
exists( $self->{pod}{$sect} ) ) { |
820
|
3
|
|
|
|
|
10
|
return $self->{pod}{$sect}; |
821
|
|
|
|
|
|
|
} |
822
|
|
|
|
|
|
|
else { |
823
|
2
|
|
|
|
|
9
|
return undef; |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
} |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
sub is_indexable { |
828
|
8
|
|
|
9
|
1
|
23
|
my ($self, $package) = @_; |
829
|
|
|
|
|
|
|
|
830
|
8
|
|
|
|
|
19
|
my @indexable_packages = grep $_ ne 'main', $self->packages_inside; |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
# check for specific package, if provided |
833
|
8
|
100
|
|
|
|
51
|
return !! grep $_ eq $package, @indexable_packages if $package; |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
# otherwise, check for any indexable packages at all |
836
|
2
|
|
|
|
|
10
|
return !! @indexable_packages; |
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
1; |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
__END__ |