line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Parse::PMFile; |
2
|
|
|
|
|
|
|
|
3
|
134
|
|
|
134
|
|
18454
|
sub __clean_eval { eval $_[0] } # needs to be here (RT#101273) |
4
|
|
|
|
|
|
|
|
5
|
63
|
|
|
63
|
|
4200212
|
use strict; |
|
63
|
|
|
|
|
644
|
|
|
63
|
|
|
|
|
1830
|
|
6
|
63
|
|
|
63
|
|
340
|
use warnings; |
|
63
|
|
|
|
|
112
|
|
|
63
|
|
|
|
|
1481
|
|
7
|
63
|
|
|
63
|
|
33532
|
use Safe; |
|
63
|
|
|
|
|
2376417
|
|
|
63
|
|
|
|
|
3180
|
|
8
|
63
|
|
|
63
|
|
46174
|
use JSON::PP (); |
|
63
|
|
|
|
|
918224
|
|
|
63
|
|
|
|
|
1902
|
|
9
|
63
|
|
|
63
|
|
32326
|
use Dumpvalue; |
|
63
|
|
|
|
|
298455
|
|
|
63
|
|
|
|
|
2098
|
|
10
|
63
|
|
|
63
|
|
26625
|
use version (); |
|
63
|
|
|
|
|
118269
|
|
|
63
|
|
|
|
|
1705
|
|
11
|
63
|
|
|
63
|
|
479
|
use File::Spec (); |
|
63
|
|
|
|
|
118
|
|
|
63
|
|
|
|
|
72200
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $VERSION = '0.44'; |
14
|
|
|
|
|
|
|
our $VERBOSE = 0; |
15
|
|
|
|
|
|
|
our $ALLOW_DEV_VERSION = 0; |
16
|
|
|
|
|
|
|
our $FORK = 0; |
17
|
|
|
|
|
|
|
our $UNSAFE = $] < 5.010000 ? 1 : 0; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
sub new { |
20
|
237
|
|
|
237
|
1
|
565495
|
my ($class, $meta, $opts) = @_; |
21
|
237
|
100
|
|
|
|
651
|
bless {%{ $opts || {} }, META_CONTENT => $meta}, $class; |
|
237
|
|
|
|
|
2891
|
|
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# from PAUSE::pmfile::examine_fio |
25
|
|
|
|
|
|
|
sub parse { |
26
|
238
|
|
|
238
|
1
|
8840
|
my ($self, $pmfile) = @_; |
27
|
|
|
|
|
|
|
|
28
|
238
|
|
|
|
|
784
|
$pmfile =~ s|\\|/|g; |
29
|
|
|
|
|
|
|
|
30
|
238
|
|
|
|
|
4477
|
my($filemtime) = (stat $pmfile)[9]; |
31
|
238
|
|
|
|
|
1480
|
$self->{MTIME} = $filemtime; |
32
|
238
|
|
|
|
|
774
|
$self->{PMFILE} = $pmfile; |
33
|
|
|
|
|
|
|
|
34
|
238
|
100
|
|
|
|
825
|
unless ($self->_version_from_meta_ok) { |
35
|
232
|
|
|
|
|
449
|
my $version; |
36
|
232
|
50
|
|
|
|
476
|
unless (eval { $version = $self->_parse_version; 1 }) { |
|
232
|
|
|
|
|
726
|
|
|
195
|
|
|
|
|
1145
|
|
37
|
0
|
|
|
|
|
0
|
$self->_verbose(1, "error with version in $pmfile: $@"); |
38
|
0
|
|
|
|
|
0
|
return; |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
195
|
|
|
|
|
1456
|
$self->{VERSION} = $version; |
42
|
195
|
50
|
66
|
|
|
3362
|
if ($self->{VERSION} =~ /^\{.*\}$/) { |
|
|
100
|
100
|
|
|
|
|
43
|
|
|
|
|
|
|
# JSON error message |
44
|
|
|
|
|
|
|
} elsif ($self->{VERSION} =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!" |
45
|
5
|
|
|
|
|
48
|
return; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
196
|
|
|
|
|
2029
|
my($ppp) = $self->_packages_per_pmfile; |
50
|
196
|
|
|
|
|
2711
|
my @keys_ppp = $self->_filter_ppps(sort keys %$ppp); |
51
|
196
|
|
|
|
|
1960
|
$self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n"); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# |
54
|
|
|
|
|
|
|
# Immediately after each package (pmfile) examined contact |
55
|
|
|
|
|
|
|
# the database |
56
|
|
|
|
|
|
|
# |
57
|
|
|
|
|
|
|
|
58
|
196
|
|
|
|
|
807
|
my ($package, %errors); |
59
|
196
|
|
|
|
|
0
|
my %checked_in; |
60
|
196
|
|
|
|
|
1042
|
DBPACK: foreach $package (@keys_ppp) { |
61
|
|
|
|
|
|
|
# this part is taken from PAUSE::package::examine_pkg |
62
|
|
|
|
|
|
|
# and PAUSE::package::_pkg_name_insane |
63
|
196
|
50
|
33
|
|
|
8061
|
if ($package !~ /^\w[\w\:\']*\w?\z/ |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
64
|
|
|
|
|
|
|
|| $package !~ /\w\z/ |
65
|
|
|
|
|
|
|
|| $package =~ /:/ && $package !~ /::/ |
66
|
|
|
|
|
|
|
|| $package =~ /\w:\w/ |
67
|
|
|
|
|
|
|
|| $package =~ /:::/ |
68
|
|
|
|
|
|
|
){ |
69
|
0
|
|
|
|
|
0
|
$self->_verbose(1,"Package[$package] did not pass the ultimate sanity check"); |
70
|
0
|
|
|
|
|
0
|
delete $ppp->{$package}; |
71
|
0
|
|
|
|
|
0
|
next; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
196
|
0
|
33
|
|
|
878
|
if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) { |
|
|
|
0
|
|
|
|
|
75
|
0
|
|
|
|
|
0
|
delete $ppp->{$package}; |
76
|
0
|
|
|
|
|
0
|
next; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# Check that package name matches case of file name |
80
|
|
|
|
|
|
|
{ |
81
|
196
|
|
|
|
|
351
|
my (undef, $module) = split m{/lib/}, $self->{PMFILE}, 2; |
|
196
|
|
|
|
|
1353
|
|
82
|
196
|
100
|
|
|
|
788
|
if ($module) { |
83
|
6
|
|
|
|
|
33
|
$module =~ s{\.pm\z}{}; |
84
|
6
|
|
|
|
|
35
|
$module =~ s{/}{::}g; |
85
|
|
|
|
|
|
|
|
86
|
6
|
50
|
33
|
|
|
73
|
if (lc $module eq lc $package && $module ne $package) { |
87
|
|
|
|
|
|
|
# warn "/// $self->{PMFILE} vs. $module vs. $package\n"; |
88
|
|
|
|
|
|
|
$errors{$package} = { |
89
|
|
|
|
|
|
|
indexing_warning => "Capitalization of package ($package) does not match filename!", |
90
|
|
|
|
|
|
|
infile => $self->{PMFILE}, |
91
|
0
|
|
|
|
|
0
|
}; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
196
|
|
|
|
|
613
|
my $pp = $ppp->{$package}; |
97
|
196
|
50
|
66
|
|
|
2000
|
if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error |
98
|
0
|
|
|
|
|
0
|
my $err = JSON::PP::decode_json($pp->{version}); |
99
|
0
|
0
|
|
|
|
0
|
if ($err->{x_normalize}) { |
|
|
0
|
|
|
|
|
|
100
|
|
|
|
|
|
|
$errors{$package} = { |
101
|
|
|
|
|
|
|
normalize => $err->{version}, |
102
|
|
|
|
|
|
|
infile => $pp->{infile}, |
103
|
0
|
|
|
|
|
0
|
}; |
104
|
0
|
|
|
|
|
0
|
$pp->{version} = "undef"; |
105
|
|
|
|
|
|
|
} elsif ($err->{openerr}) { |
106
|
0
|
|
|
|
|
0
|
$pp->{version} = "undef"; |
107
|
0
|
|
|
|
|
0
|
$self->_verbose(1, |
108
|
|
|
|
|
|
|
qq{Parse::PMFile was not able to |
109
|
|
|
|
|
|
|
read the file. It issued the following error: C< $err->{r} >}, |
110
|
|
|
|
|
|
|
); |
111
|
|
|
|
|
|
|
$errors{$package} = { |
112
|
|
|
|
|
|
|
open => $err->{r}, |
113
|
|
|
|
|
|
|
infile => $pp->{infile}, |
114
|
0
|
|
|
|
|
0
|
}; |
115
|
|
|
|
|
|
|
} else { |
116
|
0
|
|
|
|
|
0
|
$pp->{version} = "undef"; |
117
|
0
|
|
|
|
|
0
|
$self->_verbose(1, |
118
|
|
|
|
|
|
|
qq{Parse::PMFile was not able to |
119
|
|
|
|
|
|
|
parse the following line in that file: C< $err->{line} > |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
Note: the indexer is running in a Safe compartement and cannot |
122
|
|
|
|
|
|
|
provide the full functionality of perl in the VERSION line. It |
123
|
|
|
|
|
|
|
is trying hard, but sometime it fails. As a workaround, please |
124
|
|
|
|
|
|
|
consider writing a META.yml that contains a 'provides' |
125
|
|
|
|
|
|
|
attribute or contact the CPAN admins to investigate (yet |
126
|
|
|
|
|
|
|
another) workaround against "Safe" limitations.)}, |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
); |
129
|
|
|
|
|
|
|
$errors{$package} = { |
130
|
|
|
|
|
|
|
parse_version => $err->{line}, |
131
|
|
|
|
|
|
|
infile => $err->{file}, |
132
|
0
|
|
|
|
|
0
|
}; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# Sanity checks |
137
|
|
|
|
|
|
|
|
138
|
196
|
|
|
|
|
836
|
for ( |
139
|
|
|
|
|
|
|
$package, |
140
|
|
|
|
|
|
|
$pp->{version}, |
141
|
|
|
|
|
|
|
) { |
142
|
392
|
50
|
66
|
|
|
4074
|
if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here |
|
|
|
66
|
|
|
|
|
143
|
4
|
|
|
|
|
14
|
delete $ppp->{$package}; |
144
|
4
|
|
|
|
|
12
|
next; # don't screw up 02packages |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
} |
147
|
196
|
100
|
|
|
|
1350
|
unless ($self->_version_ok($pp)) { |
148
|
|
|
|
|
|
|
$errors{$package} = { |
149
|
|
|
|
|
|
|
long_version => qq{Version string exceeds maximum allowed length of 16b: "$pp->{version}"}, |
150
|
|
|
|
|
|
|
infile => $pp->{infile}, |
151
|
3
|
|
|
|
|
27
|
}; |
152
|
3
|
|
|
|
|
10
|
next; |
153
|
|
|
|
|
|
|
} |
154
|
193
|
|
|
|
|
932
|
$checked_in{$package} = $ppp->{$package}; |
155
|
|
|
|
|
|
|
} # end foreach package |
156
|
|
|
|
|
|
|
|
157
|
196
|
100
|
66
|
|
|
2583
|
return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub _version_ok { |
161
|
196
|
|
|
196
|
|
669
|
my ($self, $pp) = @_; |
162
|
196
|
100
|
100
|
|
|
1037
|
return if length($pp->{version} || 0) > 16; |
163
|
193
|
|
|
|
|
636
|
return 1 |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub _perm_check { |
167
|
0
|
|
|
0
|
|
0
|
my ($self, $package) = @_; |
168
|
0
|
|
|
|
|
0
|
my $userid = $self->{USERID}; |
169
|
0
|
|
|
|
|
0
|
my $module = $self->{PERMISSIONS}->module_permissions($package); |
170
|
0
|
0
|
|
|
|
0
|
return 1 if !$module; # not listed yet |
171
|
0
|
0
|
0
|
|
|
0
|
return 1 if defined $module->m && $module->m eq $userid; |
172
|
0
|
0
|
0
|
|
|
0
|
return 1 if defined $module->f && $module->f eq $userid; |
173
|
0
|
0
|
0
|
|
|
0
|
return 1 if defined $module->c && grep {$_ eq $userid} @{$module->c}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
174
|
0
|
|
|
|
|
0
|
return; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# from PAUSE::pmfile; |
178
|
|
|
|
|
|
|
sub _parse_version { |
179
|
232
|
|
|
232
|
|
902
|
my $self = shift; |
180
|
|
|
|
|
|
|
|
181
|
63
|
|
|
63
|
|
560
|
use strict; |
|
63
|
|
|
|
|
166
|
|
|
63
|
|
|
|
|
24844
|
|
182
|
|
|
|
|
|
|
|
183
|
232
|
|
|
|
|
601
|
my $pmfile = $self->{PMFILE}; |
184
|
232
|
|
|
|
|
13470
|
my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000)); |
185
|
|
|
|
|
|
|
|
186
|
232
|
|
|
|
|
839
|
my $pmcp = $pmfile; |
187
|
232
|
|
|
|
|
757
|
for ($pmcp) { |
188
|
232
|
|
|
|
|
982
|
s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the |
189
|
|
|
|
|
|
|
# solution to escape @s and \ |
190
|
|
|
|
|
|
|
} |
191
|
232
|
|
|
|
|
386
|
my($v); |
192
|
|
|
|
|
|
|
{ |
193
|
|
|
|
|
|
|
|
194
|
232
|
|
|
|
|
364
|
package main; # seems necessary |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# XXX: do we need to fork as PAUSE does? |
197
|
|
|
|
|
|
|
# or, is alarm() just fine? |
198
|
232
|
|
|
|
|
367
|
my $pid; |
199
|
232
|
100
|
66
|
|
|
2035
|
if ($self->{FORK} || $FORK) { |
200
|
115
|
|
|
|
|
123250
|
$pid = fork(); |
201
|
115
|
50
|
|
|
|
9743
|
die "Can't fork: $!" unless defined $pid; |
202
|
|
|
|
|
|
|
} |
203
|
232
|
100
|
|
|
|
3016
|
if ($pid) { |
204
|
78
|
|
|
|
|
35318768
|
waitpid($pid, 0); |
205
|
78
|
50
|
|
|
|
23820
|
if (open my $fh, '<', $tmpfile) { |
206
|
78
|
|
|
|
|
14657
|
$v = <$fh>; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
} else { |
209
|
|
|
|
|
|
|
# XXX Limit Resources too |
210
|
|
|
|
|
|
|
|
211
|
154
|
|
|
|
|
1028
|
my $comp; |
212
|
154
|
|
|
|
|
1712
|
my $eval = qq{ |
213
|
|
|
|
|
|
|
local(\$^W) = 0; |
214
|
|
|
|
|
|
|
Parse::PMFile::_parse_version_safely("$pmcp"); |
215
|
|
|
|
|
|
|
}; |
216
|
154
|
50
|
33
|
|
|
2905
|
unless ($self->{UNSAFE} || $UNSAFE) { |
217
|
154
|
|
|
|
|
7558
|
$comp = Safe->new; |
218
|
154
|
|
|
|
|
311844
|
$comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz |
219
|
154
|
|
|
|
|
3034
|
$comp->share("*Parse::PMFile::_parse_version_safely"); |
220
|
154
|
|
|
|
|
22022
|
$comp->share("*version::new"); |
221
|
154
|
|
|
|
|
10096
|
$comp->share("*version::numify"); |
222
|
154
|
|
|
|
|
10352
|
$comp->share_from('main', ['*version::', |
223
|
|
|
|
|
|
|
'*charstar::', |
224
|
|
|
|
|
|
|
'*Exporter::', |
225
|
|
|
|
|
|
|
'*DynaLoader::']); |
226
|
154
|
|
|
|
|
236118
|
$comp->share_from('version', ['&qv']); |
227
|
154
|
|
|
|
|
9194
|
$comp->permit(":base_math"); # atan2 (Acme-Pi) |
228
|
|
|
|
|
|
|
# $comp->permit("require"); # no strict! |
229
|
154
|
|
|
|
|
2467
|
$comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
154
|
50
|
33
|
|
|
5754
|
version->import('qv') if $self->{UNSAFE} || $UNSAFE; |
233
|
|
|
|
|
|
|
{ |
234
|
63
|
|
|
63
|
|
512
|
no strict; |
|
63
|
|
|
|
|
219
|
|
|
63
|
|
|
|
|
19306
|
|
|
154
|
|
|
|
|
917
|
|
235
|
154
|
50
|
|
|
|
2712
|
$v = $comp ? $comp->reval($eval) : eval $eval; |
236
|
|
|
|
|
|
|
} |
237
|
154
|
100
|
|
|
|
173279
|
if ($@){ # still in the child process, out of Safe::reval |
238
|
21
|
|
|
|
|
117
|
my $err = $@; |
239
|
|
|
|
|
|
|
# warn ">>>>>>>err[$err]<<<<<<<<"; |
240
|
21
|
50
|
|
|
|
157
|
if (ref $err) { |
241
|
21
|
50
|
|
|
|
408
|
if ($err->{line} =~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/) { |
242
|
21
|
|
|
|
|
129
|
local($^W) = 0; |
243
|
21
|
|
|
|
|
172
|
my ($sigil, $vstr) = ($1, $3); |
244
|
21
|
50
|
|
|
|
536
|
$self->_restore_overloaded_stuff(1) if $err->{line} =~ /use\s+version\b|version\->|qv\(/; |
245
|
21
|
50
|
|
|
|
130
|
$v = $comp ? $comp->reval($vstr) : eval $vstr; |
246
|
21
|
50
|
33
|
|
|
22771
|
$v = $$v if $sigil eq '*' && ref $v; |
247
|
|
|
|
|
|
|
} |
248
|
21
|
50
|
33
|
|
|
321
|
if ($@ or !$v) { |
249
|
0
|
|
|
|
|
0
|
$self->_verbose(1, sprintf("reval failed: err[%s] for eval[%s]", |
250
|
|
|
|
|
|
|
JSON::PP::encode_json($err), |
251
|
|
|
|
|
|
|
$eval, |
252
|
|
|
|
|
|
|
)); |
253
|
0
|
|
|
|
|
0
|
$v = JSON::PP::encode_json($err); |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
} else { |
256
|
0
|
|
|
|
|
0
|
$v = JSON::PP::encode_json({ openerr => $err }); |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} |
259
|
154
|
50
|
|
|
|
1258
|
if (defined $v) { |
260
|
63
|
|
|
63
|
|
535
|
no warnings; |
|
63
|
|
|
|
|
233
|
|
|
63
|
|
|
|
|
19139
|
|
261
|
154
|
100
|
|
|
|
2490
|
$v = $v->numify if ref($v) =~ /^version(::vpp)?$/; |
262
|
|
|
|
|
|
|
} else { |
263
|
0
|
|
|
|
|
0
|
$v = ""; |
264
|
|
|
|
|
|
|
} |
265
|
154
|
100
|
66
|
|
|
3458
|
if ($self->{FORK} || $FORK) { |
266
|
37
|
|
|
|
|
6325
|
open my $fh, '>:utf8', $tmpfile; |
267
|
37
|
|
|
|
|
695
|
print $fh $v; |
268
|
37
|
|
|
|
|
3147
|
exit 0; |
269
|
|
|
|
|
|
|
} else { |
270
|
117
|
|
|
|
|
675
|
utf8::encode($v); |
271
|
|
|
|
|
|
|
# undefine empty $v as if read from the tmpfile |
272
|
117
|
50
|
33
|
|
|
1130
|
$v = undef if defined $v && !length $v; |
273
|
117
|
50
|
|
|
|
964
|
$comp->erase if ($comp); |
274
|
117
|
|
|
|
|
128784
|
$self->_restore_overloaded_stuff; |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
} |
278
|
195
|
100
|
66
|
|
|
27472
|
unlink $tmpfile if ($self->{FORK} || $FORK) && -e $tmpfile; |
|
|
|
66
|
|
|
|
|
279
|
|
|
|
|
|
|
|
280
|
195
|
|
|
|
|
3489
|
return $self->_normalize_version($v); |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
sub _restore_overloaded_stuff { |
284
|
138
|
|
|
138
|
|
715
|
my ($self, $used_version_in_safe) = @_; |
285
|
138
|
50
|
33
|
|
|
2191
|
return if $self->{UNSAFE} || $UNSAFE; |
286
|
|
|
|
|
|
|
|
287
|
63
|
|
|
63
|
|
542
|
no strict 'refs'; |
|
63
|
|
|
|
|
175
|
|
|
63
|
|
|
|
|
2212
|
|
288
|
63
|
|
|
63
|
|
393
|
no warnings 'redefine'; |
|
63
|
|
|
|
|
916
|
|
|
63
|
|
|
|
|
66210
|
|
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
# version XS in CPAN |
291
|
138
|
|
|
|
|
660
|
my $restored; |
292
|
138
|
50
|
|
|
|
890
|
if ($INC{'version/vxs.pm'}) { |
293
|
0
|
|
|
|
|
0
|
*{'version::(""'} = \&version::vxs::stringify; |
|
0
|
|
|
|
|
0
|
|
294
|
0
|
|
|
|
|
0
|
*{'version::(0+'} = \&version::vxs::numify; |
|
0
|
|
|
|
|
0
|
|
295
|
0
|
|
|
|
|
0
|
*{'version::(cmp'} = \&version::vxs::VCMP; |
|
0
|
|
|
|
|
0
|
|
296
|
0
|
|
|
|
|
0
|
*{'version::(<=>'} = \&version::vxs::VCMP; |
|
0
|
|
|
|
|
0
|
|
297
|
0
|
|
|
|
|
0
|
*{'version::(bool'} = \&version::vxs::boolean; |
|
0
|
|
|
|
|
0
|
|
298
|
0
|
|
|
|
|
0
|
$restored = 1; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
# version PP in CPAN |
301
|
138
|
50
|
|
|
|
727
|
if ($INC{'version/vpp.pm'}) { |
302
|
|
|
|
|
|
|
{ |
303
|
0
|
|
|
|
|
0
|
package # hide from PAUSE |
304
|
|
|
|
|
|
|
charstar; |
305
|
0
|
|
|
|
|
0
|
overload->import; |
306
|
|
|
|
|
|
|
} |
307
|
0
|
0
|
|
|
|
0
|
if (!$used_version_in_safe) { |
308
|
|
|
|
|
|
|
package # hide from PAUSE |
309
|
|
|
|
|
|
|
version::vpp; |
310
|
0
|
|
|
|
|
0
|
overload->import; |
311
|
|
|
|
|
|
|
} |
312
|
0
|
0
|
|
|
|
0
|
unless ($restored) { |
313
|
0
|
|
|
|
|
0
|
*{'version::(""'} = \&version::vpp::stringify; |
|
0
|
|
|
|
|
0
|
|
314
|
0
|
|
|
|
|
0
|
*{'version::(0+'} = \&version::vpp::numify; |
|
0
|
|
|
|
|
0
|
|
315
|
0
|
|
|
|
|
0
|
*{'version::(cmp'} = \&version::vpp::vcmp; |
|
0
|
|
|
|
|
0
|
|
316
|
0
|
|
|
|
|
0
|
*{'version::(<=>'} = \&version::vpp::vcmp; |
|
0
|
|
|
|
|
0
|
|
317
|
0
|
|
|
|
|
0
|
*{'version::(bool'} = \&version::vpp::vbool; |
|
0
|
|
|
|
|
0
|
|
318
|
|
|
|
|
|
|
} |
319
|
0
|
|
|
|
|
0
|
*{'version::vpp::(""'} = \&version::vpp::stringify; |
|
0
|
|
|
|
|
0
|
|
320
|
0
|
|
|
|
|
0
|
*{'version::vpp::(0+'} = \&version::vpp::numify; |
|
0
|
|
|
|
|
0
|
|
321
|
0
|
|
|
|
|
0
|
*{'version::vpp::(cmp'} = \&version::vpp::vcmp; |
|
0
|
|
|
|
|
0
|
|
322
|
0
|
|
|
|
|
0
|
*{'version::vpp::(<=>'} = \&version::vpp::vcmp; |
|
0
|
|
|
|
|
0
|
|
323
|
0
|
|
|
|
|
0
|
*{'version::vpp::(bool'} = \&version::vpp::vbool; |
|
0
|
|
|
|
|
0
|
|
324
|
0
|
|
|
|
|
0
|
*{'charstar::(""'} = \&charstar::thischar; |
|
0
|
|
|
|
|
0
|
|
325
|
0
|
|
|
|
|
0
|
*{'charstar::(0+'} = \&charstar::thischar; |
|
0
|
|
|
|
|
0
|
|
326
|
0
|
|
|
|
|
0
|
*{'charstar::(++'} = \&charstar::increment; |
|
0
|
|
|
|
|
0
|
|
327
|
0
|
|
|
|
|
0
|
*{'charstar::(--'} = \&charstar::decrement; |
|
0
|
|
|
|
|
0
|
|
328
|
0
|
|
|
|
|
0
|
*{'charstar::(+'} = \&charstar::plus; |
|
0
|
|
|
|
|
0
|
|
329
|
0
|
|
|
|
|
0
|
*{'charstar::(-'} = \&charstar::minus; |
|
0
|
|
|
|
|
0
|
|
330
|
0
|
|
|
|
|
0
|
*{'charstar::(*'} = \&charstar::multiply; |
|
0
|
|
|
|
|
0
|
|
331
|
0
|
|
|
|
|
0
|
*{'charstar::(cmp'} = \&charstar::cmp; |
|
0
|
|
|
|
|
0
|
|
332
|
0
|
|
|
|
|
0
|
*{'charstar::(<=>'} = \&charstar::spaceship; |
|
0
|
|
|
|
|
0
|
|
333
|
0
|
|
|
|
|
0
|
*{'charstar::(bool'} = \&charstar::thischar; |
|
0
|
|
|
|
|
0
|
|
334
|
0
|
|
|
|
|
0
|
*{'charstar::(='} = \&charstar::clone; |
|
0
|
|
|
|
|
0
|
|
335
|
0
|
|
|
|
|
0
|
$restored = 1; |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
# version in core |
338
|
138
|
50
|
|
|
|
657
|
if (!$restored) { |
339
|
138
|
|
|
|
|
583
|
*{'version::(""'} = \&version::stringify; |
|
138
|
|
|
|
|
816
|
|
340
|
138
|
|
|
|
|
428
|
*{'version::(0+'} = \&version::numify; |
|
138
|
|
|
|
|
717
|
|
341
|
138
|
|
|
|
|
417
|
*{'version::(cmp'} = \&version::vcmp; |
|
138
|
|
|
|
|
445
|
|
342
|
138
|
|
|
|
|
317
|
*{'version::(<=>'} = \&version::vcmp; |
|
138
|
|
|
|
|
385
|
|
343
|
138
|
|
|
|
|
285
|
*{'version::(bool'} = \&version::boolean; |
|
138
|
|
|
|
|
979
|
|
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
# from PAUSE::pmfile; |
348
|
|
|
|
|
|
|
sub _packages_per_pmfile { |
349
|
196
|
|
|
196
|
|
641
|
my $self = shift; |
350
|
|
|
|
|
|
|
|
351
|
196
|
|
|
|
|
676
|
my $ppp = {}; |
352
|
196
|
|
|
|
|
722
|
my $pmfile = $self->{PMFILE}; |
353
|
196
|
|
|
|
|
626
|
my $filemtime = $self->{MTIME}; |
354
|
196
|
|
|
|
|
637
|
my $version = $self->{VERSION}; |
355
|
|
|
|
|
|
|
|
356
|
196
|
50
|
|
|
|
11081
|
open my $fh, "<", "$pmfile" or return $ppp; |
357
|
|
|
|
|
|
|
|
358
|
196
|
|
|
|
|
2969
|
local $/ = "\n"; |
359
|
196
|
|
|
|
|
819
|
my $inpod = 0; |
360
|
|
|
|
|
|
|
|
361
|
196
|
|
|
|
|
5998
|
PLINE: while (<$fh>) { |
362
|
5706
|
|
|
|
|
9008
|
chomp; |
363
|
5706
|
|
|
|
|
9887
|
my($pline) = $_; |
364
|
5706
|
50
|
|
|
|
13721
|
$inpod = $pline =~ /^=(?!cut)/ ? 1 : |
|
|
50
|
|
|
|
|
|
365
|
|
|
|
|
|
|
$pline =~ /^=cut/ ? 0 : $inpod; |
366
|
5706
|
50
|
|
|
|
9967
|
next if $inpod; |
367
|
5706
|
50
|
|
|
|
11491
|
next if substr($pline,0,4) eq "=cut"; |
368
|
|
|
|
|
|
|
|
369
|
5706
|
|
|
|
|
10254
|
$pline =~ s/\#.*//; |
370
|
5706
|
100
|
|
|
|
17875
|
next if $pline =~ /^\s*$/; |
371
|
4504
|
100
|
66
|
|
|
9697
|
if ($pline =~ /^__(?:END|DATA)__\b/ |
372
|
|
|
|
|
|
|
and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__ |
373
|
|
|
|
|
|
|
){ |
374
|
9
|
|
|
|
|
33
|
last PLINE; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
4495
|
|
|
|
|
6573
|
my $pkg; |
378
|
|
|
|
|
|
|
my $strict_version; |
379
|
|
|
|
|
|
|
|
380
|
4495
|
100
|
|
|
|
29784
|
if ( |
381
|
|
|
|
|
|
|
$pline =~ m{ |
382
|
|
|
|
|
|
|
# (.*) # takes too much time if $pline is long |
383
|
|
|
|
|
|
|
#(?
|
384
|
|
|
|
|
|
|
^[\s\{;]* |
385
|
|
|
|
|
|
|
\b(?:package|class|role)\s+ |
386
|
|
|
|
|
|
|
([\w\:\']+) |
387
|
|
|
|
|
|
|
\s* |
388
|
|
|
|
|
|
|
(?: $ | [\}\;] | \{ | \s+($version::STRICT) ) |
389
|
|
|
|
|
|
|
}x) { |
390
|
205
|
|
|
|
|
1374
|
$pkg = $1; |
391
|
205
|
|
|
|
|
629
|
$strict_version = $2; |
392
|
205
|
50
|
|
|
|
824
|
if ($pkg eq "DB"){ |
393
|
|
|
|
|
|
|
# XXX if pumpkin and perl make him comaintainer! I |
394
|
|
|
|
|
|
|
# think I always made the pumpkins comaint on DB |
395
|
|
|
|
|
|
|
# without further ado (?) |
396
|
0
|
|
|
|
|
0
|
next PLINE; |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
|
400
|
4495
|
100
|
|
|
|
14800
|
if ($pkg) { |
401
|
|
|
|
|
|
|
# Found something |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
# from package |
404
|
205
|
|
|
|
|
700
|
$pkg =~ s/\'/::/g; |
405
|
205
|
50
|
|
|
|
1317
|
next PLINE unless $pkg =~ /^[A-Za-z]/; |
406
|
205
|
50
|
|
|
|
1551
|
next PLINE unless $pkg =~ /\w$/; |
407
|
205
|
100
|
|
|
|
844
|
next PLINE if $pkg eq "main"; |
408
|
|
|
|
|
|
|
# Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg |
409
|
|
|
|
|
|
|
# database for modid in mods, package in packages, package in perms |
410
|
|
|
|
|
|
|
# alter table mods modify modid varchar(128) binary NOT NULL default ''; |
411
|
|
|
|
|
|
|
# alter table packages modify package varchar(128) binary NOT NULL default ''; |
412
|
199
|
50
|
|
|
|
733
|
next PLINE if length($pkg) > 128; |
413
|
|
|
|
|
|
|
#restriction |
414
|
199
|
|
|
|
|
1840
|
$ppp->{$pkg}{parsed}++; |
415
|
199
|
|
|
|
|
1160
|
$ppp->{$pkg}{infile} = $pmfile; |
416
|
199
|
100
|
|
|
|
1383
|
if ($self->_simile($pmfile,$pkg)) { |
417
|
193
|
|
|
|
|
906
|
$ppp->{$pkg}{simile} = $pmfile; |
418
|
193
|
100
|
|
|
|
844
|
if ($self->_version_from_meta_ok) { |
419
|
6
|
|
|
|
|
13
|
my $provides = $self->{META_CONTENT}{provides}; |
420
|
6
|
50
|
|
|
|
29
|
if (exists $provides->{$pkg}) { |
421
|
6
|
50
|
|
|
|
57
|
if (defined $provides->{$pkg}{version}) { |
422
|
6
|
|
|
|
|
16
|
my $v = $provides->{$pkg}{version}; |
423
|
6
|
100
|
33
|
|
|
102
|
if ($v =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!" |
|
|
|
66
|
|
|
|
|
424
|
4
|
|
|
|
|
38
|
next PLINE; |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
|
427
|
2
|
50
|
|
|
|
16
|
unless (eval { $version = $self->_normalize_version($v); 1 }) { |
|
2
|
|
|
|
|
12
|
|
|
2
|
|
|
|
|
12
|
|
428
|
0
|
|
|
|
|
0
|
$self->_verbose(1, "error with version in $pmfile: $@"); |
429
|
0
|
|
|
|
|
0
|
next; |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
} |
432
|
2
|
|
|
|
|
15
|
$ppp->{$pkg}{version} = $version; |
433
|
|
|
|
|
|
|
} else { |
434
|
0
|
|
|
|
|
0
|
$ppp->{$pkg}{version} = "undef"; |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
} else { |
438
|
187
|
100
|
|
|
|
643
|
if (defined $strict_version){ |
439
|
19
|
|
|
|
|
169
|
$ppp->{$pkg}{version} = $strict_version ; |
440
|
|
|
|
|
|
|
} else { |
441
|
168
|
50
|
|
|
|
1081
|
$ppp->{$pkg}{version} = defined $version ? $version : ""; |
442
|
|
|
|
|
|
|
} |
443
|
63
|
|
|
63
|
|
497
|
no warnings; |
|
63
|
|
|
|
|
134
|
|
|
63
|
|
|
|
|
15001
|
|
444
|
187
|
100
|
|
|
|
730
|
if ($version eq 'undef') { |
445
|
19
|
50
|
|
|
|
110
|
$ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version}; |
446
|
|
|
|
|
|
|
} else { |
447
|
|
|
|
|
|
|
$ppp->{$pkg}{version} = |
448
|
|
|
|
|
|
|
$version |
449
|
|
|
|
|
|
|
if $version |
450
|
|
|
|
|
|
|
> $ppp->{$pkg}{version} || |
451
|
|
|
|
|
|
|
$version |
452
|
168
|
50
|
33
|
|
|
2129
|
gt $ppp->{$pkg}{version}; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
} else { # not simile |
456
|
|
|
|
|
|
|
#### it comes later, it would be nonsense |
457
|
|
|
|
|
|
|
#### to set to "undef". MM_Unix gives us |
458
|
|
|
|
|
|
|
#### the best we can reasonably consider |
459
|
|
|
|
|
|
|
$ppp->{$pkg}{version} = |
460
|
|
|
|
|
|
|
$version |
461
|
|
|
|
|
|
|
unless defined $ppp->{$pkg}{version} && |
462
|
6
|
50
|
33
|
|
|
23
|
length($ppp->{$pkg}{version}); |
463
|
|
|
|
|
|
|
} |
464
|
195
|
|
|
|
|
1329
|
$ppp->{$pkg}{filemtime} = $filemtime; |
465
|
|
|
|
|
|
|
} else { |
466
|
|
|
|
|
|
|
# $self->_verbose(2,"no pkg found"); |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
196
|
|
|
|
|
2849
|
close $fh; |
471
|
196
|
|
|
|
|
2788
|
$ppp; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
# from PAUSE::pmfile; |
475
|
|
|
|
|
|
|
{ |
476
|
63
|
|
|
63
|
|
465
|
no strict; |
|
63
|
|
|
|
|
140
|
|
|
63
|
|
|
|
|
30289
|
|
477
|
|
|
|
|
|
|
sub _parse_version_safely { |
478
|
154
|
|
|
154
|
|
79959
|
my($parsefile) = @_; |
479
|
154
|
|
|
|
|
480
|
my $result; |
480
|
154
|
|
|
|
|
586
|
local *FH; |
481
|
154
|
|
|
|
|
1905
|
local $/ = "\n"; |
482
|
154
|
50
|
|
|
|
10571
|
open(FH,$parsefile) or die "Could not open '$parsefile': $!"; |
483
|
154
|
|
|
|
|
1317
|
my $inpod = 0; |
484
|
154
|
|
|
|
|
6074
|
while () { |
485
|
437
|
50
|
|
|
|
3009
|
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; |
|
|
50
|
|
|
|
|
|
486
|
437
|
50
|
33
|
|
|
3937
|
next if $inpod || /^\s*#/; |
487
|
437
|
100
|
|
|
|
1661
|
last if /^__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare -> __END__ in the middle of a line is rarer |
488
|
434
|
|
|
|
|
1064
|
chop; |
489
|
|
|
|
|
|
|
|
490
|
434
|
100
|
|
|
|
2283
|
if (my ($ver) = /package \s+ \S+ \s+ (\S+) \s* [;{]/x) { |
491
|
|
|
|
|
|
|
# XXX: should handle this better if version is bogus -- rjbs, |
492
|
|
|
|
|
|
|
# 2014-03-16 |
493
|
6
|
100
|
|
|
|
54
|
return $ver if version::is_lax($ver); |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; |
497
|
431
|
100
|
|
|
|
4174
|
next unless /(?<=])\=(?![=>])/; |
498
|
134
|
|
|
|
|
557
|
my $current_parsed_line = $_; |
499
|
134
|
|
|
|
|
2236
|
my $eval = qq{ |
500
|
|
|
|
|
|
|
package # |
501
|
|
|
|
|
|
|
ExtUtils::MakeMaker::_version; |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
local $1$2; |
504
|
|
|
|
|
|
|
\$$2=undef; do { |
505
|
|
|
|
|
|
|
$_ |
506
|
|
|
|
|
|
|
}; \$$2 |
507
|
|
|
|
|
|
|
}; |
508
|
134
|
|
|
|
|
1247
|
local $^W = 0; |
509
|
134
|
|
|
0
|
|
2491
|
local $SIG{__WARN__} = sub {}; |
510
|
134
|
|
|
|
|
1464
|
$result = __clean_eval($eval); |
511
|
|
|
|
|
|
|
# warn "current_parsed_line[$current_parsed_line]\$\@[$@]"; |
512
|
134
|
100
|
66
|
|
|
1714
|
if ($@ or !defined $result){ |
513
|
21
|
|
|
|
|
1285
|
die +{ |
514
|
|
|
|
|
|
|
eval => $eval, |
515
|
|
|
|
|
|
|
line => $current_parsed_line, |
516
|
|
|
|
|
|
|
file => $parsefile, |
517
|
|
|
|
|
|
|
err => $@, |
518
|
|
|
|
|
|
|
}; |
519
|
|
|
|
|
|
|
} |
520
|
113
|
|
|
|
|
919
|
last; |
521
|
|
|
|
|
|
|
} #; |
522
|
130
|
|
|
|
|
2443
|
close FH; |
523
|
|
|
|
|
|
|
|
524
|
130
|
100
|
|
|
|
826
|
$result = "undef" unless defined $result; |
525
|
130
|
100
|
|
|
|
571
|
if ((ref $result) =~ /^version(?:::vpp)?\b/) { |
526
|
63
|
|
|
63
|
|
497
|
no warnings; |
|
63
|
|
|
|
|
228
|
|
|
63
|
|
|
|
|
52728
|
|
527
|
6
|
|
|
|
|
65
|
$result = $result->numify; |
528
|
|
|
|
|
|
|
} |
529
|
130
|
|
|
|
|
3609
|
return $result; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# from PAUSE::pmfile; |
534
|
|
|
|
|
|
|
sub _filter_ppps { |
535
|
196
|
|
|
196
|
|
1075
|
my($self,@ppps) = @_; |
536
|
196
|
|
|
|
|
464
|
my @res; |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
# very similar code is in PAUSE::dist::filter_pms |
539
|
196
|
|
|
|
|
1159
|
MANI: for my $ppp ( @ppps ) { |
540
|
199
|
100
|
|
|
|
1006
|
if ($self->{META_CONTENT}){ |
541
|
|
|
|
|
|
|
my $no_index = $self->{META_CONTENT}{no_index} |
542
|
9
|
|
66
|
|
|
71
|
|| $self->{META_CONTENT}{private}; # backward compat |
543
|
9
|
100
|
|
|
|
40
|
if (ref($no_index) eq 'HASH') { |
544
|
3
|
|
|
|
|
45
|
my %map = ( |
545
|
|
|
|
|
|
|
package => qr{\z}, |
546
|
|
|
|
|
|
|
namespace => qr{::}, |
547
|
|
|
|
|
|
|
); |
548
|
3
|
|
|
|
|
14
|
for my $k (qw(package namespace)) { |
549
|
3
|
50
|
|
|
|
14
|
next unless my $v = $no_index->{$k}; |
550
|
3
|
|
|
|
|
10
|
my $rest = $map{$k}; |
551
|
3
|
50
|
|
|
|
28
|
if (ref $v eq "ARRAY") { |
552
|
3
|
|
|
|
|
11
|
for my $ve (@$v) { |
553
|
3
|
|
|
|
|
12
|
$ve =~ s|::$||; |
554
|
3
|
50
|
|
|
|
54
|
if ($ppp =~ /^$ve$rest/){ |
555
|
3
|
|
|
|
|
26
|
$self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]"); |
556
|
3
|
|
|
|
|
40
|
next MANI; |
557
|
|
|
|
|
|
|
} else { |
558
|
0
|
|
|
|
|
0
|
$self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]"); |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
} else { |
562
|
0
|
|
|
|
|
0
|
$v =~ s|::$||; |
563
|
0
|
0
|
|
|
|
0
|
if ($ppp =~ /^$v$rest/){ |
564
|
0
|
|
|
|
|
0
|
$self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]"); |
565
|
0
|
|
|
|
|
0
|
next MANI; |
566
|
|
|
|
|
|
|
} else { |
567
|
0
|
|
|
|
|
0
|
$self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]"); |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
} else { |
572
|
6
|
|
|
|
|
17
|
$self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT"); |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
} else { |
575
|
|
|
|
|
|
|
# $self->_verbose(1,"no META_CONTENT"); # too noisy |
576
|
|
|
|
|
|
|
} |
577
|
196
|
|
|
|
|
932
|
push @res, $ppp; |
578
|
|
|
|
|
|
|
} |
579
|
196
|
|
|
|
|
1517
|
$self->_verbose(1,"Result of filter_ppps: res[@res]"); |
580
|
196
|
|
|
|
|
926
|
@res; |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
# from PAUSE::pmfile; |
584
|
|
|
|
|
|
|
sub _simile { |
585
|
199
|
|
|
199
|
|
1211
|
my($self,$file,$package) = @_; |
586
|
|
|
|
|
|
|
# MakeMaker gives them the chance to have the file Simple.pm in |
587
|
|
|
|
|
|
|
# this directory but have the package HTML::Simple in it. |
588
|
|
|
|
|
|
|
# Afaik, they wouldn't be able to do so with deeper nested packages |
589
|
199
|
|
|
|
|
1960
|
$file =~ s|.*/||; |
590
|
199
|
|
|
|
|
2170
|
$file =~ s|\.pm(?:\.PL)?||; |
591
|
199
|
|
|
|
|
2936
|
my $ret = $package =~ m/\b\Q$file\E$/; |
592
|
199
|
|
100
|
|
|
790
|
$ret ||= 0; |
593
|
199
|
100
|
|
|
|
773
|
unless ($ret) { |
594
|
|
|
|
|
|
|
# Apache::mod_perl_guide stuffs it into Version.pm |
595
|
6
|
50
|
|
|
|
28
|
$ret = 1 if lc $file eq 'version'; |
596
|
|
|
|
|
|
|
} |
597
|
199
|
|
|
|
|
1647
|
$self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n"); |
598
|
199
|
|
|
|
|
933
|
$ret; |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
# from PAUSE::pmfile |
602
|
|
|
|
|
|
|
sub _normalize_version { |
603
|
197
|
|
|
197
|
|
1871
|
my($self,$v) = @_; |
604
|
197
|
50
|
|
|
|
1295
|
$v = "undef" unless defined $v; |
605
|
197
|
|
|
|
|
5000
|
my $dv = Dumpvalue->new; |
606
|
197
|
|
|
|
|
18032
|
my $sdv = $dv->stringify($v,1); # second argument prevents ticks |
607
|
197
|
|
|
|
|
11650
|
$self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n"); |
608
|
|
|
|
|
|
|
|
609
|
197
|
100
|
|
|
|
1463
|
return $v if $v eq "undef"; |
610
|
178
|
50
|
|
|
|
2144
|
return $v if $v =~ /^\{.*\}$/; # JSON object |
611
|
178
|
|
|
|
|
2493
|
$v =~ s/^\s+//; |
612
|
178
|
|
|
|
|
1158
|
$v =~ s/\s+\z//; |
613
|
178
|
100
|
|
|
|
1562
|
if ($v =~ /_/) { |
614
|
|
|
|
|
|
|
# XXX should pass something like EDEVELOPERRELEASE up e.g. |
615
|
|
|
|
|
|
|
# SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one |
616
|
|
|
|
|
|
|
# such modules and the mesage was not helpful that "nothing |
617
|
|
|
|
|
|
|
# was found". |
618
|
10
|
|
|
|
|
128
|
return $v ; |
619
|
|
|
|
|
|
|
} |
620
|
168
|
50
|
|
|
|
2489
|
if (!version::is_lax($v)) { |
621
|
0
|
|
|
|
|
0
|
return JSON::PP::encode_json({ x_normalize => 'version::is_lax failed', version => $v }); |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
# may warn "Integer overflow" |
624
|
63
|
|
|
63
|
|
542
|
my $vv = eval { no warnings; version->new($v)->numify }; |
|
63
|
|
|
|
|
136
|
|
|
63
|
|
|
|
|
6541
|
|
|
168
|
|
|
|
|
11495
|
|
|
168
|
|
|
|
|
6037
|
|
625
|
168
|
50
|
|
|
|
1357
|
if ($@) { |
626
|
|
|
|
|
|
|
# warn "$v: $@"; |
627
|
0
|
|
|
|
|
0
|
return JSON::PP::encode_json({ x_normalize => $@, version => $v }); |
628
|
|
|
|
|
|
|
# return "undef"; |
629
|
|
|
|
|
|
|
} |
630
|
168
|
100
|
|
|
|
1160
|
if ($vv eq $v) { |
631
|
|
|
|
|
|
|
# the boring 3.14 |
632
|
|
|
|
|
|
|
} else { |
633
|
141
|
|
|
|
|
1021
|
my $forced = $self->_force_numeric($v); |
634
|
141
|
50
|
|
|
|
1049
|
if ($forced eq $vv) { |
|
|
50
|
|
|
|
|
|
635
|
|
|
|
|
|
|
} elsif ($forced =~ /^v(.+)/) { |
636
|
|
|
|
|
|
|
# rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz) |
637
|
63
|
|
|
63
|
|
434
|
no warnings; |
|
63
|
|
|
|
|
158
|
|
|
63
|
|
|
|
|
96425
|
|
638
|
0
|
|
|
|
|
0
|
$vv = version->new($1)->numify; |
639
|
|
|
|
|
|
|
} else { |
640
|
|
|
|
|
|
|
# warn "Unequal forced[$forced] and vv[$vv]"; |
641
|
141
|
50
|
|
|
|
1128
|
if ($forced == $vv) { |
642
|
|
|
|
|
|
|
# the trailing zeroes would cause unnecessary havoc |
643
|
141
|
|
|
|
|
440
|
$vv = $forced; |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
|
} |
647
|
168
|
|
|
|
|
2731
|
return $vv; |
648
|
|
|
|
|
|
|
} |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
# from PAUSE::pmfile; |
651
|
|
|
|
|
|
|
sub _force_numeric { |
652
|
141
|
|
|
141
|
|
1056
|
my($self,$v) = @_; |
653
|
141
|
|
|
|
|
1311
|
$v = $self->_readable($v); |
654
|
|
|
|
|
|
|
|
655
|
141
|
50
|
33
|
|
|
3558
|
if ( |
|
|
|
33
|
|
|
|
|
656
|
|
|
|
|
|
|
$v =~ |
657
|
|
|
|
|
|
|
/^(\+?)(\d*)(\.(\d*))?/ && |
658
|
|
|
|
|
|
|
# "$2$4" ne '' |
659
|
|
|
|
|
|
|
( |
660
|
|
|
|
|
|
|
defined $2 && length $2 |
661
|
|
|
|
|
|
|
|| |
662
|
|
|
|
|
|
|
defined $4 && length $4 |
663
|
|
|
|
|
|
|
) |
664
|
|
|
|
|
|
|
) { |
665
|
141
|
50
|
|
|
|
998
|
my $two = defined $2 ? $2 : ""; |
666
|
141
|
50
|
|
|
|
750
|
my $three = defined $3 ? $3 : ""; |
667
|
141
|
|
|
|
|
443
|
$v = "$two$three"; |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
# no else branch! We simply say, everything else is a string. |
670
|
141
|
|
|
|
|
499
|
$v; |
671
|
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
# from PAUSE::dist |
674
|
|
|
|
|
|
|
sub _version_from_meta_ok { |
675
|
431
|
|
|
431
|
|
1467
|
my($self) = @_; |
676
|
431
|
100
|
|
|
|
1970
|
return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK}; |
677
|
237
|
|
|
|
|
639
|
my $c = $self->{META_CONTENT}; |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
# If there's no provides hash, we can't get our module versions from the |
680
|
|
|
|
|
|
|
# provides hash! -- rjbs, 2012-03-31 |
681
|
237
|
100
|
|
|
|
1466
|
return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides}; |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
# Some versions of Module::Build geneated an empty provides hash. If we're |
684
|
|
|
|
|
|
|
# *not* looking at a Module::Build-generated metafile, then it's okay. |
685
|
6
|
50
|
|
|
|
50
|
my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/; |
686
|
6
|
50
|
|
|
|
47
|
return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v; |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
# ??? I don't know why this is here. |
689
|
0
|
0
|
|
|
|
0
|
return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0'; |
690
|
|
|
|
|
|
|
|
691
|
0
|
0
|
0
|
|
|
0
|
if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) { |
|
0
|
|
0
|
|
|
0
|
|
692
|
|
|
|
|
|
|
# RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron |
693
|
|
|
|
|
|
|
# did not find the reason why this happened, but let's not go |
694
|
|
|
|
|
|
|
# overboard, 0.26 seems a good threshold from the statistics: there |
695
|
|
|
|
|
|
|
# are not many empty provides hashes from 0.26 up. |
696
|
0
|
|
|
|
|
0
|
return($self->{VERSION_FROM_META_OK} = 0); |
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
# We're not in the suspect range of M::B versions. It's good to go. |
700
|
0
|
|
|
|
|
0
|
return($self->{VERSION_FROM_META_OK} = 1); |
701
|
|
|
|
|
|
|
} |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
sub _verbose { |
704
|
797
|
|
|
797
|
|
2500
|
my($self,$level,@what) = @_; |
705
|
797
|
50
|
33
|
|
|
8370
|
warn @what if $level <= ((ref $self && $self->{VERBOSE}) || $VERBOSE); |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
# all of the following methods are stripped from CPAN::Version |
709
|
|
|
|
|
|
|
# (as of version 5.5001, bundled in CPAN 2.03), and slightly |
710
|
|
|
|
|
|
|
# modified (ie. made private, as well as CPAN->debug(...) are |
711
|
|
|
|
|
|
|
# replaced with $self->_verbose(9, ...).) |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
# CPAN::Version::vcmp courtesy Jost Krieger |
714
|
|
|
|
|
|
|
sub _vcmp { |
715
|
0
|
|
|
0
|
|
0
|
my($self,$l,$r) = @_; |
716
|
0
|
|
|
|
|
0
|
local($^W) = 0; |
717
|
0
|
|
|
|
|
0
|
$self->_verbose(9, "l[$l] r[$r]"); |
718
|
|
|
|
|
|
|
|
719
|
0
|
0
|
|
|
|
0
|
return 0 if $l eq $r; # short circuit for quicker success |
720
|
|
|
|
|
|
|
|
721
|
0
|
|
|
|
|
0
|
for ($l,$r) { |
722
|
0
|
|
|
|
|
0
|
s/_//g; |
723
|
|
|
|
|
|
|
} |
724
|
0
|
|
|
|
|
0
|
$self->_verbose(9, "l[$l] r[$r]"); |
725
|
0
|
|
|
|
|
0
|
for ($l,$r) { |
726
|
0
|
0
|
0
|
|
|
0
|
next unless tr/.// > 1 || /^v/; |
727
|
0
|
|
|
|
|
0
|
s/^v?/v/; |
728
|
0
|
|
|
|
|
0
|
1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group |
729
|
|
|
|
|
|
|
} |
730
|
0
|
|
|
|
|
0
|
$self->_verbose(9, "l[$l] r[$r]"); |
731
|
0
|
0
|
|
|
|
0
|
if ($l=~/^v/ <=> $r=~/^v/) { |
732
|
0
|
|
|
|
|
0
|
for ($l,$r) { |
733
|
0
|
0
|
|
|
|
0
|
next if /^v/; |
734
|
0
|
|
|
|
|
0
|
$_ = $self->_float2vv($_); |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
} |
737
|
0
|
|
|
|
|
0
|
$self->_verbose(9, "l[$l] r[$r]"); |
738
|
0
|
|
|
|
|
0
|
my $lvstring = "v0"; |
739
|
0
|
|
|
|
|
0
|
my $rvstring = "v0"; |
740
|
0
|
0
|
0
|
|
|
0
|
if ($] >= 5.006 |
|
|
|
0
|
|
|
|
|
741
|
|
|
|
|
|
|
&& $l =~ /^v/ |
742
|
|
|
|
|
|
|
&& $r =~ /^v/) { |
743
|
0
|
|
|
|
|
0
|
$lvstring = $self->_vstring($l); |
744
|
0
|
|
|
|
|
0
|
$rvstring = $self->_vstring($r); |
745
|
0
|
|
|
|
|
0
|
$self->_verbose(9, sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring); |
746
|
|
|
|
|
|
|
} |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
return ( |
749
|
0
|
|
0
|
|
|
0
|
($l ne "undef") <=> ($r ne "undef") |
750
|
|
|
|
|
|
|
|| |
751
|
|
|
|
|
|
|
$lvstring cmp $rvstring |
752
|
|
|
|
|
|
|
|| |
753
|
|
|
|
|
|
|
$l <=> $r |
754
|
|
|
|
|
|
|
|| |
755
|
|
|
|
|
|
|
$l cmp $r |
756
|
|
|
|
|
|
|
); |
757
|
|
|
|
|
|
|
} |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
sub _vgt { |
760
|
0
|
|
|
0
|
|
0
|
my($self,$l,$r) = @_; |
761
|
0
|
|
|
|
|
0
|
$self->_vcmp($l,$r) > 0; |
762
|
|
|
|
|
|
|
} |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
sub _vlt { |
765
|
0
|
|
|
0
|
|
0
|
my($self,$l,$r) = @_; |
766
|
0
|
|
|
|
|
0
|
$self->_vcmp($l,$r) < 0; |
767
|
|
|
|
|
|
|
} |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
sub _vge { |
770
|
0
|
|
|
0
|
|
0
|
my($self,$l,$r) = @_; |
771
|
0
|
|
|
|
|
0
|
$self->_vcmp($l,$r) >= 0; |
772
|
|
|
|
|
|
|
} |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
sub _vle { |
775
|
0
|
|
|
0
|
|
0
|
my($self,$l,$r) = @_; |
776
|
0
|
|
|
|
|
0
|
$self->_vcmp($l,$r) <= 0; |
777
|
|
|
|
|
|
|
} |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
sub _vstring { |
780
|
0
|
|
|
0
|
|
0
|
my($self,$n) = @_; |
781
|
0
|
0
|
|
|
|
0
|
$n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]"; |
782
|
0
|
|
|
|
|
0
|
pack "U*", split /\./, $n; |
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
# vv => visible vstring |
786
|
|
|
|
|
|
|
sub _float2vv { |
787
|
0
|
|
|
0
|
|
0
|
my($self,$n) = @_; |
788
|
0
|
|
|
|
|
0
|
my($rev) = int($n); |
789
|
0
|
|
0
|
|
|
0
|
$rev ||= 0; |
790
|
0
|
|
|
|
|
0
|
my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit |
791
|
|
|
|
|
|
|
# architecture influence |
792
|
0
|
|
0
|
|
|
0
|
$mantissa ||= 0; |
793
|
0
|
|
|
|
|
0
|
$mantissa .= "0" while length($mantissa)%3; |
794
|
0
|
|
|
|
|
0
|
my $ret = "v" . $rev; |
795
|
0
|
|
|
|
|
0
|
while ($mantissa) { |
796
|
0
|
0
|
|
|
|
0
|
$mantissa =~ s/(\d{1,3})// or |
797
|
|
|
|
|
|
|
die "Panic: length>0 but not a digit? mantissa[$mantissa]"; |
798
|
0
|
|
|
|
|
0
|
$ret .= ".".int($1); |
799
|
|
|
|
|
|
|
} |
800
|
|
|
|
|
|
|
# warn "n[$n]ret[$ret]"; |
801
|
0
|
|
|
|
|
0
|
$ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0 |
802
|
0
|
|
|
|
|
0
|
$ret; |
803
|
|
|
|
|
|
|
} |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
sub _readable { |
806
|
141
|
|
|
141
|
|
713
|
my($self,$n) = @_; |
807
|
141
|
|
|
|
|
1284
|
$n =~ /^([\w\-\+\.]+)/; |
808
|
|
|
|
|
|
|
|
809
|
141
|
50
|
33
|
|
|
2845
|
return $1 if defined $1 && length($1)>0; |
810
|
|
|
|
|
|
|
# if the first user reaches version v43, he will be treated as "+". |
811
|
|
|
|
|
|
|
# We'll have to decide about a new rule here then, depending on what |
812
|
|
|
|
|
|
|
# will be the prevailing versioning behavior then. |
813
|
|
|
|
|
|
|
|
814
|
0
|
0
|
|
|
|
|
if ($] < 5.006) { # or whenever v-strings were introduced |
815
|
|
|
|
|
|
|
# we get them wrong anyway, whatever we do, because 5.005 will |
816
|
|
|
|
|
|
|
# have already interpreted 0.2.4 to be "0.24". So even if he |
817
|
|
|
|
|
|
|
# indexer sends us something like "v0.2.4" we compare wrongly. |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
# And if they say v1.2, then the old perl takes it as "v12" |
820
|
|
|
|
|
|
|
|
821
|
0
|
|
|
|
|
|
$self->_verbose(9, "Suspicious version string seen [$n]\n"); |
822
|
0
|
|
|
|
|
|
return $n; |
823
|
|
|
|
|
|
|
} |
824
|
0
|
|
|
|
|
|
my $better = sprintf "v%vd", $n; |
825
|
0
|
|
|
|
|
|
$self->_verbose(9, "n[$n] better[$better]"); |
826
|
0
|
|
|
|
|
|
return $better; |
827
|
|
|
|
|
|
|
} |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
1; |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
__END__ |